1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2017 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/>. */
27 #include <count-one-bits.h>
28 #include <count-trailing-zeros.h>
33 #include "character.h"
40 static void swap_in_symval_forwarding (struct Lisp_Symbol
*,
41 struct Lisp_Buffer_Local_Value
*);
44 BOOLFWDP (union Lisp_Fwd
*a
)
46 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
49 INTFWDP (union Lisp_Fwd
*a
)
51 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
54 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
56 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
59 OBJFWDP (union Lisp_Fwd
*a
)
61 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
64 static struct Lisp_Boolfwd
*
65 XBOOLFWD (union Lisp_Fwd
*a
)
67 eassert (BOOLFWDP (a
));
70 static struct Lisp_Kboard_Objfwd
*
71 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
73 eassert (KBOARD_OBJFWDP (a
));
74 return &a
->u_kboard_objfwd
;
76 static struct Lisp_Intfwd
*
77 XINTFWD (union Lisp_Fwd
*a
)
79 eassert (INTFWDP (a
));
82 static struct Lisp_Objfwd
*
83 XOBJFWD (union Lisp_Fwd
*a
)
85 eassert (OBJFWDP (a
));
90 CHECK_SUBR (Lisp_Object x
)
92 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
96 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
98 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
103 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
105 return XCDR (blv
->valcell
);
109 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
111 XSETCDR (blv
->valcell
, val
);
115 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
121 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
127 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
132 static _Noreturn
void
133 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
135 Lisp_Object size1
= make_number (bool_vector_size (a1
));
136 Lisp_Object size2
= make_number (bool_vector_size (a2
));
138 xsignal2 (Qwrong_length_argument
, size1
, size2
);
140 xsignal3 (Qwrong_length_argument
, size1
, size2
,
141 make_number (bool_vector_size (a3
)));
145 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
147 /* If VALUE is not even a valid Lisp object, we'd want to abort here
148 where we can get a backtrace showing where it came from. We used
149 to try and do that by checking the tagbits, but nowadays all
150 tagbits are potentially valid. */
151 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
154 xsignal2 (Qwrong_type_argument
, predicate
, value
);
158 pure_write_error (Lisp_Object obj
)
160 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
164 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
166 xsignal2 (Qargs_out_of_range
, a1
, a2
);
170 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
172 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
176 circular_list (Lisp_Object list
)
178 xsignal1 (Qcircular_list
, list
);
182 /* Data type predicates. */
184 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
185 doc
: /* Return t if the two args are the same Lisp object. */
187 (Lisp_Object obj1
, Lisp_Object obj2
)
194 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
195 doc
: /* Return t if OBJECT is nil, and return nil otherwise. */
204 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
205 doc
: /* Return a symbol representing the type of OBJECT.
206 The symbol returned names the object's basic type;
207 for example, (type-of 1) returns `integer'. */)
210 switch (XTYPE (object
))
225 switch (XMISCTYPE (object
))
227 case Lisp_Misc_Marker
:
229 case Lisp_Misc_Overlay
:
231 case Lisp_Misc_Float
:
233 case Lisp_Misc_Finalizer
:
236 case Lisp_Misc_User_Ptr
:
243 case Lisp_Vectorlike
:
244 switch (PSEUDOVECTOR_TYPE (XVECTOR (object
)))
246 case PVEC_NORMAL_VECTOR
: return Qvector
;
247 case PVEC_WINDOW_CONFIGURATION
: return Qwindow_configuration
;
248 case PVEC_PROCESS
: return Qprocess
;
249 case PVEC_WINDOW
: return Qwindow
;
250 case PVEC_SUBR
: return Qsubr
;
251 case PVEC_COMPILED
: return Qcompiled_function
;
252 case PVEC_BUFFER
: return Qbuffer
;
253 case PVEC_CHAR_TABLE
: return Qchar_table
;
254 case PVEC_BOOL_VECTOR
: return Qbool_vector
;
255 case PVEC_FRAME
: return Qframe
;
256 case PVEC_HASH_TABLE
: return Qhash_table
;
258 if (FONT_SPEC_P (object
))
260 if (FONT_ENTITY_P (object
))
262 if (FONT_OBJECT_P (object
))
265 emacs_abort (); /* return Qfont? */
266 case PVEC_THREAD
: return Qthread
;
267 case PVEC_MUTEX
: return Qmutex
;
268 case PVEC_CONDVAR
: return Qcondition_variable
;
269 case PVEC_TERMINAL
: return Qterminal
;
272 Lisp_Object t
= AREF (object
, 0);
273 if (RECORDP (t
) && 1 < PVSIZE (t
))
274 /* Return the type name field of the class! */
279 /* "Impossible" cases. */
282 case PVEC_XWIDGET_VIEW
:
283 case PVEC_SUB_CHAR_TABLE
:
296 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
297 doc
: /* Return t if OBJECT is a cons cell. */
306 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */
316 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
317 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
318 Otherwise, return nil. */
322 if (CONSP (object
) || NILP (object
))
327 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
328 doc
: /* Return t if OBJECT is not a list. Lists include nil. */
332 if (CONSP (object
) || NILP (object
))
337 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
338 doc
: /* Return t if OBJECT is a symbol. */
342 if (SYMBOLP (object
))
347 /* Define this in C to avoid unnecessarily consing up the symbol
349 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
350 doc
: /* Return t if OBJECT is a keyword.
351 This means that it is a symbol with a print name beginning with `:'
352 interned in the initial obarray. */)
356 && SREF (SYMBOL_NAME (object
), 0) == ':'
357 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
362 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a vector. */)
366 if (VECTORP (object
))
371 DEFUN ("recordp", Frecordp
, Srecordp
, 1, 1, 0,
372 doc
: /* Return t if OBJECT is a record. */)
375 if (RECORDP (object
))
380 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
381 doc
: /* Return t if OBJECT is a string. */
385 if (STRINGP (object
))
390 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
392 doc
: /* Return t if OBJECT is a multibyte string.
393 Return nil if OBJECT is either a unibyte string, or not a string. */)
396 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
401 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
402 doc
: /* Return t if OBJECT is a char-table. */)
405 if (CHAR_TABLE_P (object
))
410 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
411 Svector_or_char_table_p
, 1, 1, 0,
412 doc
: /* Return t if OBJECT is a char-table or vector. */)
415 if (VECTORP (object
) || CHAR_TABLE_P (object
))
420 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
421 doc
: /* Return t if OBJECT is a bool-vector. */)
424 if (BOOL_VECTOR_P (object
))
429 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
430 doc
: /* Return t if OBJECT is an array (string or vector). */)
438 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
439 doc
: /* Return t if OBJECT is a sequence (list or array). */)
440 (register Lisp_Object object
)
442 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
447 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
448 doc
: /* Return t if OBJECT is an editor buffer. */)
451 if (BUFFERP (object
))
456 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
457 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
460 if (MARKERP (object
))
466 DEFUN ("user-ptrp", Fuser_ptrp
, Suser_ptrp
, 1, 1, 0,
467 doc
: /* Return t if OBJECT is a module user pointer. */)
470 if (USER_PTRP (object
))
476 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
477 doc
: /* Return t if OBJECT is a built-in function. */)
485 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
487 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
490 if (COMPILEDP (object
))
495 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
496 doc
: /* Return t if OBJECT is a character or a string. */
498 (register Lisp_Object object
)
500 if (CHARACTERP (object
) || STRINGP (object
))
505 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
506 doc
: /* Return t if OBJECT is an integer. */
510 if (INTEGERP (object
))
515 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
516 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
517 (register Lisp_Object object
)
519 if (MARKERP (object
) || INTEGERP (object
))
524 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
525 doc
: /* Return t if OBJECT is a nonnegative integer. */
529 if (NATNUMP (object
))
534 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
535 doc
: /* Return t if OBJECT is a number (floating point or integer). */
539 if (NUMBERP (object
))
545 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
546 Snumber_or_marker_p
, 1, 1, 0,
547 doc
: /* Return t if OBJECT is a number or a marker. */)
550 if (NUMBERP (object
) || MARKERP (object
))
555 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
556 doc
: /* Return t if OBJECT is a floating point number. */
565 DEFUN ("threadp", Fthreadp
, Sthreadp
, 1, 1, 0,
566 doc
: /* Return t if OBJECT is a thread. */)
569 if (THREADP (object
))
574 DEFUN ("mutexp", Fmutexp
, Smutexp
, 1, 1, 0,
575 doc
: /* Return t if OBJECT is a mutex. */)
583 DEFUN ("condition-variable-p", Fcondition_variable_p
, Scondition_variable_p
,
585 doc
: /* Return t if OBJECT is a condition variable. */)
588 if (CONDVARP (object
))
593 /* Extract and set components of lists. */
595 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
596 doc
: /* Return the car of LIST. If arg is nil, return nil.
597 Error if arg is not nil and not a cons cell. See also `car-safe'.
599 See Info node `(elisp)Cons Cells' for a discussion of related basic
600 Lisp concepts such as car, cdr, cons cell and list. */)
601 (register Lisp_Object list
)
606 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
607 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
610 return CAR_SAFE (object
);
613 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
614 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
615 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
617 See Info node `(elisp)Cons Cells' for a discussion of related basic
618 Lisp concepts such as cdr, car, cons cell and list. */)
619 (register Lisp_Object list
)
624 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
625 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
628 return CDR_SAFE (object
);
631 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
632 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
633 (register Lisp_Object cell
, Lisp_Object newcar
)
636 CHECK_IMPURE (cell
, XCONS (cell
));
637 XSETCAR (cell
, newcar
);
641 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
642 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
643 (register Lisp_Object cell
, Lisp_Object newcdr
)
646 CHECK_IMPURE (cell
, XCONS (cell
));
647 XSETCDR (cell
, newcdr
);
651 /* Extract and set components of symbols. */
653 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
654 doc
: /* Return t if SYMBOL's value is not void.
655 Note that if `lexical-binding' is in effect, this refers to the
656 global value outside of any lexical scope. */)
657 (register Lisp_Object symbol
)
659 Lisp_Object valcontents
;
660 struct Lisp_Symbol
*sym
;
661 CHECK_SYMBOL (symbol
);
662 sym
= XSYMBOL (symbol
);
665 switch (sym
->redirect
)
667 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
668 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
669 case SYMBOL_LOCALIZED
:
671 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
673 /* In set_internal, we un-forward vars when their value is
678 swap_in_symval_forwarding (sym
, blv
);
679 valcontents
= blv_value (blv
);
683 case SYMBOL_FORWARDED
:
684 /* In set_internal, we un-forward vars when their value is
687 default: emacs_abort ();
690 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
693 /* FIXME: It has been previously suggested to make this function an
694 alias for symbol-function, but upon discussion at Bug#23957,
695 there is a risk breaking backward compatibility, as some users of
696 fboundp may expect `t' in particular, rather than any true
697 value. An alias is still welcome so long as the compatibility
698 issues are addressed. */
699 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
700 doc
: /* Return t if SYMBOL's function definition is not void. */)
701 (register Lisp_Object symbol
)
703 CHECK_SYMBOL (symbol
);
704 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
707 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
708 doc
: /* Make SYMBOL's value be void.
710 (register Lisp_Object symbol
)
712 CHECK_SYMBOL (symbol
);
713 if (SYMBOL_CONSTANT_P (symbol
))
714 xsignal1 (Qsetting_constant
, symbol
);
715 Fset (symbol
, Qunbound
);
719 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
720 doc
: /* Make SYMBOL's function definition be nil.
722 (register Lisp_Object symbol
)
724 CHECK_SYMBOL (symbol
);
725 if (NILP (symbol
) || EQ (symbol
, Qt
))
726 xsignal1 (Qsetting_constant
, symbol
);
727 set_symbol_function (symbol
, Qnil
);
731 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
732 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
733 (register Lisp_Object symbol
)
735 CHECK_SYMBOL (symbol
);
736 return XSYMBOL (symbol
)->function
;
739 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
740 doc
: /* Return SYMBOL's property list. */)
741 (register Lisp_Object symbol
)
743 CHECK_SYMBOL (symbol
);
744 return XSYMBOL (symbol
)->plist
;
747 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
748 doc
: /* Return SYMBOL's name, a string. */)
749 (register Lisp_Object symbol
)
751 register Lisp_Object name
;
753 CHECK_SYMBOL (symbol
);
754 name
= SYMBOL_NAME (symbol
);
758 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
759 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
760 (register Lisp_Object symbol
, Lisp_Object definition
)
762 register Lisp_Object function
;
763 CHECK_SYMBOL (symbol
);
764 /* Perhaps not quite the right error signal, but seems good enough. */
766 xsignal1 (Qsetting_constant
, symbol
);
768 function
= XSYMBOL (symbol
)->function
;
770 if (!NILP (Vautoload_queue
) && !NILP (function
))
771 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
773 if (AUTOLOADP (function
))
774 Fput (symbol
, Qautoload
, XCDR (function
));
776 /* Convert to eassert or remove after GC bug is found. In the
777 meantime, check unconditionally, at a slight perf hit. */
778 if (! valid_lisp_object_p (definition
))
781 set_symbol_function (symbol
, definition
);
786 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
787 doc
: /* Set SYMBOL's function definition to DEFINITION.
788 Associates the function with the current load file, if any.
789 The optional third argument DOCSTRING specifies the documentation string
790 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
791 determined by DEFINITION.
793 Internally, this normally uses `fset', but if SYMBOL has a
794 `defalias-fset-function' property, the associated value is used instead.
796 The return value is undefined. */)
797 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
799 CHECK_SYMBOL (symbol
);
800 if (!NILP (Vpurify_flag
)
801 /* If `definition' is a keymap, immutable (and copying) is wrong. */
802 && !KEYMAPP (definition
))
803 definition
= Fpurecopy (definition
);
806 bool autoload
= AUTOLOADP (definition
);
807 if (NILP (Vpurify_flag
) || !autoload
)
808 { /* Only add autoload entries after dumping, because the ones before are
809 not useful and else we get loads of them from the loaddefs.el. */
811 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
812 /* Remember that the function was already an autoload. */
813 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
814 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
818 { /* Handle automatic advice activation. */
819 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
821 call2 (hook
, symbol
, definition
);
823 Ffset (symbol
, definition
);
826 if (!NILP (docstring
))
827 Fput (symbol
, Qfunction_documentation
, docstring
);
828 /* We used to return `definition', but now that `defun' and `defmacro' expand
829 to a call to `defalias', we return `symbol' for backward compatibility
834 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
835 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
836 (register Lisp_Object symbol
, Lisp_Object newplist
)
838 CHECK_SYMBOL (symbol
);
839 set_symbol_plist (symbol
, newplist
);
843 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
844 doc
: /* Return minimum and maximum number of args allowed for SUBR.
845 SUBR must be a built-in function.
846 The returned value is a pair (MIN . MAX). MIN is the minimum number
847 of args. MAX is the maximum number or the symbol `many', for a
848 function with `&rest' args, or `unevalled' for a special form. */)
851 short minargs
, maxargs
;
853 minargs
= XSUBR (subr
)->min_args
;
854 maxargs
= XSUBR (subr
)->max_args
;
855 return Fcons (make_number (minargs
),
856 maxargs
== MANY
? Qmany
857 : maxargs
== UNEVALLED
? Qunevalled
858 : make_number (maxargs
));
861 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
862 doc
: /* Return name of subroutine SUBR.
863 SUBR must be a built-in function. */)
868 name
= XSUBR (subr
)->symbol_name
;
869 return build_string (name
);
872 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
873 doc
: /* Return the interactive form of CMD or nil if none.
874 If CMD is not a command, the return value is nil.
875 Value, if non-nil, is a list (interactive SPEC). */)
878 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
883 /* Use an `interactive-form' property if present, analogous to the
884 function-documentation property. */
886 while (SYMBOLP (fun
))
888 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
892 fun
= Fsymbol_function (fun
);
897 const char *spec
= XSUBR (fun
)->intspec
;
899 return list2 (Qinteractive
,
900 (*spec
!= '(') ? build_string (spec
) :
901 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
903 else if (COMPILEDP (fun
))
905 if (PVSIZE (fun
) > COMPILED_INTERACTIVE
)
906 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
908 else if (AUTOLOADP (fun
))
909 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
910 else if (CONSP (fun
))
912 Lisp_Object funcar
= XCAR (fun
);
913 if (EQ (funcar
, Qclosure
))
914 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
915 else if (EQ (funcar
, Qlambda
))
916 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
922 /***********************************************************************
923 Getting and Setting Values of Symbols
924 ***********************************************************************/
926 /* Return the symbol holding SYMBOL's value. Signal
927 `cyclic-variable-indirection' if SYMBOL's chain of variable
928 indirections contains a loop. */
931 indirect_variable (struct Lisp_Symbol
*symbol
)
933 struct Lisp_Symbol
*tortoise
, *hare
;
935 hare
= tortoise
= symbol
;
937 while (hare
->redirect
== SYMBOL_VARALIAS
)
939 hare
= SYMBOL_ALIAS (hare
);
940 if (hare
->redirect
!= SYMBOL_VARALIAS
)
943 hare
= SYMBOL_ALIAS (hare
);
944 tortoise
= SYMBOL_ALIAS (tortoise
);
946 if (hare
== tortoise
)
949 XSETSYMBOL (tem
, symbol
);
950 xsignal1 (Qcyclic_variable_indirection
, tem
);
958 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
959 doc
: /* Return the variable at the end of OBJECT's variable chain.
960 If OBJECT is a symbol, follow its variable indirections (if any), and
961 return the variable at the end of the chain of aliases. See Info node
962 `(elisp)Variable Aliases'.
964 If OBJECT is not a symbol, just return it. If there is a loop in the
965 chain of aliases, signal a `cyclic-variable-indirection' error. */)
968 if (SYMBOLP (object
))
970 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
971 XSETSYMBOL (object
, sym
);
977 /* Given the raw contents of a symbol value cell,
978 return the Lisp value of the symbol.
979 This does not handle buffer-local variables; use
980 swap_in_symval_forwarding for that. */
983 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
985 register Lisp_Object val
;
986 switch (XFWDTYPE (valcontents
))
989 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
993 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
996 return *XOBJFWD (valcontents
)->objvar
;
998 case Lisp_Fwd_Buffer_Obj
:
999 return per_buffer_value (current_buffer
,
1000 XBUFFER_OBJFWD (valcontents
)->offset
);
1002 case Lisp_Fwd_Kboard_Obj
:
1003 /* We used to simply use current_kboard here, but from Lisp
1004 code, its value is often unexpected. It seems nicer to
1005 allow constructions like this to work as intuitively expected:
1007 (with-selected-frame frame
1008 (define-key local-function-map "\eOP" [f1]))
1010 On the other hand, this affects the semantics of
1011 last-command and real-last-command, and people may rely on
1012 that. I took a quick look at the Lisp codebase, and I
1013 don't think anything will break. --lorentey */
1014 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1015 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1016 default: emacs_abort ();
1020 /* Used to signal a user-friendly error when symbol WRONG is
1021 not a member of CHOICE, which should be a list of symbols. */
1024 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
1026 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
1027 Lisp_Object obj
, *args
;
1028 AUTO_STRING (one_of
, "One of ");
1029 AUTO_STRING (comma
, ", ");
1030 AUTO_STRING (or, " or ");
1031 AUTO_STRING (should_be_specified
, " should be specified");
1034 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
1038 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
1040 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
1041 args
[i
++] = (NILP (XCDR (obj
)) ? should_be_specified
1042 : NILP (XCDR (XCDR (obj
))) ? or : comma
);
1045 obj
= Fconcat (i
, args
);
1047 xsignal2 (Qerror
, obj
, wrong
);
1050 /* Used to signal a user-friendly error if WRONG is not a number or
1051 integer/floating-point number outsize of inclusive MIN..MAX range. */
1054 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
1056 AUTO_STRING (value_should_be_from
, "Value should be from ");
1057 AUTO_STRING (to
, " to ");
1059 CALLN (Fconcat
, value_should_be_from
, Fnumber_to_string (min
),
1060 to
, Fnumber_to_string (max
)),
1064 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1065 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1066 buffer-independent contents of the value cell: forwarded just one
1067 step past the buffer-localness.
1069 BUF non-zero means set the value in buffer BUF instead of the
1070 current buffer. This only plays a role for per-buffer variables. */
1073 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
1075 switch (XFWDTYPE (valcontents
))
1078 CHECK_NUMBER (newval
);
1079 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1083 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1087 *XOBJFWD (valcontents
)->objvar
= newval
;
1089 /* If this variable is a default for something stored
1090 in the buffer itself, such as default-fill-column,
1091 find the buffers that don't have local values for it
1093 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1094 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1096 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1097 - (char *) &buffer_defaults
);
1098 int idx
= PER_BUFFER_IDX (offset
);
1100 Lisp_Object tail
, buf
;
1105 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1107 struct buffer
*b
= XBUFFER (buf
);
1109 if (! PER_BUFFER_VALUE_P (b
, idx
))
1110 set_per_buffer_value (b
, offset
, newval
);
1115 case Lisp_Fwd_Buffer_Obj
:
1117 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1118 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1122 if (SYMBOLP (predicate
))
1126 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1128 if (NILP (Fmemq (newval
, prop
)))
1129 wrong_choice (prop
, newval
);
1131 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1133 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1134 if (! NUMBERP (newval
)
1135 || NILP (CALLN (Fleq
, min
, newval
, max
)))
1136 wrong_range (min
, max
, newval
);
1138 else if (FUNCTIONP (predicate
))
1140 if (NILP (call1 (predicate
, newval
)))
1141 wrong_type_argument (predicate
, newval
);
1146 buf
= current_buffer
;
1147 set_per_buffer_value (buf
, offset
, newval
);
1151 case Lisp_Fwd_Kboard_Obj
:
1153 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1154 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1155 *(Lisp_Object
*) p
= newval
;
1160 emacs_abort (); /* goto def; */
1164 /* Set up SYMBOL to refer to its global binding. This makes it safe
1165 to alter the status of other bindings. BEWARE: this may be called
1166 during the mark phase of GC, where we assume that Lisp_Object slots
1167 of BLV are marked after this function has changed them. */
1170 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1172 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1174 /* Unload the previously loaded binding. */
1176 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1178 /* Select the global binding in the symbol. */
1179 set_blv_valcell (blv
, blv
->defcell
);
1181 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1183 /* Indicate that the global binding is set up now. */
1184 set_blv_where (blv
, Qnil
);
1185 set_blv_found (blv
, 0);
1188 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1189 VALCONTENTS is the contents of its value cell,
1190 which points to a struct Lisp_Buffer_Local_Value.
1192 Return the value forwarded one step past the buffer-local stage.
1193 This could be another forwarding pointer. */
1196 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1198 register Lisp_Object tem1
;
1200 eassert (blv
== SYMBOL_BLV (symbol
));
1205 || current_buffer
!= XBUFFER (tem1
))
1208 /* Unload the previously loaded binding. */
1209 tem1
= blv
->valcell
;
1211 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1212 /* Choose the new binding. */
1215 XSETSYMBOL (var
, symbol
);
1216 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1217 set_blv_where (blv
, Fcurrent_buffer ());
1219 if (!(blv
->found
= !NILP (tem1
)))
1220 tem1
= blv
->defcell
;
1222 /* Load the new binding. */
1223 set_blv_valcell (blv
, tem1
);
1225 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1229 /* Find the value of a symbol, returning Qunbound if it's not bound.
1230 This is helpful for code which just wants to get a variable's value
1231 if it has one, without signaling an error.
1232 Note that it must not be possible to quit
1233 within this function. Great care is required for this. */
1236 find_symbol_value (Lisp_Object symbol
)
1238 struct Lisp_Symbol
*sym
;
1240 CHECK_SYMBOL (symbol
);
1241 sym
= XSYMBOL (symbol
);
1244 switch (sym
->redirect
)
1246 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1247 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1248 case SYMBOL_LOCALIZED
:
1250 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1251 swap_in_symval_forwarding (sym
, blv
);
1252 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1255 case SYMBOL_FORWARDED
:
1256 return do_symval_forwarding (SYMBOL_FWD (sym
));
1257 default: emacs_abort ();
1261 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1262 doc
: /* Return SYMBOL's value. Error if that is void.
1263 Note that if `lexical-binding' is in effect, this returns the
1264 global value outside of any lexical scope. */)
1265 (Lisp_Object symbol
)
1269 val
= find_symbol_value (symbol
);
1270 if (!EQ (val
, Qunbound
))
1273 xsignal1 (Qvoid_variable
, symbol
);
1276 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1277 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1278 (register Lisp_Object symbol
, Lisp_Object newval
)
1280 set_internal (symbol
, newval
, Qnil
, SET_INTERNAL_SET
);
1284 /* Store the value NEWVAL into SYMBOL.
1285 If buffer-locality is an issue, WHERE specifies which context to use.
1286 (nil stands for the current buffer/frame).
1288 If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to
1289 become local in every buffer where it is set, then we make it
1290 local. If BINDFLAG is SET_INTERNAL_BIND or SET_INTERNAL_UNBIND, we
1294 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1295 enum Set_Internal_Bind bindflag
)
1297 bool voide
= EQ (newval
, Qunbound
);
1298 struct Lisp_Symbol
*sym
;
1301 /* If restoring in a dead buffer, do nothing. */
1302 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1305 CHECK_SYMBOL (symbol
);
1306 sym
= XSYMBOL (symbol
);
1307 switch (sym
->trapped_write
)
1309 case SYMBOL_NOWRITE
:
1310 if (NILP (Fkeywordp (symbol
))
1311 || !EQ (newval
, Fsymbol_value (symbol
)))
1312 xsignal1 (Qsetting_constant
, symbol
);
1314 /* Allow setting keywords to their own value. */
1317 case SYMBOL_TRAPPED_WRITE
:
1318 /* Setting due to thread-switching doesn't count. */
1319 if (bindflag
!= SET_INTERNAL_THREAD_SWITCH
)
1320 notify_variable_watchers (symbol
, voide
? Qnil
: newval
,
1321 (bindflag
== SET_INTERNAL_BIND
? Qlet
:
1322 bindflag
== SET_INTERNAL_UNBIND
? Qunlet
:
1323 voide
? Qmakunbound
: Qset
),
1326 case SYMBOL_UNTRAPPED_WRITE
:
1329 default: emacs_abort ();
1333 switch (sym
->redirect
)
1335 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1336 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1337 case SYMBOL_LOCALIZED
:
1339 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1341 XSETBUFFER (where
, current_buffer
);
1343 /* If the current buffer is not the buffer whose binding is
1344 loaded, or if it's a Lisp_Buffer_Local_Value and
1345 the default binding is loaded, the loaded binding may be the
1347 if (!EQ (blv
->where
, where
)
1348 /* Also unload a global binding (if the var is local_if_set). */
1349 || (EQ (blv
->valcell
, blv
->defcell
)))
1351 /* The currently loaded binding is not necessarily valid.
1352 We need to unload it, and choose a new binding. */
1354 /* Write out `realvalue' to the old loaded binding. */
1356 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1358 /* Find the new binding. */
1359 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1360 tem1
= assq_no_quit (symbol
,
1361 BVAR (XBUFFER (where
), local_var_alist
));
1362 set_blv_where (blv
, where
);
1367 /* This buffer still sees the default value. */
1369 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1370 or if this is `let' rather than `set',
1371 make CURRENT-ALIST-ELEMENT point to itself,
1372 indicating that we're seeing the default value.
1373 Likewise if the variable has been let-bound
1374 in the current buffer. */
1375 if (bindflag
|| !blv
->local_if_set
1376 || let_shadows_buffer_binding_p (sym
))
1379 tem1
= blv
->defcell
;
1381 /* If it's a local_if_set, being set not bound,
1382 and we're not within a let that was made for this buffer,
1383 create a new buffer-local binding for the variable.
1384 That means, give this buffer a new assoc for a local value
1385 and load that binding. */
1388 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1389 bset_local_var_alist
1391 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1395 /* Record which binding is now loaded. */
1396 set_blv_valcell (blv
, tem1
);
1399 /* Store the new value in the cons cell. */
1400 set_blv_value (blv
, newval
);
1405 /* If storing void (making the symbol void), forward only through
1406 buffer-local indicator, not through Lisp_Objfwd, etc. */
1409 store_symval_forwarding (blv
->fwd
, newval
,
1411 ? XBUFFER (where
) : current_buffer
);
1415 case SYMBOL_FORWARDED
:
1418 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1419 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1420 if (BUFFER_OBJFWDP (innercontents
))
1422 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1423 int idx
= PER_BUFFER_IDX (offset
);
1425 && bindflag
== SET_INTERNAL_SET
1426 && !let_shadows_buffer_binding_p (sym
))
1427 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1431 { /* If storing void (making the symbol void), forward only through
1432 buffer-local indicator, not through Lisp_Objfwd, etc. */
1433 sym
->redirect
= SYMBOL_PLAINVAL
;
1434 SET_SYMBOL_VAL (sym
, newval
);
1437 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1440 default: emacs_abort ();
1446 set_symbol_trapped_write (Lisp_Object symbol
, enum symbol_trapped_write trap
)
1448 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1449 if (sym
->trapped_write
== SYMBOL_NOWRITE
)
1450 xsignal1 (Qtrapping_constant
, symbol
);
1451 sym
->trapped_write
= trap
;
1455 restore_symbol_trapped_write (Lisp_Object symbol
)
1457 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1461 harmonize_variable_watchers (Lisp_Object alias
, Lisp_Object base_variable
)
1463 if (!EQ (base_variable
, alias
)
1464 && EQ (base_variable
, Findirect_variable (alias
)))
1465 set_symbol_trapped_write
1466 (alias
, XSYMBOL (base_variable
)->trapped_write
);
1469 DEFUN ("add-variable-watcher", Fadd_variable_watcher
, Sadd_variable_watcher
,
1471 doc
: /* Cause WATCH-FUNCTION to be called when SYMBOL is set.
1473 It will be called with 4 arguments: (SYMBOL NEWVAL OPERATION WHERE).
1474 SYMBOL is the variable being changed.
1475 NEWVAL is the value it will be changed to.
1476 OPERATION is a symbol representing the kind of change, one of: `set',
1477 `let', `unlet', `makunbound', and `defvaralias'.
1478 WHERE is a buffer if the buffer-local value of the variable being
1479 changed, nil otherwise.
1481 All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */)
1482 (Lisp_Object symbol
, Lisp_Object watch_function
)
1484 symbol
= Findirect_variable (symbol
);
1485 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1486 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1488 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1489 Lisp_Object member
= Fmember (watch_function
, watchers
);
1491 Fput (symbol
, Qwatchers
, Fcons (watch_function
, watchers
));
1495 DEFUN ("remove-variable-watcher", Fremove_variable_watcher
, Sremove_variable_watcher
,
1497 doc
: /* Undo the effect of `add-variable-watcher'.
1498 Remove WATCH-FUNCTION from the list of functions to be called when
1499 SYMBOL (or its aliases) are set. */)
1500 (Lisp_Object symbol
, Lisp_Object watch_function
)
1502 symbol
= Findirect_variable (symbol
);
1503 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1504 watchers
= Fdelete (watch_function
, watchers
);
1505 if (NILP (watchers
))
1507 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1508 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1510 Fput (symbol
, Qwatchers
, watchers
);
1514 DEFUN ("get-variable-watchers", Fget_variable_watchers
, Sget_variable_watchers
,
1516 doc
: /* Return a list of SYMBOL's active watchers. */)
1517 (Lisp_Object symbol
)
1519 return (SYMBOL_TRAPPED_WRITE_P (symbol
) == SYMBOL_TRAPPED_WRITE
)
1520 ? Fget (Findirect_variable (symbol
), Qwatchers
)
1525 notify_variable_watchers (Lisp_Object symbol
,
1527 Lisp_Object operation
,
1530 symbol
= Findirect_variable (symbol
);
1532 ptrdiff_t count
= SPECPDL_INDEX ();
1533 record_unwind_protect (restore_symbol_trapped_write
, symbol
);
1534 /* Avoid recursion. */
1535 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1538 && !EQ (operation
, Qset_default
) && !EQ (operation
, Qmakunbound
)
1539 && !NILP (Flocal_variable_if_set_p (symbol
, Fcurrent_buffer ())))
1541 XSETBUFFER (where
, current_buffer
);
1544 if (EQ (operation
, Qset_default
))
1547 for (Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1549 watchers
= XCDR (watchers
))
1551 Lisp_Object watcher
= XCAR (watchers
);
1552 /* Call subr directly to avoid gc. */
1553 if (SUBRP (watcher
))
1555 Lisp_Object args
[] = { symbol
, newval
, operation
, where
};
1556 funcall_subr (XSUBR (watcher
), ARRAYELTS (args
), args
);
1559 CALLN (Ffuncall
, watcher
, symbol
, newval
, operation
, where
);
1562 unbind_to (count
, Qnil
);
1566 /* Access or set a buffer-local symbol's default value. */
1568 /* Return the default value of SYMBOL, but don't check for voidness.
1569 Return Qunbound if it is void. */
1572 default_value (Lisp_Object symbol
)
1574 struct Lisp_Symbol
*sym
;
1576 CHECK_SYMBOL (symbol
);
1577 sym
= XSYMBOL (symbol
);
1580 switch (sym
->redirect
)
1582 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1583 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1584 case SYMBOL_LOCALIZED
:
1586 /* If var is set up for a buffer that lacks a local value for it,
1587 the current value is nominally the default value.
1588 But the `realvalue' slot may be more up to date, since
1589 ordinary setq stores just that slot. So use that. */
1590 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1591 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1592 return do_symval_forwarding (blv
->fwd
);
1594 return XCDR (blv
->defcell
);
1596 case SYMBOL_FORWARDED
:
1598 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1600 /* For a built-in buffer-local variable, get the default value
1601 rather than letting do_symval_forwarding get the current value. */
1602 if (BUFFER_OBJFWDP (valcontents
))
1604 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1605 if (PER_BUFFER_IDX (offset
) != 0)
1606 return per_buffer_default (offset
);
1609 /* For other variables, get the current value. */
1610 return do_symval_forwarding (valcontents
);
1612 default: emacs_abort ();
1616 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1617 doc
: /* Return t if SYMBOL has a non-void default value.
1618 This is the value that is seen in buffers that do not have their own values
1619 for this variable. */)
1620 (Lisp_Object symbol
)
1622 register Lisp_Object value
;
1624 value
= default_value (symbol
);
1625 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1628 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1629 doc
: /* Return SYMBOL's default value.
1630 This is the value that is seen in buffers that do not have their own values
1631 for this variable. The default value is meaningful for variables with
1632 local bindings in certain buffers. */)
1633 (Lisp_Object symbol
)
1635 Lisp_Object value
= default_value (symbol
);
1636 if (!EQ (value
, Qunbound
))
1639 xsignal1 (Qvoid_variable
, symbol
);
1643 set_default_internal (Lisp_Object symbol
, Lisp_Object value
,
1644 enum Set_Internal_Bind bindflag
)
1646 struct Lisp_Symbol
*sym
;
1648 CHECK_SYMBOL (symbol
);
1649 sym
= XSYMBOL (symbol
);
1650 switch (sym
->trapped_write
)
1652 case SYMBOL_NOWRITE
:
1653 if (NILP (Fkeywordp (symbol
))
1654 || !EQ (value
, Fsymbol_value (symbol
)))
1655 xsignal1 (Qsetting_constant
, symbol
);
1657 /* Allow setting keywords to their own value. */
1660 case SYMBOL_TRAPPED_WRITE
:
1661 /* Don't notify here if we're going to call Fset anyway. */
1662 if (sym
->redirect
!= SYMBOL_PLAINVAL
1663 /* Setting due to thread switching doesn't count. */
1664 && bindflag
!= SET_INTERNAL_THREAD_SWITCH
)
1665 notify_variable_watchers (symbol
, value
, Qset_default
, Qnil
);
1667 case SYMBOL_UNTRAPPED_WRITE
:
1670 default: emacs_abort ();
1674 switch (sym
->redirect
)
1676 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1677 case SYMBOL_PLAINVAL
: set_internal (symbol
, value
, Qnil
, bindflag
); return;
1678 case SYMBOL_LOCALIZED
:
1680 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1682 /* Store new value into the DEFAULT-VALUE slot. */
1683 XSETCDR (blv
->defcell
, value
);
1685 /* If the default binding is now loaded, set the REALVALUE slot too. */
1686 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1687 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1690 case SYMBOL_FORWARDED
:
1692 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1694 /* Handle variables like case-fold-search that have special slots
1696 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1697 if (BUFFER_OBJFWDP (valcontents
))
1699 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1700 int idx
= PER_BUFFER_IDX (offset
);
1702 set_per_buffer_default (offset
, value
);
1704 /* If this variable is not always local in all buffers,
1705 set it in the buffers that don't nominally have a local value. */
1711 if (!PER_BUFFER_VALUE_P (b
, idx
))
1712 set_per_buffer_value (b
, offset
, value
);
1716 set_internal (symbol
, value
, Qnil
, bindflag
);
1719 default: emacs_abort ();
1723 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1724 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1725 The default value is seen in buffers that do not have their own values
1726 for this variable. */)
1727 (Lisp_Object symbol
, Lisp_Object value
)
1729 set_default_internal (symbol
, value
, SET_INTERNAL_SET
);
1733 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1734 doc
: /* Set the default value of variable VAR to VALUE.
1735 VAR, the variable name, is literal (not evaluated);
1736 VALUE is an expression: it is evaluated and its value returned.
1737 The default value of a variable is seen in buffers
1738 that do not have their own values for the variable.
1740 More generally, you can use multiple variables and values, as in
1741 (setq-default VAR VALUE VAR VALUE...)
1742 This sets each VAR's default value to the corresponding VALUE.
1743 The VALUE for the Nth VAR can refer to the new default values
1745 usage: (setq-default [VAR VALUE]...) */)
1748 Lisp_Object args_left
, symbol
, val
;
1750 args_left
= val
= args
;
1752 while (CONSP (args_left
))
1754 val
= eval_sub (Fcar (XCDR (args_left
)));
1755 symbol
= XCAR (args_left
);
1756 Fset_default (symbol
, val
);
1757 args_left
= Fcdr (XCDR (args_left
));
1763 /* Lisp functions for creating and removing buffer-local variables. */
1768 union Lisp_Fwd
*fwd
;
1771 static struct Lisp_Buffer_Local_Value
*
1772 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1773 union Lisp_Val_Fwd valcontents
)
1775 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1779 XSETSYMBOL (symbol
, sym
);
1780 tem
= Fcons (symbol
, (forwarded
1781 ? do_symval_forwarding (valcontents
.fwd
)
1782 : valcontents
.value
));
1784 /* Buffer_Local_Values cannot have as realval a buffer-local
1785 or keyboard-local forwarding. */
1786 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1787 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1788 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1789 set_blv_where (blv
, Qnil
);
1790 blv
->local_if_set
= 0;
1791 set_blv_defcell (blv
, tem
);
1792 set_blv_valcell (blv
, tem
);
1793 set_blv_found (blv
, 0);
1797 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1798 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1799 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1800 At any time, the value for the current buffer is in effect,
1801 unless the variable has never been set in this buffer,
1802 in which case the default value is in effect.
1803 Note that binding the variable with `let', or setting it while
1804 a `let'-style binding made in this buffer is in effect,
1805 does not make the variable buffer-local. Return VARIABLE.
1807 This globally affects all uses of this variable, so it belongs together with
1808 the variable declaration, rather than with its uses (if you just want to make
1809 a variable local to the current buffer for one particular use, use
1810 `make-local-variable'). Buffer-local bindings are normally cleared
1811 while setting up a new major mode, unless they have a `permanent-local'
1814 The function `default-value' gets the default value and `set-default' sets it. */)
1815 (register Lisp_Object variable
)
1817 struct Lisp_Symbol
*sym
;
1818 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1819 union Lisp_Val_Fwd valcontents
;
1822 CHECK_SYMBOL (variable
);
1823 sym
= XSYMBOL (variable
);
1826 switch (sym
->redirect
)
1828 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1829 case SYMBOL_PLAINVAL
:
1830 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1831 if (EQ (valcontents
.value
, Qunbound
))
1832 valcontents
.value
= Qnil
;
1834 case SYMBOL_LOCALIZED
:
1835 blv
= SYMBOL_BLV (sym
);
1837 case SYMBOL_FORWARDED
:
1838 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1839 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1840 error ("Symbol %s may not be buffer-local",
1841 SDATA (SYMBOL_NAME (variable
)));
1842 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1845 default: emacs_abort ();
1848 if (SYMBOL_CONSTANT_P (variable
))
1849 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1853 blv
= make_blv (sym
, forwarded
, valcontents
);
1854 sym
->redirect
= SYMBOL_LOCALIZED
;
1855 SET_SYMBOL_BLV (sym
, blv
);
1858 blv
->local_if_set
= 1;
1862 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1863 1, 1, "vMake Local Variable: ",
1864 doc
: /* Make VARIABLE have a separate value in the current buffer.
1865 Other buffers will continue to share a common default value.
1866 \(The buffer-local value of VARIABLE starts out as the same value
1867 VARIABLE previously had. If VARIABLE was void, it remains void.)
1870 If the variable is already arranged to become local when set,
1871 this function causes a local value to exist for this buffer,
1872 just as setting the variable would do.
1874 This function returns VARIABLE, and therefore
1875 (set (make-local-variable \\='VARIABLE) VALUE-EXP)
1878 See also `make-variable-buffer-local'.
1880 Do not use `make-local-variable' to make a hook variable buffer-local.
1881 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1882 (Lisp_Object variable
)
1886 union Lisp_Val_Fwd valcontents
;
1887 struct Lisp_Symbol
*sym
;
1888 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1890 CHECK_SYMBOL (variable
);
1891 sym
= XSYMBOL (variable
);
1894 switch (sym
->redirect
)
1896 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1897 case SYMBOL_PLAINVAL
:
1898 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1899 case SYMBOL_LOCALIZED
:
1900 blv
= SYMBOL_BLV (sym
);
1902 case SYMBOL_FORWARDED
:
1903 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1904 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1905 error ("Symbol %s may not be buffer-local",
1906 SDATA (SYMBOL_NAME (variable
)));
1908 default: emacs_abort ();
1911 if (sym
->trapped_write
== SYMBOL_NOWRITE
)
1912 error ("Symbol %s may not be buffer-local",
1913 SDATA (SYMBOL_NAME (variable
)));
1915 if (blv
? blv
->local_if_set
1916 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1918 tem
= Fboundp (variable
);
1919 /* Make sure the symbol has a local value in this particular buffer,
1920 by setting it to the same value it already has. */
1921 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1926 blv
= make_blv (sym
, forwarded
, valcontents
);
1927 sym
->redirect
= SYMBOL_LOCALIZED
;
1928 SET_SYMBOL_BLV (sym
, blv
);
1931 /* Make sure this buffer has its own value of symbol. */
1932 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1933 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1936 if (let_shadows_buffer_binding_p (sym
))
1938 AUTO_STRING (format
,
1939 "Making %s buffer-local while locally let-bound!");
1940 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1943 /* Swap out any local binding for some other buffer, and make
1944 sure the current value is permanently recorded, if it's the
1946 find_symbol_value (variable
);
1948 bset_local_var_alist
1950 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1951 BVAR (current_buffer
, local_var_alist
)));
1953 /* Make sure symbol does not think it is set up for this buffer;
1954 force it to look once again for this buffer's value. */
1955 if (current_buffer
== XBUFFER (blv
->where
))
1956 set_blv_where (blv
, Qnil
);
1957 set_blv_found (blv
, 0);
1960 /* If the symbol forwards into a C variable, then load the binding
1961 for this buffer now. If C code modifies the variable before we
1962 load the binding in, then that new value will clobber the default
1963 binding the next time we unload it. */
1965 swap_in_symval_forwarding (sym
, blv
);
1970 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1971 1, 1, "vKill Local Variable: ",
1972 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1973 From now on the default value will apply in this buffer. Return VARIABLE. */)
1974 (register Lisp_Object variable
)
1976 register Lisp_Object tem
;
1977 struct Lisp_Buffer_Local_Value
*blv
;
1978 struct Lisp_Symbol
*sym
;
1980 CHECK_SYMBOL (variable
);
1981 sym
= XSYMBOL (variable
);
1984 switch (sym
->redirect
)
1986 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1987 case SYMBOL_PLAINVAL
: return variable
;
1988 case SYMBOL_FORWARDED
:
1990 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1991 if (BUFFER_OBJFWDP (valcontents
))
1993 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1994 int idx
= PER_BUFFER_IDX (offset
);
1998 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1999 set_per_buffer_value (current_buffer
, offset
,
2000 per_buffer_default (offset
));
2005 case SYMBOL_LOCALIZED
:
2006 blv
= SYMBOL_BLV (sym
);
2008 default: emacs_abort ();
2011 if (sym
->trapped_write
== SYMBOL_TRAPPED_WRITE
)
2012 notify_variable_watchers (variable
, Qnil
, Qmakunbound
, Fcurrent_buffer ());
2014 /* Get rid of this buffer's alist element, if any. */
2015 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
2016 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
2018 bset_local_var_alist
2020 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
2022 /* If the symbol is set up with the current buffer's binding
2023 loaded, recompute its value. We have to do it now, or else
2024 forwarded objects won't work right. */
2026 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
2027 if (EQ (buf
, blv
->where
))
2029 set_blv_where (blv
, Qnil
);
2031 find_symbol_value (variable
);
2038 /* Lisp functions for creating and removing buffer-local variables. */
2040 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
2042 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
2043 BUFFER defaults to the current buffer. */)
2044 (Lisp_Object variable
, Lisp_Object buffer
)
2046 struct buffer
*buf
= decode_buffer (buffer
);
2047 struct Lisp_Symbol
*sym
;
2049 CHECK_SYMBOL (variable
);
2050 sym
= XSYMBOL (variable
);
2053 switch (sym
->redirect
)
2055 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2056 case SYMBOL_PLAINVAL
: return Qnil
;
2057 case SYMBOL_LOCALIZED
:
2059 Lisp_Object tail
, elt
, tmp
;
2060 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2061 XSETBUFFER (tmp
, buf
);
2062 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2064 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
2065 return blv_found (blv
) ? Qt
: Qnil
;
2067 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
2070 if (EQ (variable
, XCAR (elt
)))
2075 case SYMBOL_FORWARDED
:
2077 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2078 if (BUFFER_OBJFWDP (valcontents
))
2080 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2081 int idx
= PER_BUFFER_IDX (offset
);
2082 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2087 default: emacs_abort ();
2091 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2093 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
2094 BUFFER defaults to the current buffer.
2096 More precisely, return non-nil if either VARIABLE already has a local
2097 value in BUFFER, or if VARIABLE is automatically buffer-local (see
2098 `make-variable-buffer-local'). */)
2099 (register Lisp_Object variable
, Lisp_Object buffer
)
2101 struct Lisp_Symbol
*sym
;
2103 CHECK_SYMBOL (variable
);
2104 sym
= XSYMBOL (variable
);
2107 switch (sym
->redirect
)
2109 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2110 case SYMBOL_PLAINVAL
: return Qnil
;
2111 case SYMBOL_LOCALIZED
:
2113 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2114 if (blv
->local_if_set
)
2116 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2117 return Flocal_variable_p (variable
, buffer
);
2119 case SYMBOL_FORWARDED
:
2120 /* All BUFFER_OBJFWD slots become local if they are set. */
2121 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2122 default: emacs_abort ();
2126 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2128 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2129 If the current binding is buffer-local, the value is the current buffer.
2130 If the current binding is global (the default), the value is nil. */)
2131 (register Lisp_Object variable
)
2133 struct Lisp_Symbol
*sym
;
2135 CHECK_SYMBOL (variable
);
2136 sym
= XSYMBOL (variable
);
2138 /* Make sure the current binding is actually swapped in. */
2139 find_symbol_value (variable
);
2142 switch (sym
->redirect
)
2144 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2145 case SYMBOL_PLAINVAL
: return Qnil
;
2146 case SYMBOL_FORWARDED
:
2148 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2149 if (KBOARD_OBJFWDP (valcontents
))
2150 return Fframe_terminal (selected_frame
);
2151 else if (!BUFFER_OBJFWDP (valcontents
))
2155 case SYMBOL_LOCALIZED
:
2156 /* For a local variable, record both the symbol and which
2157 buffer's or frame's value we are saving. */
2158 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2159 return Fcurrent_buffer ();
2160 else if (sym
->redirect
== SYMBOL_LOCALIZED
2161 && blv_found (SYMBOL_BLV (sym
)))
2162 return SYMBOL_BLV (sym
)->where
;
2165 default: emacs_abort ();
2169 /* This code is disabled now that we use the selected frame to return
2170 keyboard-local-values. */
2172 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2174 DEFUN ("terminal-local-value", Fterminal_local_value
,
2175 Sterminal_local_value
, 2, 2, 0,
2176 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2177 If SYMBOL is not a terminal-local variable, then return its normal
2178 value, like `symbol-value'.
2180 TERMINAL may be a terminal object, a frame, or nil (meaning the
2181 selected frame's terminal device). */)
2182 (Lisp_Object symbol
, Lisp_Object terminal
)
2185 struct terminal
*t
= get_terminal (terminal
, 1);
2186 push_kboard (t
->kboard
);
2187 result
= Fsymbol_value (symbol
);
2192 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2193 Sset_terminal_local_value
, 3, 3, 0,
2194 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2195 If VARIABLE is not a terminal-local variable, then set its normal
2196 binding, like `set'.
2198 TERMINAL may be a terminal object, a frame, or nil (meaning the
2199 selected frame's terminal device). */)
2200 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2203 struct terminal
*t
= get_terminal (terminal
, 1);
2204 push_kboard (d
->kboard
);
2205 result
= Fset (symbol
, value
);
2211 /* Find the function at the end of a chain of symbol function indirections. */
2213 /* If OBJECT is a symbol, find the end of its function chain and
2214 return the value found there. If OBJECT is not a symbol, just
2215 return it. If there is a cycle in the function chain, signal a
2216 cyclic-function-indirection error.
2218 This is like Findirect_function, except that it doesn't signal an
2219 error if the chain ends up unbound. */
2221 indirect_function (register Lisp_Object object
)
2223 Lisp_Object tortoise
, hare
;
2225 hare
= tortoise
= object
;
2229 if (!SYMBOLP (hare
) || NILP (hare
))
2231 hare
= XSYMBOL (hare
)->function
;
2232 if (!SYMBOLP (hare
) || NILP (hare
))
2234 hare
= XSYMBOL (hare
)->function
;
2236 tortoise
= XSYMBOL (tortoise
)->function
;
2238 if (EQ (hare
, tortoise
))
2239 xsignal1 (Qcyclic_function_indirection
, object
);
2245 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2246 doc
: /* Return the function at the end of OBJECT's function chain.
2247 If OBJECT is not a symbol, just return it. Otherwise, follow all
2248 function indirections to find the final function binding and return it.
2249 Signal a cyclic-function-indirection error if there is a loop in the
2250 function chain of symbols. */)
2251 (register Lisp_Object object
, Lisp_Object noerror
)
2255 /* Optimize for no indirection. */
2257 if (SYMBOLP (result
) && !NILP (result
)
2258 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2259 result
= indirect_function (result
);
2266 /* Extract and set vector and string elements. */
2268 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2269 doc
: /* Return the element of ARG at index IDX.
2270 ARG may be a vector, a string, a char-table, a bool-vector, a record,
2271 or a byte-code object. IDX starts at 0. */)
2272 (register Lisp_Object array
, Lisp_Object idx
)
2274 register EMACS_INT idxval
;
2277 idxval
= XINT (idx
);
2278 if (STRINGP (array
))
2281 ptrdiff_t idxval_byte
;
2283 if (idxval
< 0 || idxval
>= SCHARS (array
))
2284 args_out_of_range (array
, idx
);
2285 if (! STRING_MULTIBYTE (array
))
2286 return make_number ((unsigned char) SREF (array
, idxval
));
2287 idxval_byte
= string_char_to_byte (array
, idxval
);
2289 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2290 return make_number (c
);
2292 else if (BOOL_VECTOR_P (array
))
2294 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2295 args_out_of_range (array
, idx
);
2296 return bool_vector_ref (array
, idxval
);
2298 else if (CHAR_TABLE_P (array
))
2300 CHECK_CHARACTER (idx
);
2301 return CHAR_TABLE_REF (array
, idxval
);
2306 if (VECTORP (array
))
2307 size
= ASIZE (array
);
2308 else if (COMPILEDP (array
) || RECORDP (array
))
2309 size
= PVSIZE (array
);
2311 wrong_type_argument (Qarrayp
, array
);
2313 if (idxval
< 0 || idxval
>= size
)
2314 args_out_of_range (array
, idx
);
2315 return AREF (array
, idxval
);
2319 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2320 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2321 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2322 bool-vector. IDX starts at 0. */)
2323 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2325 register EMACS_INT idxval
;
2328 idxval
= XINT (idx
);
2329 if (! RECORDP (array
))
2330 CHECK_ARRAY (array
, Qarrayp
);
2332 if (VECTORP (array
))
2334 CHECK_IMPURE (array
, XVECTOR (array
));
2335 if (idxval
< 0 || idxval
>= ASIZE (array
))
2336 args_out_of_range (array
, idx
);
2337 ASET (array
, idxval
, newelt
);
2339 else if (BOOL_VECTOR_P (array
))
2341 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2342 args_out_of_range (array
, idx
);
2343 bool_vector_set (array
, idxval
, !NILP (newelt
));
2345 else if (CHAR_TABLE_P (array
))
2347 CHECK_CHARACTER (idx
);
2348 CHAR_TABLE_SET (array
, idxval
, newelt
);
2350 else if (RECORDP (array
))
2352 if (idxval
< 0 || idxval
>= PVSIZE (array
))
2353 args_out_of_range (array
, idx
);
2354 ASET (array
, idxval
, newelt
);
2360 CHECK_IMPURE (array
, XSTRING (array
));
2361 if (idxval
< 0 || idxval
>= SCHARS (array
))
2362 args_out_of_range (array
, idx
);
2363 CHECK_CHARACTER (newelt
);
2364 c
= XFASTINT (newelt
);
2366 if (STRING_MULTIBYTE (array
))
2368 ptrdiff_t idxval_byte
, nbytes
;
2369 int prev_bytes
, new_bytes
;
2370 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2372 nbytes
= SBYTES (array
);
2373 idxval_byte
= string_char_to_byte (array
, idxval
);
2374 p1
= SDATA (array
) + idxval_byte
;
2375 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2376 new_bytes
= CHAR_STRING (c
, p0
);
2377 if (prev_bytes
!= new_bytes
)
2379 /* We must relocate the string data. */
2380 ptrdiff_t nchars
= SCHARS (array
);
2382 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2384 memcpy (str
, SDATA (array
), nbytes
);
2385 allocate_string_data (XSTRING (array
), nchars
,
2386 nbytes
+ new_bytes
- prev_bytes
);
2387 memcpy (SDATA (array
), str
, idxval_byte
);
2388 p1
= SDATA (array
) + idxval_byte
;
2389 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2390 nbytes
- (idxval_byte
+ prev_bytes
));
2392 clear_string_char_byte_cache ();
2399 if (! SINGLE_BYTE_CHAR_P (c
))
2403 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2404 if (SREF (array
, i
) >= 0x80)
2405 args_out_of_range (array
, newelt
);
2406 /* ARRAY is an ASCII string. Convert it to a multibyte
2407 string, and try `aset' again. */
2408 STRING_SET_MULTIBYTE (array
);
2409 return Faset (array
, idx
, newelt
);
2411 SSET (array
, idxval
, c
);
2418 /* Arithmetic functions */
2421 arithcompare (Lisp_Object num1
, Lisp_Object num2
,
2422 enum Arith_Comparison comparison
)
2429 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2430 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2432 /* If either arg is floating point, set F1 and F2 to the 'double'
2433 approximations of the two arguments, and set FNEQ if floating-point
2434 comparison reports that F1 is not equal to F2, possibly because F1
2435 or F2 is a NaN. Regardless, set I1 and I2 to integers that break
2436 ties if the floating-point comparison is either not done or reports
2441 f1
= XFLOAT_DATA (num1
);
2445 f2
= XFLOAT_DATA (num2
);
2449 /* Compare a float NUM1 to an integer NUM2 by converting the
2450 integer I2 (i.e., NUM2) to the double F2 (a conversion that
2451 can round on some platforms, if I2 is large enough), and then
2452 converting F2 back to the integer I1 (a conversion that is
2453 always exact), so that I1 exactly equals ((double) NUM2). If
2454 floating-point comparison reports a tie, NUM1 = F1 = F2 = I1
2455 (exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1
2456 to I2 will break the tie correctly. */
2457 i1
= f2
= i2
= XINT (num2
);
2466 /* Compare an integer NUM1 to a float NUM2. This is the
2467 converse of comparing float to integer (see above). */
2469 f2
= XFLOAT_DATA (num2
);
2482 test
= !fneq
&& i1
== i2
;
2485 case ARITH_NOTEQUAL
:
2486 test
= fneq
|| i1
!= i2
;
2490 test
= fneq
? f1
< f2
: i1
< i2
;
2493 case ARITH_LESS_OR_EQUAL
:
2494 test
= fneq
? f1
<= f2
: i1
<= i2
;
2498 test
= fneq
? f1
> f2
: i1
> i2
;
2501 case ARITH_GRTR_OR_EQUAL
:
2502 test
= fneq
? f1
>= f2
: i1
>= i2
;
2509 return test
? Qt
: Qnil
;
2513 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2514 enum Arith_Comparison comparison
)
2516 for (ptrdiff_t i
= 1; i
< nargs
; i
++)
2517 if (NILP (arithcompare (args
[i
- 1], args
[i
], comparison
)))
2522 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2523 doc
: /* Return t if args, all numbers or markers, are equal.
2524 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2525 (ptrdiff_t nargs
, Lisp_Object
*args
)
2527 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2530 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2531 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2532 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2533 (ptrdiff_t nargs
, Lisp_Object
*args
)
2535 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2538 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2539 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2540 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2541 (ptrdiff_t nargs
, Lisp_Object
*args
)
2543 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2546 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2547 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2548 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2549 (ptrdiff_t nargs
, Lisp_Object
*args
)
2551 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2554 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2555 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2556 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2557 (ptrdiff_t nargs
, Lisp_Object
*args
)
2559 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2562 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2563 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2564 (register Lisp_Object num1
, Lisp_Object num2
)
2566 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2569 /* Convert the integer I to a cons-of-integers, where I is not in
2572 #define INTBIG_TO_LISP(i, extremum) \
2573 (eassert (FIXNUM_OVERFLOW_P (i)), \
2574 (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \
2575 && FIXNUM_OVERFLOW_P ((i) >> 16)) \
2576 ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \
2577 : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \
2578 && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \
2579 ? Fcons (make_number ((i) >> 16 >> 24), \
2580 Fcons (make_number ((i) >> 16 & 0xffffff), \
2581 make_number ((i) & 0xffff))) \
2585 intbig_to_lisp (intmax_t i
)
2587 return INTBIG_TO_LISP (i
, INTMAX_MIN
);
2591 uintbig_to_lisp (uintmax_t i
)
2593 return INTBIG_TO_LISP (i
, UINTMAX_MAX
);
2596 /* Convert the cons-of-integers, integer, or float value C to an
2597 unsigned value with maximum value MAX, where MAX is one less than a
2598 power of 2. Signal an error if C does not have a valid format or
2601 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2607 valid
= XINT (c
) >= 0;
2610 else if (FLOATP (c
))
2612 double d
= XFLOAT_DATA (c
);
2613 if (d
>= 0 && d
< 1.0 + max
)
2619 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2621 uintmax_t top
= XFASTINT (XCAR (c
));
2622 Lisp_Object rest
= XCDR (c
);
2623 if (top
<= UINTMAX_MAX
>> 24 >> 16
2625 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2626 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2628 uintmax_t mid
= XFASTINT (XCAR (rest
));
2629 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2632 else if (top
<= UINTMAX_MAX
>> 16)
2636 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2638 val
= top
<< 16 | XFASTINT (rest
);
2644 if (! (valid
&& val
<= max
))
2645 error ("Not an in-range integer, integral float, or cons of integers");
2649 /* Convert the cons-of-integers, integer, or float value C to a signed
2650 value with extrema MIN and MAX. MAX should be one less than a
2651 power of 2, and MIN should be zero or the negative of a power of 2.
2652 Signal an error if C does not have a valid format or is out of
2655 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2664 else if (FLOATP (c
))
2666 double d
= XFLOAT_DATA (c
);
2667 if (d
>= min
&& d
< 1.0 + max
)
2673 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2675 intmax_t top
= XINT (XCAR (c
));
2676 Lisp_Object rest
= XCDR (c
);
2677 if (top
>= INTMAX_MIN
>> 24 >> 16 && top
<= INTMAX_MAX
>> 24 >> 16
2679 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2680 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2682 intmax_t mid
= XFASTINT (XCAR (rest
));
2683 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2686 else if (top
>= INTMAX_MIN
>> 16 && top
<= INTMAX_MAX
>> 16)
2690 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2692 val
= top
<< 16 | XFASTINT (rest
);
2698 if (! (valid
&& min
<= val
&& val
<= max
))
2699 error ("Not an in-range integer, integral float, or cons of integers");
2703 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2704 doc
: /* Return the decimal representation of NUMBER as a string.
2705 Uses a minus sign if negative.
2706 NUMBER may be an integer or a floating point number. */)
2707 (Lisp_Object number
)
2709 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2712 CHECK_NUMBER_OR_FLOAT (number
);
2714 if (FLOATP (number
))
2715 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2717 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2719 return make_unibyte_string (buffer
, len
);
2722 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2723 doc
: /* Parse STRING as a decimal number and return the number.
2724 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2725 STRING cannot be parsed as an integer or floating point number.
2727 If BASE, interpret STRING as a number in that base. If BASE isn't
2728 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2729 If the base used is not 10, STRING is always parsed as an integer. */)
2730 (register Lisp_Object string
, Lisp_Object base
)
2736 CHECK_STRING (string
);
2742 CHECK_NUMBER (base
);
2743 if (! (XINT (base
) >= 2 && XINT (base
) <= 16))
2744 xsignal1 (Qargs_out_of_range
, base
);
2748 p
= SSDATA (string
);
2749 while (*p
== ' ' || *p
== '\t')
2752 val
= string_to_number (p
, b
, 1);
2753 return NILP (val
) ? make_number (0) : val
;
2767 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2768 ptrdiff_t, Lisp_Object
*);
2770 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2773 ptrdiff_t argnum
, ok_args
;
2774 EMACS_INT accum
= 0;
2775 EMACS_INT next
, ok_accum
;
2797 for (argnum
= 0; argnum
< nargs
; argnum
++)
2805 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2807 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2810 return float_arith_driver (ok_accum
, ok_args
, code
,
2813 next
= XINT (args
[argnum
]);
2817 overflow
|= INT_ADD_WRAPV (accum
, next
, &accum
);
2821 accum
= nargs
== 1 ? - next
: next
;
2823 overflow
|= INT_SUBTRACT_WRAPV (accum
, next
, &accum
);
2826 overflow
|= INT_MULTIPLY_WRAPV (accum
, next
, &accum
);
2829 if (! (argnum
|| nargs
== 1))
2834 xsignal0 (Qarith_error
);
2835 if (INT_DIVIDE_OVERFLOW (accum
, next
))
2853 XSETINT (val
, accum
);
2858 # define isnan(x) ((x) != (x))
2862 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2863 ptrdiff_t nargs
, Lisp_Object
*args
)
2865 register Lisp_Object val
;
2868 for (; argnum
< nargs
; argnum
++)
2870 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2871 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2875 next
= XFLOAT_DATA (val
);
2879 args
[argnum
] = val
; /* runs into a compiler bug. */
2880 next
= XINT (args
[argnum
]);
2888 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2894 if (! (argnum
|| nargs
== 1))
2898 if (! IEEE_FLOATING_POINT
&& next
== 0)
2899 xsignal0 (Qarith_error
);
2906 wrong_type_argument (Qinteger_or_marker_p
, val
);
2910 return make_float (accum
);
2914 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2915 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2916 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2917 (ptrdiff_t nargs
, Lisp_Object
*args
)
2919 return arith_driver (Aadd
, nargs
, args
);
2922 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2923 doc
: /* Negate number or subtract numbers or markers and return the result.
2924 With one arg, negates it. With more than one arg,
2925 subtracts all but the first from the first.
2926 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2927 (ptrdiff_t nargs
, Lisp_Object
*args
)
2929 return arith_driver (Asub
, nargs
, args
);
2932 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2933 doc
: /* Return product of any number of arguments, which are numbers or markers.
2934 usage: (* &rest NUMBERS-OR-MARKERS) */)
2935 (ptrdiff_t nargs
, Lisp_Object
*args
)
2937 return arith_driver (Amult
, nargs
, args
);
2940 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2941 doc
: /* Divide number by divisors and return the result.
2942 With two or more arguments, return first argument divided by the rest.
2943 With one argument, return 1 divided by the argument.
2944 The arguments must be numbers or markers.
2945 usage: (/ NUMBER &rest DIVISORS) */)
2946 (ptrdiff_t nargs
, Lisp_Object
*args
)
2949 for (argnum
= 2; argnum
< nargs
; argnum
++)
2950 if (FLOATP (args
[argnum
]))
2951 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2952 return arith_driver (Adiv
, nargs
, args
);
2955 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2956 doc
: /* Return remainder of X divided by Y.
2957 Both must be integers or markers. */)
2958 (register Lisp_Object x
, Lisp_Object y
)
2962 CHECK_NUMBER_COERCE_MARKER (x
);
2963 CHECK_NUMBER_COERCE_MARKER (y
);
2966 xsignal0 (Qarith_error
);
2968 XSETINT (val
, XINT (x
) % XINT (y
));
2972 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2973 doc
: /* Return X modulo Y.
2974 The result falls between zero (inclusive) and Y (exclusive).
2975 Both X and Y must be numbers or markers. */)
2976 (register Lisp_Object x
, Lisp_Object y
)
2981 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2982 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2984 if (FLOATP (x
) || FLOATP (y
))
2985 return fmod_float (x
, y
);
2991 xsignal0 (Qarith_error
);
2995 /* If the "remainder" comes out with the wrong sign, fix it. */
2996 if (i2
< 0 ? i1
> 0 : i1
< 0)
3004 minmax_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
3005 enum Arith_Comparison comparison
)
3007 eassume (0 < nargs
);
3009 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
3011 Lisp_Object val
= args
[argnum
];
3012 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
3013 if (argnum
== 0 || !NILP (arithcompare (val
, accum
, comparison
)))
3015 else if (FLOATP (accum
) && isnan (XFLOAT_DATA (accum
)))
3021 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
3022 doc
: /* Return largest of all the arguments (which must be numbers or markers).
3023 The value is always a number; markers are converted to numbers.
3024 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3025 (ptrdiff_t nargs
, Lisp_Object
*args
)
3027 return minmax_driver (nargs
, args
, ARITH_GRTR
);
3030 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
3031 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
3032 The value is always a number; markers are converted to numbers.
3033 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3034 (ptrdiff_t nargs
, Lisp_Object
*args
)
3036 return minmax_driver (nargs
, args
, ARITH_LESS
);
3039 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
3040 doc
: /* Return bitwise-and of all the arguments.
3041 Arguments may be integers, or markers converted to integers.
3042 usage: (logand &rest INTS-OR-MARKERS) */)
3043 (ptrdiff_t nargs
, Lisp_Object
*args
)
3045 return arith_driver (Alogand
, nargs
, args
);
3048 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
3049 doc
: /* Return bitwise-or of all the arguments.
3050 Arguments may be integers, or markers converted to integers.
3051 usage: (logior &rest INTS-OR-MARKERS) */)
3052 (ptrdiff_t nargs
, Lisp_Object
*args
)
3054 return arith_driver (Alogior
, nargs
, args
);
3057 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
3058 doc
: /* Return bitwise-exclusive-or of all the arguments.
3059 Arguments may be integers, or markers converted to integers.
3060 usage: (logxor &rest INTS-OR-MARKERS) */)
3061 (ptrdiff_t nargs
, Lisp_Object
*args
)
3063 return arith_driver (Alogxor
, nargs
, args
);
3067 ash_lsh_impl (register Lisp_Object value
, Lisp_Object count
, bool lsh
)
3069 register Lisp_Object val
;
3071 CHECK_NUMBER (value
);
3072 CHECK_NUMBER (count
);
3074 if (XINT (count
) >= EMACS_INT_WIDTH
)
3076 else if (XINT (count
) > 0)
3077 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
3078 else if (XINT (count
) <= -EMACS_INT_WIDTH
)
3079 XSETINT (val
, lsh
? 0 : XINT (value
) < 0 ? -1 : 0);
3081 XSETINT (val
, lsh
? XUINT (value
) >> -XINT (count
) : \
3082 XINT (value
) >> -XINT (count
));
3086 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
3087 doc
: /* Return VALUE with its bits shifted left by COUNT.
3088 If COUNT is negative, shifting is actually to the right.
3089 In this case, the sign bit is duplicated. */)
3090 (register Lisp_Object value
, Lisp_Object count
)
3092 return ash_lsh_impl (value
, count
, false);
3095 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
3096 doc
: /* Return VALUE with its bits shifted left by COUNT.
3097 If COUNT is negative, shifting is actually to the right.
3098 In this case, zeros are shifted in on the left. */)
3099 (register Lisp_Object value
, Lisp_Object count
)
3101 return ash_lsh_impl (value
, count
, true);
3104 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3105 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3106 Markers are converted to integers. */)
3107 (register Lisp_Object number
)
3109 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3111 if (FLOATP (number
))
3112 return (make_float (1.0 + XFLOAT_DATA (number
)));
3114 XSETINT (number
, XINT (number
) + 1);
3118 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3119 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3120 Markers are converted to integers. */)
3121 (register Lisp_Object number
)
3123 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3125 if (FLOATP (number
))
3126 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3128 XSETINT (number
, XINT (number
) - 1);
3132 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3133 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3134 (register Lisp_Object number
)
3136 CHECK_NUMBER (number
);
3137 XSETINT (number
, ~XINT (number
));
3141 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3142 doc
: /* Return the byteorder for the machine.
3143 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3144 lowercase l) for small endian machines. */
3148 unsigned i
= 0x04030201;
3149 int order
= *(char *)&i
== 1 ? 108 : 66;
3151 return make_number (order
);
3154 /* Because we round up the bool vector allocate size to word_size
3155 units, we can safely read past the "end" of the vector in the
3156 operations below. These extra bits are always zero. */
3159 bool_vector_spare_mask (EMACS_INT nr_bits
)
3161 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
3164 /* Info about unsigned long long, falling back on unsigned long
3165 if unsigned long long is not available. */
3167 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH
3168 enum { ULL_WIDTH
= ULLONG_WIDTH
};
3169 # define ULL_MAX ULLONG_MAX
3171 enum { ULL_WIDTH
= ULONG_WIDTH
};
3172 # define ULL_MAX ULONG_MAX
3173 # define count_one_bits_ll count_one_bits_l
3174 # define count_trailing_zeros_ll count_trailing_zeros_l
3177 /* Shift VAL right by the width of an unsigned long long.
3178 ULL_WIDTH must be less than BITS_PER_BITS_WORD. */
3181 shift_right_ull (bits_word w
)
3183 /* Pacify bogus GCC warning about shift count exceeding type width. */
3184 int shift
= ULL_WIDTH
- BITS_PER_BITS_WORD
< 0 ? ULL_WIDTH
: 0;
3188 /* Return the number of 1 bits in W. */
3191 count_one_bits_word (bits_word w
)
3193 if (BITS_WORD_MAX
<= UINT_MAX
)
3194 return count_one_bits (w
);
3195 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3196 return count_one_bits_l (w
);
3199 int i
= 0, count
= 0;
3200 while (count
+= count_one_bits_ll (w
),
3201 (i
+= ULL_WIDTH
) < BITS_PER_BITS_WORD
)
3202 w
= shift_right_ull (w
);
3207 enum bool_vector_op
{ bool_vector_exclusive_or
,
3209 bool_vector_intersection
,
3210 bool_vector_set_difference
,
3211 bool_vector_subsetp
};
3214 bool_vector_binop_driver (Lisp_Object a
,
3217 enum bool_vector_op op
)
3220 bits_word
*adata
, *bdata
, *destdata
;
3224 CHECK_BOOL_VECTOR (a
);
3225 CHECK_BOOL_VECTOR (b
);
3227 nr_bits
= bool_vector_size (a
);
3228 if (bool_vector_size (b
) != nr_bits
)
3229 wrong_length_argument (a
, b
, dest
);
3231 nr_words
= bool_vector_words (nr_bits
);
3232 adata
= bool_vector_data (a
);
3233 bdata
= bool_vector_data (b
);
3237 dest
= make_uninit_bool_vector (nr_bits
);
3238 destdata
= bool_vector_data (dest
);
3242 CHECK_BOOL_VECTOR (dest
);
3243 destdata
= bool_vector_data (dest
);
3244 if (bool_vector_size (dest
) != nr_bits
)
3245 wrong_length_argument (a
, b
, dest
);
3249 case bool_vector_exclusive_or
:
3250 for (; i
< nr_words
; i
++)
3251 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3255 case bool_vector_subsetp
:
3256 for (; i
< nr_words
; i
++)
3257 if (adata
[i
] &~ bdata
[i
])
3261 case bool_vector_union
:
3262 for (; i
< nr_words
; i
++)
3263 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3267 case bool_vector_intersection
:
3268 for (; i
< nr_words
; i
++)
3269 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3273 case bool_vector_set_difference
:
3274 for (; i
< nr_words
; i
++)
3275 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3286 case bool_vector_exclusive_or
:
3287 for (; i
< nr_words
; i
++)
3288 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3291 case bool_vector_union
:
3292 for (; i
< nr_words
; i
++)
3293 destdata
[i
] = adata
[i
] | bdata
[i
];
3296 case bool_vector_intersection
:
3297 for (; i
< nr_words
; i
++)
3298 destdata
[i
] = adata
[i
] & bdata
[i
];
3301 case bool_vector_set_difference
:
3302 for (; i
< nr_words
; i
++)
3303 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3313 /* PRECONDITION must be true. Return VALUE. This odd construction
3314 works around a bogus GCC diagnostic "shift count >= width of type". */
3317 pre_value (bool precondition
, int value
)
3319 eassume (precondition
);
3320 return precondition
? value
: 0;
3323 /* Compute the number of trailing zero bits in val. If val is zero,
3324 return the number of bits in val. */
3326 count_trailing_zero_bits (bits_word val
)
3328 if (BITS_WORD_MAX
== UINT_MAX
)
3329 return count_trailing_zeros (val
);
3330 if (BITS_WORD_MAX
== ULONG_MAX
)
3331 return count_trailing_zeros_l (val
);
3332 if (BITS_WORD_MAX
== ULL_MAX
)
3333 return count_trailing_zeros_ll (val
);
3335 /* The rest of this code is for the unlikely platform where bits_word differs
3336 in width from unsigned int, unsigned long, and unsigned long long. */
3337 val
|= ~ BITS_WORD_MAX
;
3338 if (BITS_WORD_MAX
<= UINT_MAX
)
3339 return count_trailing_zeros (val
);
3340 if (BITS_WORD_MAX
<= ULONG_MAX
)
3341 return count_trailing_zeros_l (val
);
3346 count
< BITS_PER_BITS_WORD
- ULL_WIDTH
;
3350 return count
+ count_trailing_zeros_ll (val
);
3351 val
= shift_right_ull (val
);
3354 if (BITS_PER_BITS_WORD
% ULL_WIDTH
!= 0
3355 && BITS_WORD_MAX
== (bits_word
) -1)
3356 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3357 BITS_PER_BITS_WORD
% ULL_WIDTH
);
3358 return count
+ count_trailing_zeros_ll (val
);
3363 bits_word_to_host_endian (bits_word val
)
3365 #ifndef WORDS_BIGENDIAN
3368 if (BITS_WORD_MAX
>> 31 == 1)
3369 return bswap_32 (val
);
3370 # if HAVE_UNSIGNED_LONG_LONG
3371 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3372 return bswap_64 (val
);
3377 for (i
= 0; i
< sizeof val
; i
++)
3379 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3380 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3381 val
= val
>> 1 >> (CHAR_BIT
- 1);
3388 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3389 Sbool_vector_exclusive_or
, 2, 3, 0,
3390 doc
: /* Return A ^ B, bitwise exclusive or.
3391 If optional third argument C is given, store result into C.
3392 A, B, and C must be bool vectors of the same length.
3393 Return the destination vector if it changed or nil otherwise. */)
3394 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3396 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3399 DEFUN ("bool-vector-union", Fbool_vector_union
,
3400 Sbool_vector_union
, 2, 3, 0,
3401 doc
: /* Return A | B, bitwise or.
3402 If optional third argument C is given, store result into C.
3403 A, B, and C must be bool vectors of the same length.
3404 Return the destination vector if it changed or nil otherwise. */)
3405 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3407 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3410 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3411 Sbool_vector_intersection
, 2, 3, 0,
3412 doc
: /* Return A & B, bitwise and.
3413 If optional third argument C is given, store result into C.
3414 A, B, and C must be bool vectors of the same length.
3415 Return the destination vector if it changed or nil otherwise. */)
3416 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3418 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3421 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3422 Sbool_vector_set_difference
, 2, 3, 0,
3423 doc
: /* Return A &~ B, set difference.
3424 If optional third argument C is given, store result into C.
3425 A, B, and C must be bool vectors of the same length.
3426 Return the destination vector if it changed or nil otherwise. */)
3427 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3429 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3432 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3433 Sbool_vector_subsetp
, 2, 2, 0,
3434 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3435 A and B must be bool vectors of the same length. */)
3436 (Lisp_Object a
, Lisp_Object b
)
3438 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3441 DEFUN ("bool-vector-not", Fbool_vector_not
,
3442 Sbool_vector_not
, 1, 2, 0,
3443 doc
: /* Compute ~A, set complement.
3444 If optional second argument B is given, store result into B.
3445 A and B must be bool vectors of the same length.
3446 Return the destination vector. */)
3447 (Lisp_Object a
, Lisp_Object b
)
3450 bits_word
*bdata
, *adata
;
3453 CHECK_BOOL_VECTOR (a
);
3454 nr_bits
= bool_vector_size (a
);
3457 b
= make_uninit_bool_vector (nr_bits
);
3460 CHECK_BOOL_VECTOR (b
);
3461 if (bool_vector_size (b
) != nr_bits
)
3462 wrong_length_argument (a
, b
, Qnil
);
3465 bdata
= bool_vector_data (b
);
3466 adata
= bool_vector_data (a
);
3468 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3469 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3471 if (nr_bits
% BITS_PER_BITS_WORD
)
3473 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3475 mword
&= bool_vector_spare_mask (nr_bits
);
3476 bdata
[i
] = bits_word_to_host_endian (mword
);
3482 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3483 Sbool_vector_count_population
, 1, 1, 0,
3484 doc
: /* Count how many elements in A are t.
3485 A is a bool vector. To count A's nil elements, subtract the return
3486 value from A's length. */)
3492 ptrdiff_t i
, nwords
;
3494 CHECK_BOOL_VECTOR (a
);
3496 nr_bits
= bool_vector_size (a
);
3497 nwords
= bool_vector_words (nr_bits
);
3499 adata
= bool_vector_data (a
);
3501 for (i
= 0; i
< nwords
; i
++)
3502 count
+= count_one_bits_word (adata
[i
]);
3504 return make_number (count
);
3507 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3508 Sbool_vector_count_consecutive
, 3, 3, 0,
3509 doc
: /* Count how many consecutive elements in A equal B starting at I.
3510 A is a bool vector, B is t or nil, and I is an index into A. */)
3511 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3518 bits_word mword
; /* Machine word. */
3519 ptrdiff_t pos
, pos0
;
3522 CHECK_BOOL_VECTOR (a
);
3525 nr_bits
= bool_vector_size (a
);
3526 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3527 args_out_of_range (a
, i
);
3529 adata
= bool_vector_data (a
);
3530 nr_words
= bool_vector_words (nr_bits
);
3531 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3532 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3535 /* By XORing with twiddle, we transform the problem of "count
3536 consecutive equal values" into "count the zero bits". The latter
3537 operation usually has hardware support. */
3538 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3540 /* Scan the remainder of the mword at the current offset. */
3541 if (pos
< nr_words
&& offset
!= 0)
3543 mword
= bits_word_to_host_endian (adata
[pos
]);
3547 /* Do not count the pad bits. */
3548 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3550 count
= count_trailing_zero_bits (mword
);
3552 if (count
+ offset
< BITS_PER_BITS_WORD
)
3553 return make_number (count
);
3556 /* Scan whole words until we either reach the end of the vector or
3557 find an mword that doesn't completely match. twiddle is
3558 endian-independent. */
3560 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3562 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3566 /* If we stopped because of a mismatch, see how many bits match
3567 in the current mword. */
3568 mword
= bits_word_to_host_endian (adata
[pos
]);
3570 count
+= count_trailing_zero_bits (mword
);
3572 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3574 /* If we hit the end, we might have overshot our count. Reduce
3575 the total by the number of spare bits at the end of the
3577 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3580 return make_number (count
);
3587 Lisp_Object error_tail
, arith_tail
;
3589 DEFSYM (Qquote
, "quote");
3590 DEFSYM (Qlambda
, "lambda");
3591 DEFSYM (Qerror_conditions
, "error-conditions");
3592 DEFSYM (Qerror_message
, "error-message");
3593 DEFSYM (Qtop_level
, "top-level");
3595 DEFSYM (Qerror
, "error");
3596 DEFSYM (Quser_error
, "user-error");
3597 DEFSYM (Qquit
, "quit");
3598 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3599 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3600 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3601 DEFSYM (Qvoid_function
, "void-function");
3602 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3603 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3604 DEFSYM (Qvoid_variable
, "void-variable");
3605 DEFSYM (Qsetting_constant
, "setting-constant");
3606 DEFSYM (Qtrapping_constant
, "trapping-constant");
3607 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3609 DEFSYM (Qinvalid_function
, "invalid-function");
3610 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3611 DEFSYM (Qno_catch
, "no-catch");
3612 DEFSYM (Qend_of_file
, "end-of-file");
3613 DEFSYM (Qarith_error
, "arith-error");
3614 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3615 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3616 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3617 DEFSYM (Qtext_read_only
, "text-read-only");
3618 DEFSYM (Qmark_inactive
, "mark-inactive");
3620 DEFSYM (Qlistp
, "listp");
3621 DEFSYM (Qconsp
, "consp");
3622 DEFSYM (Qsymbolp
, "symbolp");
3623 DEFSYM (Qintegerp
, "integerp");
3624 DEFSYM (Qnatnump
, "natnump");
3625 DEFSYM (Qwholenump
, "wholenump");
3626 DEFSYM (Qstringp
, "stringp");
3627 DEFSYM (Qarrayp
, "arrayp");
3628 DEFSYM (Qsequencep
, "sequencep");
3629 DEFSYM (Qbufferp
, "bufferp");
3630 DEFSYM (Qvectorp
, "vectorp");
3631 DEFSYM (Qrecordp
, "recordp");
3632 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3633 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3634 DEFSYM (Qmarkerp
, "markerp");
3636 DEFSYM (Quser_ptrp
, "user-ptrp");
3638 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3639 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3640 DEFSYM (Qfboundp
, "fboundp");
3642 DEFSYM (Qfloatp
, "floatp");
3643 DEFSYM (Qnumberp
, "numberp");
3644 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3646 DEFSYM (Qchar_table_p
, "char-table-p");
3647 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3649 DEFSYM (Qsubrp
, "subrp");
3650 DEFSYM (Qunevalled
, "unevalled");
3651 DEFSYM (Qmany
, "many");
3653 DEFSYM (Qcdr
, "cdr");
3655 error_tail
= pure_cons (Qerror
, Qnil
);
3657 /* ERROR is used as a signaler for random errors for which nothing else is
3660 Fput (Qerror
, Qerror_conditions
,
3662 Fput (Qerror
, Qerror_message
,
3663 build_pure_c_string ("error"));
3665 #define PUT_ERROR(sym, tail, msg) \
3666 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3667 Fput (sym, Qerror_message, build_pure_c_string (msg))
3669 PUT_ERROR (Qquit
, Qnil
, "Quit");
3671 PUT_ERROR (Quser_error
, error_tail
, "");
3672 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3673 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3674 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3675 PUT_ERROR (Qvoid_function
, error_tail
,
3676 "Symbol's function definition is void");
3677 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3678 "Symbol's chain of function indirections contains a loop");
3679 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3680 "Symbol's chain of variable indirections contains a loop");
3681 DEFSYM (Qcircular_list
, "circular-list");
3682 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3683 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3684 PUT_ERROR (Qsetting_constant
, error_tail
,
3685 "Attempt to set a constant symbol");
3686 PUT_ERROR (Qtrapping_constant
, error_tail
,
3687 "Attempt to trap writes to a constant symbol");
3688 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3689 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3690 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3691 "Wrong number of arguments");
3692 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3693 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3695 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3696 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3697 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3699 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3700 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3701 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3702 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3703 "Text is read-only");
3705 DEFSYM (Qrange_error
, "range-error");
3706 DEFSYM (Qdomain_error
, "domain-error");
3707 DEFSYM (Qsingularity_error
, "singularity-error");
3708 DEFSYM (Qoverflow_error
, "overflow-error");
3709 DEFSYM (Qunderflow_error
, "underflow-error");
3711 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3713 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3715 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3716 "Arithmetic singularity error");
3718 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3719 "Arithmetic overflow error");
3720 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3721 "Arithmetic underflow error");
3723 /* Types that type-of returns. */
3724 DEFSYM (Qinteger
, "integer");
3725 DEFSYM (Qsymbol
, "symbol");
3726 DEFSYM (Qstring
, "string");
3727 DEFSYM (Qcons
, "cons");
3728 DEFSYM (Qmarker
, "marker");
3729 DEFSYM (Qoverlay
, "overlay");
3730 DEFSYM (Qfinalizer
, "finalizer");
3732 DEFSYM (Quser_ptr
, "user-ptr");
3734 DEFSYM (Qfloat
, "float");
3735 DEFSYM (Qwindow_configuration
, "window-configuration");
3736 DEFSYM (Qprocess
, "process");
3737 DEFSYM (Qwindow
, "window");
3738 DEFSYM (Qsubr
, "subr");
3739 DEFSYM (Qcompiled_function
, "compiled-function");
3740 DEFSYM (Qbuffer
, "buffer");
3741 DEFSYM (Qframe
, "frame");
3742 DEFSYM (Qvector
, "vector");
3743 DEFSYM (Qrecord
, "record");
3744 DEFSYM (Qchar_table
, "char-table");
3745 DEFSYM (Qbool_vector
, "bool-vector");
3746 DEFSYM (Qhash_table
, "hash-table");
3747 DEFSYM (Qthread
, "thread");
3748 DEFSYM (Qmutex
, "mutex");
3749 DEFSYM (Qcondition_variable
, "condition-variable");
3750 DEFSYM (Qfont_spec
, "font-spec");
3751 DEFSYM (Qfont_entity
, "font-entity");
3752 DEFSYM (Qfont_object
, "font-object");
3753 DEFSYM (Qterminal
, "terminal");
3755 DEFSYM (Qdefun
, "defun");
3757 DEFSYM (Qinteractive_form
, "interactive-form");
3758 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3760 defsubr (&Sindirect_variable
);
3761 defsubr (&Sinteractive_form
);
3764 defsubr (&Stype_of
);
3769 defsubr (&Sintegerp
);
3770 defsubr (&Sinteger_or_marker_p
);
3771 defsubr (&Snumberp
);
3772 defsubr (&Snumber_or_marker_p
);
3774 defsubr (&Snatnump
);
3775 defsubr (&Ssymbolp
);
3776 defsubr (&Skeywordp
);
3777 defsubr (&Sstringp
);
3778 defsubr (&Smultibyte_string_p
);
3779 defsubr (&Svectorp
);
3780 defsubr (&Srecordp
);
3781 defsubr (&Schar_table_p
);
3782 defsubr (&Svector_or_char_table_p
);
3783 defsubr (&Sbool_vector_p
);
3785 defsubr (&Ssequencep
);
3786 defsubr (&Sbufferp
);
3787 defsubr (&Smarkerp
);
3789 defsubr (&Sbyte_code_function_p
);
3790 defsubr (&Schar_or_string_p
);
3791 defsubr (&Sthreadp
);
3793 defsubr (&Scondition_variable_p
);
3796 defsubr (&Scar_safe
);
3797 defsubr (&Scdr_safe
);
3800 defsubr (&Ssymbol_function
);
3801 defsubr (&Sindirect_function
);
3802 defsubr (&Ssymbol_plist
);
3803 defsubr (&Ssymbol_name
);
3804 defsubr (&Smakunbound
);
3805 defsubr (&Sfmakunbound
);
3807 defsubr (&Sfboundp
);
3809 defsubr (&Sdefalias
);
3810 defsubr (&Ssetplist
);
3811 defsubr (&Ssymbol_value
);
3813 defsubr (&Sdefault_boundp
);
3814 defsubr (&Sdefault_value
);
3815 defsubr (&Sset_default
);
3816 defsubr (&Ssetq_default
);
3817 defsubr (&Smake_variable_buffer_local
);
3818 defsubr (&Smake_local_variable
);
3819 defsubr (&Skill_local_variable
);
3820 defsubr (&Slocal_variable_p
);
3821 defsubr (&Slocal_variable_if_set_p
);
3822 defsubr (&Svariable_binding_locus
);
3823 #if 0 /* XXX Remove this. --lorentey */
3824 defsubr (&Sterminal_local_value
);
3825 defsubr (&Sset_terminal_local_value
);
3829 defsubr (&Snumber_to_string
);
3830 defsubr (&Sstring_to_number
);
3831 defsubr (&Seqlsign
);
3853 defsubr (&Sbyteorder
);
3854 defsubr (&Ssubr_arity
);
3855 defsubr (&Ssubr_name
);
3857 defsubr (&Suser_ptrp
);
3860 defsubr (&Sbool_vector_exclusive_or
);
3861 defsubr (&Sbool_vector_union
);
3862 defsubr (&Sbool_vector_intersection
);
3863 defsubr (&Sbool_vector_set_difference
);
3864 defsubr (&Sbool_vector_not
);
3865 defsubr (&Sbool_vector_subsetp
);
3866 defsubr (&Sbool_vector_count_consecutive
);
3867 defsubr (&Sbool_vector_count_population
);
3869 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3871 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3872 doc
: /* The largest value that is representable in a Lisp integer. */);
3873 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3874 make_symbol_constant (intern_c_string ("most-positive-fixnum"));
3876 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3877 doc
: /* The smallest value that is representable in a Lisp integer. */);
3878 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3879 make_symbol_constant (intern_c_string ("most-negative-fixnum"));
3881 DEFSYM (Qwatchers
, "watchers");
3882 DEFSYM (Qmakunbound
, "makunbound");
3883 DEFSYM (Qunlet
, "unlet");
3884 DEFSYM (Qset
, "set");
3885 DEFSYM (Qset_default
, "set-default");
3886 defsubr (&Sadd_variable_watcher
);
3887 defsubr (&Sremove_variable_watcher
);
3888 defsubr (&Sget_variable_watchers
);