1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2018 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 <https://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_Finalizer
:
234 case Lisp_Misc_User_Ptr
:
241 case Lisp_Vectorlike
:
242 switch (PSEUDOVECTOR_TYPE (XVECTOR (object
)))
244 case PVEC_NORMAL_VECTOR
: return Qvector
;
245 case PVEC_WINDOW_CONFIGURATION
: return Qwindow_configuration
;
246 case PVEC_PROCESS
: return Qprocess
;
247 case PVEC_WINDOW
: return Qwindow
;
248 case PVEC_SUBR
: return Qsubr
;
249 case PVEC_COMPILED
: return Qcompiled_function
;
250 case PVEC_BUFFER
: return Qbuffer
;
251 case PVEC_CHAR_TABLE
: return Qchar_table
;
252 case PVEC_BOOL_VECTOR
: return Qbool_vector
;
253 case PVEC_FRAME
: return Qframe
;
254 case PVEC_HASH_TABLE
: return Qhash_table
;
256 if (FONT_SPEC_P (object
))
258 if (FONT_ENTITY_P (object
))
260 if (FONT_OBJECT_P (object
))
263 emacs_abort (); /* return Qfont? */
264 case PVEC_THREAD
: return Qthread
;
265 case PVEC_MUTEX
: return Qmutex
;
266 case PVEC_CONDVAR
: return Qcondition_variable
;
267 case PVEC_TERMINAL
: return Qterminal
;
270 Lisp_Object t
= AREF (object
, 0);
271 if (RECORDP (t
) && 1 < PVSIZE (t
))
272 /* Return the type name field of the class! */
277 case PVEC_MODULE_FUNCTION
:
278 return Qmodule_function
;
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 ("module-function-p", Fmodule_function_p
, Smodule_function_p
, 1, 1, NULL
,
496 doc
: /* Return t if OBJECT is a function loaded from a dynamic module. */
500 return MODULE_FUNCTIONP (object
) ? Qt
: Qnil
;
503 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
504 doc
: /* Return t if OBJECT is a character or a string. */
506 (register Lisp_Object object
)
508 if (CHARACTERP (object
) || STRINGP (object
))
513 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
514 doc
: /* Return t if OBJECT is an integer. */
518 if (INTEGERP (object
))
523 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
524 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
525 (register Lisp_Object object
)
527 if (MARKERP (object
) || INTEGERP (object
))
532 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
533 doc
: /* Return t if OBJECT is a nonnegative integer. */
537 if (NATNUMP (object
))
542 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
543 doc
: /* Return t if OBJECT is a number (floating point or integer). */
547 if (NUMBERP (object
))
553 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
554 Snumber_or_marker_p
, 1, 1, 0,
555 doc
: /* Return t if OBJECT is a number or a marker. */)
558 if (NUMBERP (object
) || MARKERP (object
))
563 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
564 doc
: /* Return t if OBJECT is a floating point number. */
573 DEFUN ("threadp", Fthreadp
, Sthreadp
, 1, 1, 0,
574 doc
: /* Return t if OBJECT is a thread. */)
577 if (THREADP (object
))
582 DEFUN ("mutexp", Fmutexp
, Smutexp
, 1, 1, 0,
583 doc
: /* Return t if OBJECT is a mutex. */)
591 DEFUN ("condition-variable-p", Fcondition_variable_p
, Scondition_variable_p
,
593 doc
: /* Return t if OBJECT is a condition variable. */)
596 if (CONDVARP (object
))
601 /* Extract and set components of lists. */
603 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
604 doc
: /* Return the car of LIST. If arg is nil, return nil.
605 Error if arg is not nil and not a cons cell. See also `car-safe'.
607 See Info node `(elisp)Cons Cells' for a discussion of related basic
608 Lisp concepts such as car, cdr, cons cell and list. */)
609 (register Lisp_Object list
)
614 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
615 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
618 return CAR_SAFE (object
);
621 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
622 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
623 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
625 See Info node `(elisp)Cons Cells' for a discussion of related basic
626 Lisp concepts such as cdr, car, cons cell and list. */)
627 (register Lisp_Object list
)
632 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
633 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
636 return CDR_SAFE (object
);
639 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
640 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
641 (register Lisp_Object cell
, Lisp_Object newcar
)
644 CHECK_IMPURE (cell
, XCONS (cell
));
645 XSETCAR (cell
, newcar
);
649 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
650 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
651 (register Lisp_Object cell
, Lisp_Object newcdr
)
654 CHECK_IMPURE (cell
, XCONS (cell
));
655 XSETCDR (cell
, newcdr
);
659 /* Extract and set components of symbols. */
661 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
662 doc
: /* Return t if SYMBOL's value is not void.
663 Note that if `lexical-binding' is in effect, this refers to the
664 global value outside of any lexical scope. */)
665 (register Lisp_Object symbol
)
667 Lisp_Object valcontents
;
668 struct Lisp_Symbol
*sym
;
669 CHECK_SYMBOL (symbol
);
670 sym
= XSYMBOL (symbol
);
673 switch (sym
->u
.s
.redirect
)
675 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
676 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
677 case SYMBOL_LOCALIZED
:
679 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
681 /* In set_internal, we un-forward vars when their value is
686 swap_in_symval_forwarding (sym
, blv
);
687 valcontents
= blv_value (blv
);
691 case SYMBOL_FORWARDED
:
692 /* In set_internal, we un-forward vars when their value is
695 default: emacs_abort ();
698 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
701 /* It has been previously suggested to make this function an alias for
702 symbol-function, but upon discussion at Bug#23957, there is a risk
703 breaking backward compatibility, as some users of fboundp may
704 expect `t' in particular, rather than any true value. */
705 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
706 doc
: /* Return t if SYMBOL's function definition is not void. */)
709 CHECK_SYMBOL (symbol
);
710 return NILP (XSYMBOL (symbol
)->u
.s
.function
) ? Qnil
: Qt
;
713 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
714 doc
: /* Make SYMBOL's value be void.
716 (register Lisp_Object symbol
)
718 CHECK_SYMBOL (symbol
);
719 if (SYMBOL_CONSTANT_P (symbol
))
720 xsignal1 (Qsetting_constant
, symbol
);
721 Fset (symbol
, Qunbound
);
725 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
726 doc
: /* Make SYMBOL's function definition be nil.
728 (register Lisp_Object symbol
)
730 CHECK_SYMBOL (symbol
);
731 if (NILP (symbol
) || EQ (symbol
, Qt
))
732 xsignal1 (Qsetting_constant
, symbol
);
733 set_symbol_function (symbol
, Qnil
);
737 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
738 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
741 CHECK_SYMBOL (symbol
);
742 return XSYMBOL (symbol
)->u
.s
.function
;
745 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
746 doc
: /* Return SYMBOL's property list. */)
749 CHECK_SYMBOL (symbol
);
750 return XSYMBOL (symbol
)->u
.s
.plist
;
753 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
754 doc
: /* Return SYMBOL's name, a string. */)
755 (register Lisp_Object symbol
)
757 register Lisp_Object name
;
759 CHECK_SYMBOL (symbol
);
760 name
= SYMBOL_NAME (symbol
);
764 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
765 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
766 (register Lisp_Object symbol
, Lisp_Object definition
)
768 register Lisp_Object function
;
769 CHECK_SYMBOL (symbol
);
770 /* Perhaps not quite the right error signal, but seems good enough. */
772 xsignal1 (Qsetting_constant
, symbol
);
774 function
= XSYMBOL (symbol
)->u
.s
.function
;
776 if (!NILP (Vautoload_queue
) && !NILP (function
))
777 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
779 if (AUTOLOADP (function
))
780 Fput (symbol
, Qautoload
, XCDR (function
));
782 /* Convert to eassert or remove after GC bug is found. In the
783 meantime, check unconditionally, at a slight perf hit. */
784 if (! valid_lisp_object_p (definition
))
787 set_symbol_function (symbol
, definition
);
792 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
793 doc
: /* Set SYMBOL's function definition to DEFINITION.
794 Associates the function with the current load file, if any.
795 The optional third argument DOCSTRING specifies the documentation string
796 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
797 determined by DEFINITION.
799 Internally, this normally uses `fset', but if SYMBOL has a
800 `defalias-fset-function' property, the associated value is used instead.
802 The return value is undefined. */)
803 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
805 CHECK_SYMBOL (symbol
);
806 if (!NILP (Vpurify_flag
)
807 /* If `definition' is a keymap, immutable (and copying) is wrong. */
808 && !KEYMAPP (definition
))
809 definition
= Fpurecopy (definition
);
812 bool autoload
= AUTOLOADP (definition
);
813 if (NILP (Vpurify_flag
) || !autoload
)
814 { /* Only add autoload entries after dumping, because the ones before are
815 not useful and else we get loads of them from the loaddefs.el. */
817 if (AUTOLOADP (XSYMBOL (symbol
)->u
.s
.function
))
818 /* Remember that the function was already an autoload. */
819 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
820 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
824 { /* Handle automatic advice activation. */
825 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
827 call2 (hook
, symbol
, definition
);
829 Ffset (symbol
, definition
);
832 if (!NILP (docstring
))
833 Fput (symbol
, Qfunction_documentation
, docstring
);
834 /* We used to return `definition', but now that `defun' and `defmacro' expand
835 to a call to `defalias', we return `symbol' for backward compatibility
840 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
841 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
842 (register Lisp_Object symbol
, Lisp_Object newplist
)
844 CHECK_SYMBOL (symbol
);
845 set_symbol_plist (symbol
, newplist
);
849 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
850 doc
: /* Return minimum and maximum number of args allowed for SUBR.
851 SUBR must be a built-in function.
852 The returned value is a pair (MIN . MAX). MIN is the minimum number
853 of args. MAX is the maximum number or the symbol `many', for a
854 function with `&rest' args, or `unevalled' for a special form. */)
857 short minargs
, maxargs
;
859 minargs
= XSUBR (subr
)->min_args
;
860 maxargs
= XSUBR (subr
)->max_args
;
861 return Fcons (make_number (minargs
),
862 maxargs
== MANY
? Qmany
863 : maxargs
== UNEVALLED
? Qunevalled
864 : make_number (maxargs
));
867 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
868 doc
: /* Return name of subroutine SUBR.
869 SUBR must be a built-in function. */)
874 name
= XSUBR (subr
)->symbol_name
;
875 return build_string (name
);
878 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
879 doc
: /* Return the interactive form of CMD or nil if none.
880 If CMD is not a command, the return value is nil.
881 Value, if non-nil, is a list (interactive SPEC). */)
884 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
889 /* Use an `interactive-form' property if present, analogous to the
890 function-documentation property. */
892 while (SYMBOLP (fun
))
894 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
898 fun
= Fsymbol_function (fun
);
903 const char *spec
= XSUBR (fun
)->intspec
;
905 return list2 (Qinteractive
,
906 (*spec
!= '(') ? build_string (spec
) :
907 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
909 else if (COMPILEDP (fun
))
911 if (PVSIZE (fun
) > COMPILED_INTERACTIVE
)
912 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
914 else if (AUTOLOADP (fun
))
915 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
916 else if (CONSP (fun
))
918 Lisp_Object funcar
= XCAR (fun
);
919 if (EQ (funcar
, Qclosure
))
920 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
921 else if (EQ (funcar
, Qlambda
))
922 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
928 /***********************************************************************
929 Getting and Setting Values of Symbols
930 ***********************************************************************/
932 /* Return the symbol holding SYMBOL's value. Signal
933 `cyclic-variable-indirection' if SYMBOL's chain of variable
934 indirections contains a loop. */
937 indirect_variable (struct Lisp_Symbol
*symbol
)
939 struct Lisp_Symbol
*tortoise
, *hare
;
941 hare
= tortoise
= symbol
;
943 while (hare
->u
.s
.redirect
== SYMBOL_VARALIAS
)
945 hare
= SYMBOL_ALIAS (hare
);
946 if (hare
->u
.s
.redirect
!= SYMBOL_VARALIAS
)
949 hare
= SYMBOL_ALIAS (hare
);
950 tortoise
= SYMBOL_ALIAS (tortoise
);
952 if (hare
== tortoise
)
955 XSETSYMBOL (tem
, symbol
);
956 xsignal1 (Qcyclic_variable_indirection
, tem
);
964 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
965 doc
: /* Return the variable at the end of OBJECT's variable chain.
966 If OBJECT is a symbol, follow its variable indirections (if any), and
967 return the variable at the end of the chain of aliases. See Info node
968 `(elisp)Variable Aliases'.
970 If OBJECT is not a symbol, just return it. If there is a loop in the
971 chain of aliases, signal a `cyclic-variable-indirection' error. */)
974 if (SYMBOLP (object
))
976 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
977 XSETSYMBOL (object
, sym
);
983 /* Given the raw contents of a symbol value cell,
984 return the Lisp value of the symbol.
985 This does not handle buffer-local variables; use
986 swap_in_symval_forwarding for that. */
989 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
991 register Lisp_Object val
;
992 switch (XFWDTYPE (valcontents
))
995 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
999 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1002 return *XOBJFWD (valcontents
)->objvar
;
1004 case Lisp_Fwd_Buffer_Obj
:
1005 return per_buffer_value (current_buffer
,
1006 XBUFFER_OBJFWD (valcontents
)->offset
);
1008 case Lisp_Fwd_Kboard_Obj
:
1009 /* We used to simply use current_kboard here, but from Lisp
1010 code, its value is often unexpected. It seems nicer to
1011 allow constructions like this to work as intuitively expected:
1013 (with-selected-frame frame
1014 (define-key local-function-map "\eOP" [f1]))
1016 On the other hand, this affects the semantics of
1017 last-command and real-last-command, and people may rely on
1018 that. I took a quick look at the Lisp codebase, and I
1019 don't think anything will break. --lorentey */
1020 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1021 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1022 default: emacs_abort ();
1026 /* Used to signal a user-friendly error when symbol WRONG is
1027 not a member of CHOICE, which should be a list of symbols. */
1030 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
1032 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
1033 Lisp_Object obj
, *args
;
1034 AUTO_STRING (one_of
, "One of ");
1035 AUTO_STRING (comma
, ", ");
1036 AUTO_STRING (or, " or ");
1037 AUTO_STRING (should_be_specified
, " should be specified");
1040 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
1044 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
1046 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
1047 args
[i
++] = (NILP (XCDR (obj
)) ? should_be_specified
1048 : NILP (XCDR (XCDR (obj
))) ? or : comma
);
1051 obj
= Fconcat (i
, args
);
1053 xsignal2 (Qerror
, obj
, wrong
);
1056 /* Used to signal a user-friendly error if WRONG is not a number or
1057 integer/floating-point number outsize of inclusive MIN..MAX range. */
1060 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
1062 AUTO_STRING (value_should_be_from
, "Value should be from ");
1063 AUTO_STRING (to
, " to ");
1065 CALLN (Fconcat
, value_should_be_from
, Fnumber_to_string (min
),
1066 to
, Fnumber_to_string (max
)),
1070 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1071 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1072 buffer-independent contents of the value cell: forwarded just one
1073 step past the buffer-localness.
1075 BUF non-zero means set the value in buffer BUF instead of the
1076 current buffer. This only plays a role for per-buffer variables. */
1079 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
1081 switch (XFWDTYPE (valcontents
))
1084 CHECK_NUMBER (newval
);
1085 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1089 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1093 *XOBJFWD (valcontents
)->objvar
= newval
;
1095 /* If this variable is a default for something stored
1096 in the buffer itself, such as default-fill-column,
1097 find the buffers that don't have local values for it
1099 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1100 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1102 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1103 - (char *) &buffer_defaults
);
1104 int idx
= PER_BUFFER_IDX (offset
);
1106 Lisp_Object tail
, buf
;
1111 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1113 struct buffer
*b
= XBUFFER (buf
);
1115 if (! PER_BUFFER_VALUE_P (b
, idx
))
1116 set_per_buffer_value (b
, offset
, newval
);
1121 case Lisp_Fwd_Buffer_Obj
:
1123 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1124 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1128 if (SYMBOLP (predicate
))
1132 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1134 if (NILP (Fmemq (newval
, prop
)))
1135 wrong_choice (prop
, newval
);
1137 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1139 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1140 if (! NUMBERP (newval
)
1141 || NILP (CALLN (Fleq
, min
, newval
, max
)))
1142 wrong_range (min
, max
, newval
);
1144 else if (FUNCTIONP (predicate
))
1146 if (NILP (call1 (predicate
, newval
)))
1147 wrong_type_argument (predicate
, newval
);
1152 buf
= current_buffer
;
1153 set_per_buffer_value (buf
, offset
, newval
);
1157 case Lisp_Fwd_Kboard_Obj
:
1159 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1160 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1161 *(Lisp_Object
*) p
= newval
;
1166 emacs_abort (); /* goto def; */
1170 /* Set up SYMBOL to refer to its global binding. This makes it safe
1171 to alter the status of other bindings. BEWARE: this may be called
1172 during the mark phase of GC, where we assume that Lisp_Object slots
1173 of BLV are marked after this function has changed them. */
1176 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1178 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1180 /* Unload the previously loaded binding. */
1182 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1184 /* Select the global binding in the symbol. */
1185 set_blv_valcell (blv
, blv
->defcell
);
1187 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1189 /* Indicate that the global binding is set up now. */
1190 set_blv_where (blv
, Qnil
);
1191 set_blv_found (blv
, 0);
1194 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1195 VALCONTENTS is the contents of its value cell,
1196 which points to a struct Lisp_Buffer_Local_Value.
1198 Return the value forwarded one step past the buffer-local stage.
1199 This could be another forwarding pointer. */
1202 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1204 register Lisp_Object tem1
;
1206 eassert (blv
== SYMBOL_BLV (symbol
));
1211 || current_buffer
!= XBUFFER (tem1
))
1214 /* Unload the previously loaded binding. */
1215 tem1
= blv
->valcell
;
1217 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1218 /* Choose the new binding. */
1221 XSETSYMBOL (var
, symbol
);
1222 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1223 set_blv_where (blv
, Fcurrent_buffer ());
1225 if (!(blv
->found
= !NILP (tem1
)))
1226 tem1
= blv
->defcell
;
1228 /* Load the new binding. */
1229 set_blv_valcell (blv
, tem1
);
1231 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1235 /* Find the value of a symbol, returning Qunbound if it's not bound.
1236 This is helpful for code which just wants to get a variable's value
1237 if it has one, without signaling an error.
1238 Note that it must not be possible to quit
1239 within this function. Great care is required for this. */
1242 find_symbol_value (Lisp_Object symbol
)
1244 struct Lisp_Symbol
*sym
;
1246 CHECK_SYMBOL (symbol
);
1247 sym
= XSYMBOL (symbol
);
1250 switch (sym
->u
.s
.redirect
)
1252 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1253 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1254 case SYMBOL_LOCALIZED
:
1256 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1257 swap_in_symval_forwarding (sym
, blv
);
1258 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1261 case SYMBOL_FORWARDED
:
1262 return do_symval_forwarding (SYMBOL_FWD (sym
));
1263 default: emacs_abort ();
1267 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1268 doc
: /* Return SYMBOL's value. Error if that is void.
1269 Note that if `lexical-binding' is in effect, this returns the
1270 global value outside of any lexical scope. */)
1271 (Lisp_Object symbol
)
1275 val
= find_symbol_value (symbol
);
1276 if (!EQ (val
, Qunbound
))
1279 xsignal1 (Qvoid_variable
, symbol
);
1282 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1283 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1284 (register Lisp_Object symbol
, Lisp_Object newval
)
1286 set_internal (symbol
, newval
, Qnil
, SET_INTERNAL_SET
);
1290 /* Store the value NEWVAL into SYMBOL.
1291 If buffer-locality is an issue, WHERE specifies which context to use.
1292 (nil stands for the current buffer/frame).
1294 If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to
1295 become local in every buffer where it is set, then we make it
1296 local. If BINDFLAG is SET_INTERNAL_BIND or SET_INTERNAL_UNBIND, we
1300 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1301 enum Set_Internal_Bind bindflag
)
1303 bool voide
= EQ (newval
, Qunbound
);
1304 struct Lisp_Symbol
*sym
;
1307 /* If restoring in a dead buffer, do nothing. */
1308 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1311 CHECK_SYMBOL (symbol
);
1312 sym
= XSYMBOL (symbol
);
1313 switch (sym
->u
.s
.trapped_write
)
1315 case SYMBOL_NOWRITE
:
1316 if (NILP (Fkeywordp (symbol
))
1317 || !EQ (newval
, Fsymbol_value (symbol
)))
1318 xsignal1 (Qsetting_constant
, symbol
);
1320 /* Allow setting keywords to their own value. */
1323 case SYMBOL_TRAPPED_WRITE
:
1324 /* Setting due to thread-switching doesn't count. */
1325 if (bindflag
!= SET_INTERNAL_THREAD_SWITCH
)
1326 notify_variable_watchers (symbol
, voide
? Qnil
: newval
,
1327 (bindflag
== SET_INTERNAL_BIND
? Qlet
:
1328 bindflag
== SET_INTERNAL_UNBIND
? Qunlet
:
1329 voide
? Qmakunbound
: Qset
),
1332 case SYMBOL_UNTRAPPED_WRITE
:
1335 default: emacs_abort ();
1339 switch (sym
->u
.s
.redirect
)
1341 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1342 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1343 case SYMBOL_LOCALIZED
:
1345 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1347 XSETBUFFER (where
, current_buffer
);
1349 /* If the current buffer is not the buffer whose binding is
1350 loaded, or if it's a Lisp_Buffer_Local_Value and
1351 the default binding is loaded, the loaded binding may be the
1353 if (!EQ (blv
->where
, where
)
1354 /* Also unload a global binding (if the var is local_if_set). */
1355 || (EQ (blv
->valcell
, blv
->defcell
)))
1357 /* The currently loaded binding is not necessarily valid.
1358 We need to unload it, and choose a new binding. */
1360 /* Write out `realvalue' to the old loaded binding. */
1362 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1364 /* Find the new binding. */
1365 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1366 tem1
= assq_no_quit (symbol
,
1367 BVAR (XBUFFER (where
), local_var_alist
));
1368 set_blv_where (blv
, where
);
1373 /* This buffer still sees the default value. */
1375 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1376 or if this is `let' rather than `set',
1377 make CURRENT-ALIST-ELEMENT point to itself,
1378 indicating that we're seeing the default value.
1379 Likewise if the variable has been let-bound
1380 in the current buffer. */
1381 if (bindflag
|| !blv
->local_if_set
1382 || let_shadows_buffer_binding_p (sym
))
1385 tem1
= blv
->defcell
;
1387 /* If it's a local_if_set, being set not bound,
1388 and we're not within a let that was made for this buffer,
1389 create a new buffer-local binding for the variable.
1390 That means, give this buffer a new assoc for a local value
1391 and load that binding. */
1394 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1395 bset_local_var_alist
1397 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1401 /* Record which binding is now loaded. */
1402 set_blv_valcell (blv
, tem1
);
1405 /* Store the new value in the cons cell. */
1406 set_blv_value (blv
, newval
);
1411 /* If storing void (making the symbol void), forward only through
1412 buffer-local indicator, not through Lisp_Objfwd, etc. */
1415 store_symval_forwarding (blv
->fwd
, newval
,
1417 ? XBUFFER (where
) : current_buffer
);
1421 case SYMBOL_FORWARDED
:
1424 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1425 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1426 if (BUFFER_OBJFWDP (innercontents
))
1428 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1429 int idx
= PER_BUFFER_IDX (offset
);
1431 && bindflag
== SET_INTERNAL_SET
1432 && !let_shadows_buffer_binding_p (sym
))
1433 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1437 { /* If storing void (making the symbol void), forward only through
1438 buffer-local indicator, not through Lisp_Objfwd, etc. */
1439 sym
->u
.s
.redirect
= SYMBOL_PLAINVAL
;
1440 SET_SYMBOL_VAL (sym
, newval
);
1443 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1446 default: emacs_abort ();
1452 set_symbol_trapped_write (Lisp_Object symbol
, enum symbol_trapped_write trap
)
1454 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1455 if (sym
->u
.s
.trapped_write
== SYMBOL_NOWRITE
)
1456 xsignal1 (Qtrapping_constant
, symbol
);
1457 sym
->u
.s
.trapped_write
= trap
;
1461 restore_symbol_trapped_write (Lisp_Object symbol
)
1463 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1467 harmonize_variable_watchers (Lisp_Object alias
, Lisp_Object base_variable
)
1469 if (!EQ (base_variable
, alias
)
1470 && EQ (base_variable
, Findirect_variable (alias
)))
1471 set_symbol_trapped_write
1472 (alias
, XSYMBOL (base_variable
)->u
.s
.trapped_write
);
1475 DEFUN ("add-variable-watcher", Fadd_variable_watcher
, Sadd_variable_watcher
,
1477 doc
: /* Cause WATCH-FUNCTION to be called when SYMBOL is set.
1479 It will be called with 4 arguments: (SYMBOL NEWVAL OPERATION WHERE).
1480 SYMBOL is the variable being changed.
1481 NEWVAL is the value it will be changed to.
1482 OPERATION is a symbol representing the kind of change, one of: `set',
1483 `let', `unlet', `makunbound', and `defvaralias'.
1484 WHERE is a buffer if the buffer-local value of the variable is being
1485 changed, nil otherwise.
1487 All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */)
1488 (Lisp_Object symbol
, Lisp_Object watch_function
)
1490 symbol
= Findirect_variable (symbol
);
1491 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1492 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1494 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1495 Lisp_Object member
= Fmember (watch_function
, watchers
);
1497 Fput (symbol
, Qwatchers
, Fcons (watch_function
, watchers
));
1501 DEFUN ("remove-variable-watcher", Fremove_variable_watcher
, Sremove_variable_watcher
,
1503 doc
: /* Undo the effect of `add-variable-watcher'.
1504 Remove WATCH-FUNCTION from the list of functions to be called when
1505 SYMBOL (or its aliases) are set. */)
1506 (Lisp_Object symbol
, Lisp_Object watch_function
)
1508 symbol
= Findirect_variable (symbol
);
1509 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1510 watchers
= Fdelete (watch_function
, watchers
);
1511 if (NILP (watchers
))
1513 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1514 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1516 Fput (symbol
, Qwatchers
, watchers
);
1520 DEFUN ("get-variable-watchers", Fget_variable_watchers
, Sget_variable_watchers
,
1522 doc
: /* Return a list of SYMBOL's active watchers. */)
1523 (Lisp_Object symbol
)
1525 return (SYMBOL_TRAPPED_WRITE_P (symbol
) == SYMBOL_TRAPPED_WRITE
)
1526 ? Fget (Findirect_variable (symbol
), Qwatchers
)
1531 notify_variable_watchers (Lisp_Object symbol
,
1533 Lisp_Object operation
,
1536 symbol
= Findirect_variable (symbol
);
1538 ptrdiff_t count
= SPECPDL_INDEX ();
1539 record_unwind_protect (restore_symbol_trapped_write
, symbol
);
1540 /* Avoid recursion. */
1541 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1544 && !EQ (operation
, Qset_default
) && !EQ (operation
, Qmakunbound
)
1545 && !NILP (Flocal_variable_if_set_p (symbol
, Fcurrent_buffer ())))
1547 XSETBUFFER (where
, current_buffer
);
1550 if (EQ (operation
, Qset_default
))
1553 for (Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1555 watchers
= XCDR (watchers
))
1557 Lisp_Object watcher
= XCAR (watchers
);
1558 /* Call subr directly to avoid gc. */
1559 if (SUBRP (watcher
))
1561 Lisp_Object args
[] = { symbol
, newval
, operation
, where
};
1562 funcall_subr (XSUBR (watcher
), ARRAYELTS (args
), args
);
1565 CALLN (Ffuncall
, watcher
, symbol
, newval
, operation
, where
);
1568 unbind_to (count
, Qnil
);
1572 /* Access or set a buffer-local symbol's default value. */
1574 /* Return the default value of SYMBOL, but don't check for voidness.
1575 Return Qunbound if it is void. */
1578 default_value (Lisp_Object symbol
)
1580 struct Lisp_Symbol
*sym
;
1582 CHECK_SYMBOL (symbol
);
1583 sym
= XSYMBOL (symbol
);
1586 switch (sym
->u
.s
.redirect
)
1588 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1589 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1590 case SYMBOL_LOCALIZED
:
1592 /* If var is set up for a buffer that lacks a local value for it,
1593 the current value is nominally the default value.
1594 But the `realvalue' slot may be more up to date, since
1595 ordinary setq stores just that slot. So use that. */
1596 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1597 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1598 return do_symval_forwarding (blv
->fwd
);
1600 return XCDR (blv
->defcell
);
1602 case SYMBOL_FORWARDED
:
1604 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1606 /* For a built-in buffer-local variable, get the default value
1607 rather than letting do_symval_forwarding get the current value. */
1608 if (BUFFER_OBJFWDP (valcontents
))
1610 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1611 if (PER_BUFFER_IDX (offset
) != 0)
1612 return per_buffer_default (offset
);
1615 /* For other variables, get the current value. */
1616 return do_symval_forwarding (valcontents
);
1618 default: emacs_abort ();
1622 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1623 doc
: /* Return t if SYMBOL has a non-void default value.
1624 This is the value that is seen in buffers that do not have their own values
1625 for this variable. */)
1626 (Lisp_Object symbol
)
1628 register Lisp_Object value
;
1630 value
= default_value (symbol
);
1631 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1634 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1635 doc
: /* Return SYMBOL's default value.
1636 This is the value that is seen in buffers that do not have their own values
1637 for this variable. The default value is meaningful for variables with
1638 local bindings in certain buffers. */)
1639 (Lisp_Object symbol
)
1641 Lisp_Object value
= default_value (symbol
);
1642 if (!EQ (value
, Qunbound
))
1645 xsignal1 (Qvoid_variable
, symbol
);
1649 set_default_internal (Lisp_Object symbol
, Lisp_Object value
,
1650 enum Set_Internal_Bind bindflag
)
1652 struct Lisp_Symbol
*sym
;
1654 CHECK_SYMBOL (symbol
);
1655 sym
= XSYMBOL (symbol
);
1656 switch (sym
->u
.s
.trapped_write
)
1658 case SYMBOL_NOWRITE
:
1659 if (NILP (Fkeywordp (symbol
))
1660 || !EQ (value
, Fsymbol_value (symbol
)))
1661 xsignal1 (Qsetting_constant
, symbol
);
1663 /* Allow setting keywords to their own value. */
1666 case SYMBOL_TRAPPED_WRITE
:
1667 /* Don't notify here if we're going to call Fset anyway. */
1668 if (sym
->u
.s
.redirect
!= SYMBOL_PLAINVAL
1669 /* Setting due to thread switching doesn't count. */
1670 && bindflag
!= SET_INTERNAL_THREAD_SWITCH
)
1671 notify_variable_watchers (symbol
, value
, Qset_default
, Qnil
);
1673 case SYMBOL_UNTRAPPED_WRITE
:
1676 default: emacs_abort ();
1680 switch (sym
->u
.s
.redirect
)
1682 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1683 case SYMBOL_PLAINVAL
: set_internal (symbol
, value
, Qnil
, bindflag
); return;
1684 case SYMBOL_LOCALIZED
:
1686 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1688 /* Store new value into the DEFAULT-VALUE slot. */
1689 XSETCDR (blv
->defcell
, value
);
1691 /* If the default binding is now loaded, set the REALVALUE slot too. */
1692 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1693 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1696 case SYMBOL_FORWARDED
:
1698 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1700 /* Handle variables like case-fold-search that have special slots
1702 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1703 if (BUFFER_OBJFWDP (valcontents
))
1705 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1706 int idx
= PER_BUFFER_IDX (offset
);
1708 set_per_buffer_default (offset
, value
);
1710 /* If this variable is not always local in all buffers,
1711 set it in the buffers that don't nominally have a local value. */
1717 if (!PER_BUFFER_VALUE_P (b
, idx
))
1718 set_per_buffer_value (b
, offset
, value
);
1722 set_internal (symbol
, value
, Qnil
, bindflag
);
1725 default: emacs_abort ();
1729 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1730 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1731 The default value is seen in buffers that do not have their own values
1732 for this variable. */)
1733 (Lisp_Object symbol
, Lisp_Object value
)
1735 set_default_internal (symbol
, value
, SET_INTERNAL_SET
);
1739 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1740 doc
: /* Set the default value of variable VAR to VALUE.
1741 VAR, the variable name, is literal (not evaluated);
1742 VALUE is an expression: it is evaluated and its value returned.
1743 The default value of a variable is seen in buffers
1744 that do not have their own values for the variable.
1746 More generally, you can use multiple variables and values, as in
1747 (setq-default VAR VALUE VAR VALUE...)
1748 This sets each VAR's default value to the corresponding VALUE.
1749 The VALUE for the Nth VAR can refer to the new default values
1751 usage: (setq-default [VAR VALUE]...) */)
1754 Lisp_Object args_left
, symbol
, val
;
1756 args_left
= val
= args
;
1758 while (CONSP (args_left
))
1760 val
= eval_sub (Fcar (XCDR (args_left
)));
1761 symbol
= XCAR (args_left
);
1762 Fset_default (symbol
, val
);
1763 args_left
= Fcdr (XCDR (args_left
));
1769 /* Lisp functions for creating and removing buffer-local variables. */
1774 union Lisp_Fwd
*fwd
;
1777 static struct Lisp_Buffer_Local_Value
*
1778 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1779 union Lisp_Val_Fwd valcontents
)
1781 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1785 XSETSYMBOL (symbol
, sym
);
1786 tem
= Fcons (symbol
, (forwarded
1787 ? do_symval_forwarding (valcontents
.fwd
)
1788 : valcontents
.value
));
1790 /* Buffer_Local_Values cannot have as realval a buffer-local
1791 or keyboard-local forwarding. */
1792 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1793 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1794 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1795 set_blv_where (blv
, Qnil
);
1796 blv
->local_if_set
= 0;
1797 set_blv_defcell (blv
, tem
);
1798 set_blv_valcell (blv
, tem
);
1799 set_blv_found (blv
, 0);
1803 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1804 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1805 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1806 At any time, the value for the current buffer is in effect,
1807 unless the variable has never been set in this buffer,
1808 in which case the default value is in effect.
1809 Note that binding the variable with `let', or setting it while
1810 a `let'-style binding made in this buffer is in effect,
1811 does not make the variable buffer-local. Return VARIABLE.
1813 This globally affects all uses of this variable, so it belongs together with
1814 the variable declaration, rather than with its uses (if you just want to make
1815 a variable local to the current buffer for one particular use, use
1816 `make-local-variable'). Buffer-local bindings are normally cleared
1817 while setting up a new major mode, unless they have a `permanent-local'
1820 The function `default-value' gets the default value and `set-default' sets it. */)
1821 (register Lisp_Object variable
)
1823 struct Lisp_Symbol
*sym
;
1824 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1825 union Lisp_Val_Fwd valcontents
;
1826 bool forwarded UNINIT
;
1828 CHECK_SYMBOL (variable
);
1829 sym
= XSYMBOL (variable
);
1832 switch (sym
->u
.s
.redirect
)
1834 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1835 case SYMBOL_PLAINVAL
:
1836 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1837 if (EQ (valcontents
.value
, Qunbound
))
1838 valcontents
.value
= Qnil
;
1840 case SYMBOL_LOCALIZED
:
1841 blv
= SYMBOL_BLV (sym
);
1843 case SYMBOL_FORWARDED
:
1844 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1845 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1846 error ("Symbol %s may not be buffer-local",
1847 SDATA (SYMBOL_NAME (variable
)));
1848 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1851 default: emacs_abort ();
1854 if (SYMBOL_CONSTANT_P (variable
))
1855 xsignal1 (Qsetting_constant
, variable
);
1859 blv
= make_blv (sym
, forwarded
, valcontents
);
1860 sym
->u
.s
.redirect
= SYMBOL_LOCALIZED
;
1861 SET_SYMBOL_BLV (sym
, blv
);
1864 blv
->local_if_set
= 1;
1868 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1869 1, 1, "vMake Local Variable: ",
1870 doc
: /* Make VARIABLE have a separate value in the current buffer.
1871 Other buffers will continue to share a common default value.
1872 \(The buffer-local value of VARIABLE starts out as the same value
1873 VARIABLE previously had. If VARIABLE was void, it remains void.)
1876 If the variable is already arranged to become local when set,
1877 this function causes a local value to exist for this buffer,
1878 just as setting the variable would do.
1880 This function returns VARIABLE, and therefore
1881 (set (make-local-variable \\='VARIABLE) VALUE-EXP)
1884 See also `make-variable-buffer-local'.
1886 Do not use `make-local-variable' to make a hook variable buffer-local.
1887 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1888 (Lisp_Object variable
)
1891 bool forwarded UNINIT
;
1892 union Lisp_Val_Fwd valcontents
;
1893 struct Lisp_Symbol
*sym
;
1894 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1896 CHECK_SYMBOL (variable
);
1897 sym
= XSYMBOL (variable
);
1900 switch (sym
->u
.s
.redirect
)
1902 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1903 case SYMBOL_PLAINVAL
:
1904 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1905 case SYMBOL_LOCALIZED
:
1906 blv
= SYMBOL_BLV (sym
);
1908 case SYMBOL_FORWARDED
:
1909 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1910 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1911 error ("Symbol %s may not be buffer-local",
1912 SDATA (SYMBOL_NAME (variable
)));
1914 default: emacs_abort ();
1917 if (sym
->u
.s
.trapped_write
== SYMBOL_NOWRITE
)
1918 xsignal1 (Qsetting_constant
, variable
);
1920 if (blv
? blv
->local_if_set
1921 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1923 tem
= Fboundp (variable
);
1924 /* Make sure the symbol has a local value in this particular buffer,
1925 by setting it to the same value it already has. */
1926 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1931 blv
= make_blv (sym
, forwarded
, valcontents
);
1932 sym
->u
.s
.redirect
= SYMBOL_LOCALIZED
;
1933 SET_SYMBOL_BLV (sym
, blv
);
1936 /* Make sure this buffer has its own value of symbol. */
1937 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1938 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1941 if (let_shadows_buffer_binding_p (sym
))
1943 AUTO_STRING (format
,
1944 "Making %s buffer-local while locally let-bound!");
1945 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1948 /* Swap out any local binding for some other buffer, and make
1949 sure the current value is permanently recorded, if it's the
1951 find_symbol_value (variable
);
1953 bset_local_var_alist
1955 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1956 BVAR (current_buffer
, local_var_alist
)));
1958 /* Make sure symbol does not think it is set up for this buffer;
1959 force it to look once again for this buffer's value. */
1960 if (current_buffer
== XBUFFER (blv
->where
))
1961 set_blv_where (blv
, Qnil
);
1962 set_blv_found (blv
, 0);
1965 /* If the symbol forwards into a C variable, then load the binding
1966 for this buffer now. If C code modifies the variable before we
1967 load the binding in, then that new value will clobber the default
1968 binding the next time we unload it. */
1970 swap_in_symval_forwarding (sym
, blv
);
1975 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1976 1, 1, "vKill Local Variable: ",
1977 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1978 From now on the default value will apply in this buffer. Return VARIABLE. */)
1979 (register Lisp_Object variable
)
1981 register Lisp_Object tem
;
1982 struct Lisp_Buffer_Local_Value
*blv
;
1983 struct Lisp_Symbol
*sym
;
1985 CHECK_SYMBOL (variable
);
1986 sym
= XSYMBOL (variable
);
1989 switch (sym
->u
.s
.redirect
)
1991 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1992 case SYMBOL_PLAINVAL
: return variable
;
1993 case SYMBOL_FORWARDED
:
1995 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1996 if (BUFFER_OBJFWDP (valcontents
))
1998 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1999 int idx
= PER_BUFFER_IDX (offset
);
2003 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
2004 set_per_buffer_value (current_buffer
, offset
,
2005 per_buffer_default (offset
));
2010 case SYMBOL_LOCALIZED
:
2011 blv
= SYMBOL_BLV (sym
);
2013 default: emacs_abort ();
2016 if (sym
->u
.s
.trapped_write
== SYMBOL_TRAPPED_WRITE
)
2017 notify_variable_watchers (variable
, Qnil
, Qmakunbound
, Fcurrent_buffer ());
2019 /* Get rid of this buffer's alist element, if any. */
2020 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
2021 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
2023 bset_local_var_alist
2025 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
2027 /* If the symbol is set up with the current buffer's binding
2028 loaded, recompute its value. We have to do it now, or else
2029 forwarded objects won't work right. */
2031 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
2032 if (EQ (buf
, blv
->where
))
2034 set_blv_where (blv
, Qnil
);
2036 find_symbol_value (variable
);
2043 /* Lisp functions for creating and removing buffer-local variables. */
2045 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
2047 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
2048 BUFFER defaults to the current buffer. */)
2049 (Lisp_Object variable
, Lisp_Object buffer
)
2051 struct buffer
*buf
= decode_buffer (buffer
);
2052 struct Lisp_Symbol
*sym
;
2054 CHECK_SYMBOL (variable
);
2055 sym
= XSYMBOL (variable
);
2058 switch (sym
->u
.s
.redirect
)
2060 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2061 case SYMBOL_PLAINVAL
: return Qnil
;
2062 case SYMBOL_LOCALIZED
:
2064 Lisp_Object tail
, elt
, tmp
;
2065 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2066 XSETBUFFER (tmp
, buf
);
2067 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2069 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
2070 return blv_found (blv
) ? Qt
: Qnil
;
2072 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
2075 if (EQ (variable
, XCAR (elt
)))
2080 case SYMBOL_FORWARDED
:
2082 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2083 if (BUFFER_OBJFWDP (valcontents
))
2085 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2086 int idx
= PER_BUFFER_IDX (offset
);
2087 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2092 default: emacs_abort ();
2096 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2098 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
2099 BUFFER defaults to the current buffer.
2101 More precisely, return non-nil if either VARIABLE already has a local
2102 value in BUFFER, or if VARIABLE is automatically buffer-local (see
2103 `make-variable-buffer-local'). */)
2104 (register Lisp_Object variable
, Lisp_Object buffer
)
2106 struct Lisp_Symbol
*sym
;
2108 CHECK_SYMBOL (variable
);
2109 sym
= XSYMBOL (variable
);
2112 switch (sym
->u
.s
.redirect
)
2114 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2115 case SYMBOL_PLAINVAL
: return Qnil
;
2116 case SYMBOL_LOCALIZED
:
2118 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2119 if (blv
->local_if_set
)
2121 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2122 return Flocal_variable_p (variable
, buffer
);
2124 case SYMBOL_FORWARDED
:
2125 /* All BUFFER_OBJFWD slots become local if they are set. */
2126 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2127 default: emacs_abort ();
2131 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2133 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2134 If the current binding is buffer-local, the value is the current buffer.
2135 If the current binding is global (the default), the value is nil. */)
2136 (register Lisp_Object variable
)
2138 struct Lisp_Symbol
*sym
;
2140 CHECK_SYMBOL (variable
);
2141 sym
= XSYMBOL (variable
);
2143 /* Make sure the current binding is actually swapped in. */
2144 find_symbol_value (variable
);
2147 switch (sym
->u
.s
.redirect
)
2149 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2150 case SYMBOL_PLAINVAL
: return Qnil
;
2151 case SYMBOL_FORWARDED
:
2153 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2154 if (KBOARD_OBJFWDP (valcontents
))
2155 return Fframe_terminal (selected_frame
);
2156 else if (!BUFFER_OBJFWDP (valcontents
))
2160 case SYMBOL_LOCALIZED
:
2161 /* For a local variable, record both the symbol and which
2162 buffer's or frame's value we are saving. */
2163 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2164 return Fcurrent_buffer ();
2165 else if (sym
->u
.s
.redirect
== SYMBOL_LOCALIZED
2166 && blv_found (SYMBOL_BLV (sym
)))
2167 return SYMBOL_BLV (sym
)->where
;
2170 default: emacs_abort ();
2174 /* This code is disabled now that we use the selected frame to return
2175 keyboard-local-values. */
2177 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2179 DEFUN ("terminal-local-value", Fterminal_local_value
,
2180 Sterminal_local_value
, 2, 2, 0,
2181 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2182 If SYMBOL is not a terminal-local variable, then return its normal
2183 value, like `symbol-value'.
2185 TERMINAL may be a terminal object, a frame, or nil (meaning the
2186 selected frame's terminal device). */)
2187 (Lisp_Object symbol
, Lisp_Object terminal
)
2190 struct terminal
*t
= get_terminal (terminal
, 1);
2191 push_kboard (t
->kboard
);
2192 result
= Fsymbol_value (symbol
);
2197 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2198 Sset_terminal_local_value
, 3, 3, 0,
2199 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2200 If VARIABLE is not a terminal-local variable, then set its normal
2201 binding, like `set'.
2203 TERMINAL may be a terminal object, a frame, or nil (meaning the
2204 selected frame's terminal device). */)
2205 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2208 struct terminal
*t
= get_terminal (terminal
, 1);
2209 push_kboard (d
->kboard
);
2210 result
= Fset (symbol
, value
);
2216 /* Find the function at the end of a chain of symbol function indirections. */
2218 /* If OBJECT is a symbol, find the end of its function chain and
2219 return the value found there. If OBJECT is not a symbol, just
2220 return it. If there is a cycle in the function chain, signal a
2221 cyclic-function-indirection error.
2223 This is like Findirect_function, except that it doesn't signal an
2224 error if the chain ends up unbound. */
2226 indirect_function (register Lisp_Object object
)
2228 Lisp_Object tortoise
, hare
;
2230 hare
= tortoise
= object
;
2234 if (!SYMBOLP (hare
) || NILP (hare
))
2236 hare
= XSYMBOL (hare
)->u
.s
.function
;
2237 if (!SYMBOLP (hare
) || NILP (hare
))
2239 hare
= XSYMBOL (hare
)->u
.s
.function
;
2241 tortoise
= XSYMBOL (tortoise
)->u
.s
.function
;
2243 if (EQ (hare
, tortoise
))
2244 xsignal1 (Qcyclic_function_indirection
, object
);
2250 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2251 doc
: /* Return the function at the end of OBJECT's function chain.
2252 If OBJECT is not a symbol, just return it. Otherwise, follow all
2253 function indirections to find the final function binding and return it.
2254 Signal a cyclic-function-indirection error if there is a loop in the
2255 function chain of symbols. */)
2256 (register Lisp_Object object
, Lisp_Object noerror
)
2260 /* Optimize for no indirection. */
2262 if (SYMBOLP (result
) && !NILP (result
)
2263 && (result
= XSYMBOL (result
)->u
.s
.function
, SYMBOLP (result
)))
2264 result
= indirect_function (result
);
2271 /* Extract and set vector and string elements. */
2273 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2274 doc
: /* Return the element of ARG at index IDX.
2275 ARG may be a vector, a string, a char-table, a bool-vector, a record,
2276 or a byte-code object. IDX starts at 0. */)
2277 (register Lisp_Object array
, Lisp_Object idx
)
2279 register EMACS_INT idxval
;
2282 idxval
= XINT (idx
);
2283 if (STRINGP (array
))
2286 ptrdiff_t idxval_byte
;
2288 if (idxval
< 0 || idxval
>= SCHARS (array
))
2289 args_out_of_range (array
, idx
);
2290 if (! STRING_MULTIBYTE (array
))
2291 return make_number ((unsigned char) SREF (array
, idxval
));
2292 idxval_byte
= string_char_to_byte (array
, idxval
);
2294 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2295 return make_number (c
);
2297 else if (BOOL_VECTOR_P (array
))
2299 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2300 args_out_of_range (array
, idx
);
2301 return bool_vector_ref (array
, idxval
);
2303 else if (CHAR_TABLE_P (array
))
2305 CHECK_CHARACTER (idx
);
2306 return CHAR_TABLE_REF (array
, idxval
);
2311 if (VECTORP (array
))
2312 size
= ASIZE (array
);
2313 else if (COMPILEDP (array
) || RECORDP (array
))
2314 size
= PVSIZE (array
);
2316 wrong_type_argument (Qarrayp
, array
);
2318 if (idxval
< 0 || idxval
>= size
)
2319 args_out_of_range (array
, idx
);
2320 return AREF (array
, idxval
);
2324 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2325 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2326 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2327 bool-vector. IDX starts at 0. */)
2328 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2330 register EMACS_INT idxval
;
2333 idxval
= XINT (idx
);
2334 if (! RECORDP (array
))
2335 CHECK_ARRAY (array
, Qarrayp
);
2337 if (VECTORP (array
))
2339 CHECK_IMPURE (array
, XVECTOR (array
));
2340 if (idxval
< 0 || idxval
>= ASIZE (array
))
2341 args_out_of_range (array
, idx
);
2342 ASET (array
, idxval
, newelt
);
2344 else if (BOOL_VECTOR_P (array
))
2346 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2347 args_out_of_range (array
, idx
);
2348 bool_vector_set (array
, idxval
, !NILP (newelt
));
2350 else if (CHAR_TABLE_P (array
))
2352 CHECK_CHARACTER (idx
);
2353 CHAR_TABLE_SET (array
, idxval
, newelt
);
2355 else if (RECORDP (array
))
2357 if (idxval
< 0 || idxval
>= PVSIZE (array
))
2358 args_out_of_range (array
, idx
);
2359 ASET (array
, idxval
, newelt
);
2365 CHECK_IMPURE (array
, XSTRING (array
));
2366 if (idxval
< 0 || idxval
>= SCHARS (array
))
2367 args_out_of_range (array
, idx
);
2368 CHECK_CHARACTER (newelt
);
2369 c
= XFASTINT (newelt
);
2371 if (STRING_MULTIBYTE (array
))
2373 ptrdiff_t idxval_byte
, nbytes
;
2374 int prev_bytes
, new_bytes
;
2375 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2377 nbytes
= SBYTES (array
);
2378 idxval_byte
= string_char_to_byte (array
, idxval
);
2379 p1
= SDATA (array
) + idxval_byte
;
2380 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2381 new_bytes
= CHAR_STRING (c
, p0
);
2382 if (prev_bytes
!= new_bytes
)
2384 /* We must relocate the string data. */
2385 ptrdiff_t nchars
= SCHARS (array
);
2387 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2389 memcpy (str
, SDATA (array
), nbytes
);
2390 allocate_string_data (XSTRING (array
), nchars
,
2391 nbytes
+ new_bytes
- prev_bytes
);
2392 memcpy (SDATA (array
), str
, idxval_byte
);
2393 p1
= SDATA (array
) + idxval_byte
;
2394 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2395 nbytes
- (idxval_byte
+ prev_bytes
));
2397 clear_string_char_byte_cache ();
2404 if (! SINGLE_BYTE_CHAR_P (c
))
2408 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2409 if (SREF (array
, i
) >= 0x80)
2410 args_out_of_range (array
, newelt
);
2411 /* ARRAY is an ASCII string. Convert it to a multibyte
2412 string, and try `aset' again. */
2413 STRING_SET_MULTIBYTE (array
);
2414 return Faset (array
, idx
, newelt
);
2416 SSET (array
, idxval
, c
);
2423 /* Arithmetic functions */
2426 arithcompare (Lisp_Object num1
, Lisp_Object num2
,
2427 enum Arith_Comparison comparison
)
2434 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2435 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2437 /* If either arg is floating point, set F1 and F2 to the 'double'
2438 approximations of the two arguments, and set FNEQ if floating-point
2439 comparison reports that F1 is not equal to F2, possibly because F1
2440 or F2 is a NaN. Regardless, set I1 and I2 to integers that break
2441 ties if the floating-point comparison is either not done or reports
2446 f1
= XFLOAT_DATA (num1
);
2450 f2
= XFLOAT_DATA (num2
);
2454 /* Compare a float NUM1 to an integer NUM2 by converting the
2455 integer I2 (i.e., NUM2) to the double F2 (a conversion that
2456 can round on some platforms, if I2 is large enough), and then
2457 converting F2 back to the integer I1 (a conversion that is
2458 always exact), so that I1 exactly equals ((double) NUM2). If
2459 floating-point comparison reports a tie, NUM1 = F1 = F2 = I1
2460 (exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1
2461 to I2 will break the tie correctly. */
2462 i1
= f2
= i2
= XINT (num2
);
2471 /* Compare an integer NUM1 to a float NUM2. This is the
2472 converse of comparing float to integer (see above). */
2474 f2
= XFLOAT_DATA (num2
);
2487 test
= !fneq
&& i1
== i2
;
2490 case ARITH_NOTEQUAL
:
2491 test
= fneq
|| i1
!= i2
;
2495 test
= fneq
? f1
< f2
: i1
< i2
;
2498 case ARITH_LESS_OR_EQUAL
:
2499 test
= fneq
? f1
<= f2
: i1
<= i2
;
2503 test
= fneq
? f1
> f2
: i1
> i2
;
2506 case ARITH_GRTR_OR_EQUAL
:
2507 test
= fneq
? f1
>= f2
: i1
>= i2
;
2514 return test
? Qt
: Qnil
;
2518 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2519 enum Arith_Comparison comparison
)
2521 for (ptrdiff_t i
= 1; i
< nargs
; i
++)
2522 if (NILP (arithcompare (args
[i
- 1], args
[i
], comparison
)))
2527 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2528 doc
: /* Return t if args, all numbers or markers, are equal.
2529 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2530 (ptrdiff_t nargs
, Lisp_Object
*args
)
2532 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2535 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2536 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2537 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2538 (ptrdiff_t nargs
, Lisp_Object
*args
)
2540 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2543 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2544 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2545 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2546 (ptrdiff_t nargs
, Lisp_Object
*args
)
2548 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2551 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2552 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2553 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2554 (ptrdiff_t nargs
, Lisp_Object
*args
)
2556 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2559 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2560 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2561 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2562 (ptrdiff_t nargs
, Lisp_Object
*args
)
2564 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2567 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2568 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2569 (register Lisp_Object num1
, Lisp_Object num2
)
2571 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2574 /* Convert the integer I to a cons-of-integers, where I is not in
2577 #define INTBIG_TO_LISP(i, extremum) \
2578 (eassert (FIXNUM_OVERFLOW_P (i)), \
2579 (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \
2580 && FIXNUM_OVERFLOW_P ((i) >> 16)) \
2581 ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \
2582 : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \
2583 && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \
2584 ? Fcons (make_number ((i) >> 16 >> 24), \
2585 Fcons (make_number ((i) >> 16 & 0xffffff), \
2586 make_number ((i) & 0xffff))) \
2590 intbig_to_lisp (intmax_t i
)
2592 return INTBIG_TO_LISP (i
, INTMAX_MIN
);
2596 uintbig_to_lisp (uintmax_t i
)
2598 return INTBIG_TO_LISP (i
, UINTMAX_MAX
);
2601 /* Convert the cons-of-integers, integer, or float value C to an
2602 unsigned value with maximum value MAX, where MAX is one less than a
2603 power of 2. Signal an error if C does not have a valid format or
2606 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2609 uintmax_t val UNINIT
;
2612 valid
= XINT (c
) >= 0;
2615 else if (FLOATP (c
))
2617 double d
= XFLOAT_DATA (c
);
2618 if (d
>= 0 && d
< 1.0 + max
)
2624 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2626 uintmax_t top
= XFASTINT (XCAR (c
));
2627 Lisp_Object rest
= XCDR (c
);
2628 if (top
<= UINTMAX_MAX
>> 24 >> 16
2630 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2631 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2633 uintmax_t mid
= XFASTINT (XCAR (rest
));
2634 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2637 else if (top
<= UINTMAX_MAX
>> 16)
2641 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2643 val
= top
<< 16 | XFASTINT (rest
);
2649 if (! (valid
&& val
<= max
))
2650 error ("Not an in-range integer, integral float, or cons of integers");
2654 /* Convert the cons-of-integers, integer, or float value C to a signed
2655 value with extrema MIN and MAX. MAX should be one less than a
2656 power of 2, and MIN should be zero or the negative of a power of 2.
2657 Signal an error if C does not have a valid format or is out of
2660 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2663 intmax_t val UNINIT
;
2669 else if (FLOATP (c
))
2671 double d
= XFLOAT_DATA (c
);
2672 if (d
>= min
&& d
< 1.0 + max
)
2678 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2680 intmax_t top
= XINT (XCAR (c
));
2681 Lisp_Object rest
= XCDR (c
);
2682 if (top
>= INTMAX_MIN
>> 24 >> 16 && top
<= INTMAX_MAX
>> 24 >> 16
2684 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2685 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2687 intmax_t mid
= XFASTINT (XCAR (rest
));
2688 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2691 else if (top
>= INTMAX_MIN
>> 16 && top
<= INTMAX_MAX
>> 16)
2695 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2697 val
= top
<< 16 | XFASTINT (rest
);
2703 if (! (valid
&& min
<= val
&& val
<= max
))
2704 error ("Not an in-range integer, integral float, or cons of integers");
2708 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2709 doc
: /* Return the decimal representation of NUMBER as a string.
2710 Uses a minus sign if negative.
2711 NUMBER may be an integer or a floating point number. */)
2712 (Lisp_Object number
)
2714 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2717 CHECK_NUMBER_OR_FLOAT (number
);
2719 if (FLOATP (number
))
2720 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2722 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2724 return make_unibyte_string (buffer
, len
);
2727 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2728 doc
: /* Parse STRING as a decimal number and return the number.
2729 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2730 STRING cannot be parsed as an integer or floating point number.
2732 If BASE, interpret STRING as a number in that base. If BASE isn't
2733 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2734 If the base used is not 10, STRING is always parsed as an integer. */)
2735 (register Lisp_Object string
, Lisp_Object base
)
2741 CHECK_STRING (string
);
2747 CHECK_NUMBER (base
);
2748 if (! (XINT (base
) >= 2 && XINT (base
) <= 16))
2749 xsignal1 (Qargs_out_of_range
, base
);
2753 p
= SSDATA (string
);
2754 while (*p
== ' ' || *p
== '\t')
2757 val
= string_to_number (p
, b
, 1);
2758 return NILP (val
) ? make_number (0) : val
;
2772 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2773 ptrdiff_t, Lisp_Object
*);
2775 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2778 ptrdiff_t argnum
, ok_args
;
2779 EMACS_INT accum
= 0;
2780 EMACS_INT next
, ok_accum
;
2802 for (argnum
= 0; argnum
< nargs
; argnum
++)
2810 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2812 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2815 return float_arith_driver (ok_accum
, ok_args
, code
,
2818 next
= XINT (args
[argnum
]);
2822 overflow
|= INT_ADD_WRAPV (accum
, next
, &accum
);
2826 accum
= nargs
== 1 ? - next
: next
;
2828 overflow
|= INT_SUBTRACT_WRAPV (accum
, next
, &accum
);
2831 overflow
|= INT_MULTIPLY_WRAPV (accum
, next
, &accum
);
2834 if (! (argnum
|| nargs
== 1))
2839 xsignal0 (Qarith_error
);
2840 if (INT_DIVIDE_OVERFLOW (accum
, next
))
2858 XSETINT (val
, accum
);
2863 # define isnan(x) ((x) != (x))
2867 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2868 ptrdiff_t nargs
, Lisp_Object
*args
)
2870 register Lisp_Object val
;
2873 for (; argnum
< nargs
; argnum
++)
2875 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2876 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2880 next
= XFLOAT_DATA (val
);
2884 args
[argnum
] = val
; /* runs into a compiler bug. */
2885 next
= XINT (args
[argnum
]);
2893 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2899 if (! (argnum
|| nargs
== 1))
2903 if (! IEEE_FLOATING_POINT
&& next
== 0)
2904 xsignal0 (Qarith_error
);
2911 wrong_type_argument (Qinteger_or_marker_p
, val
);
2915 return make_float (accum
);
2919 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2920 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2921 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2922 (ptrdiff_t nargs
, Lisp_Object
*args
)
2924 return arith_driver (Aadd
, nargs
, args
);
2927 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2928 doc
: /* Negate number or subtract numbers or markers and return the result.
2929 With one arg, negates it. With more than one arg,
2930 subtracts all but the first from the first.
2931 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2932 (ptrdiff_t nargs
, Lisp_Object
*args
)
2934 return arith_driver (Asub
, nargs
, args
);
2937 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2938 doc
: /* Return product of any number of arguments, which are numbers or markers.
2939 usage: (* &rest NUMBERS-OR-MARKERS) */)
2940 (ptrdiff_t nargs
, Lisp_Object
*args
)
2942 return arith_driver (Amult
, nargs
, args
);
2945 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2946 doc
: /* Divide number by divisors and return the result.
2947 With two or more arguments, return first argument divided by the rest.
2948 With one argument, return 1 divided by the argument.
2949 The arguments must be numbers or markers.
2950 usage: (/ NUMBER &rest DIVISORS) */)
2951 (ptrdiff_t nargs
, Lisp_Object
*args
)
2954 for (argnum
= 2; argnum
< nargs
; argnum
++)
2955 if (FLOATP (args
[argnum
]))
2956 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2957 return arith_driver (Adiv
, nargs
, args
);
2960 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2961 doc
: /* Return remainder of X divided by Y.
2962 Both must be integers or markers. */)
2963 (register Lisp_Object x
, Lisp_Object y
)
2967 CHECK_NUMBER_COERCE_MARKER (x
);
2968 CHECK_NUMBER_COERCE_MARKER (y
);
2971 xsignal0 (Qarith_error
);
2973 XSETINT (val
, XINT (x
) % XINT (y
));
2977 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2978 doc
: /* Return X modulo Y.
2979 The result falls between zero (inclusive) and Y (exclusive).
2980 Both X and Y must be numbers or markers. */)
2981 (register Lisp_Object x
, Lisp_Object y
)
2986 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2987 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2989 if (FLOATP (x
) || FLOATP (y
))
2990 return fmod_float (x
, y
);
2996 xsignal0 (Qarith_error
);
3000 /* If the "remainder" comes out with the wrong sign, fix it. */
3001 if (i2
< 0 ? i1
> 0 : i1
< 0)
3009 minmax_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
3010 enum Arith_Comparison comparison
)
3012 Lisp_Object accum
= args
[0];
3013 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (accum
);
3014 for (ptrdiff_t argnum
= 1; argnum
< nargs
; argnum
++)
3016 Lisp_Object val
= args
[argnum
];
3017 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
3018 if (!NILP (arithcompare (val
, accum
, comparison
)))
3020 else if (FLOATP (val
) && isnan (XFLOAT_DATA (val
)))
3026 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
3027 doc
: /* Return largest of all the arguments (which must be numbers or markers).
3028 The value is always a number; markers are converted to numbers.
3029 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3030 (ptrdiff_t nargs
, Lisp_Object
*args
)
3032 return minmax_driver (nargs
, args
, ARITH_GRTR
);
3035 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
3036 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
3037 The value is always a number; markers are converted to numbers.
3038 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3039 (ptrdiff_t nargs
, Lisp_Object
*args
)
3041 return minmax_driver (nargs
, args
, ARITH_LESS
);
3044 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
3045 doc
: /* Return bitwise-and of all the arguments.
3046 Arguments may be integers, or markers converted to integers.
3047 usage: (logand &rest INTS-OR-MARKERS) */)
3048 (ptrdiff_t nargs
, Lisp_Object
*args
)
3050 return arith_driver (Alogand
, nargs
, args
);
3053 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
3054 doc
: /* Return bitwise-or of all the arguments.
3055 Arguments may be integers, or markers converted to integers.
3056 usage: (logior &rest INTS-OR-MARKERS) */)
3057 (ptrdiff_t nargs
, Lisp_Object
*args
)
3059 return arith_driver (Alogior
, nargs
, args
);
3062 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
3063 doc
: /* Return bitwise-exclusive-or of all the arguments.
3064 Arguments may be integers, or markers converted to integers.
3065 usage: (logxor &rest INTS-OR-MARKERS) */)
3066 (ptrdiff_t nargs
, Lisp_Object
*args
)
3068 return arith_driver (Alogxor
, nargs
, args
);
3071 DEFUN ("logcount", Flogcount
, Slogcount
, 1, 1, 0,
3072 doc
: /* Return population count of VALUE.
3073 This is the number of one bits in the two's complement representation
3074 of VALUE. If VALUE is negative, return the number of zero bits in the
3078 CHECK_NUMBER (value
);
3079 EMACS_INT v
= XINT (value
) < 0 ? -1 - XINT (value
) : XINT (value
);
3080 return make_number (EMACS_UINT_WIDTH
<= UINT_WIDTH
3081 ? count_one_bits (v
)
3082 : EMACS_UINT_WIDTH
<= ULONG_WIDTH
3083 ? count_one_bits_l (v
)
3084 : count_one_bits_ll (v
));
3088 ash_lsh_impl (Lisp_Object value
, Lisp_Object count
, bool lsh
)
3090 /* This code assumes that signed right shifts are arithmetic. */
3091 verify ((EMACS_INT
) -1 >> 1 == -1);
3095 CHECK_NUMBER (value
);
3096 CHECK_NUMBER (count
);
3098 if (XINT (count
) >= EMACS_INT_WIDTH
)
3100 else if (XINT (count
) > 0)
3101 XSETINT (val
, XUINT (value
) << XINT (count
));
3102 else if (XINT (count
) <= -EMACS_INT_WIDTH
)
3103 XSETINT (val
, lsh
? 0 : XINT (value
) < 0 ? -1 : 0);
3105 XSETINT (val
, (lsh
? XUINT (value
) >> -XINT (count
)
3106 : XINT (value
) >> -XINT (count
)));
3110 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
3111 doc
: /* Return VALUE with its bits shifted left by COUNT.
3112 If COUNT is negative, shifting is actually to the right.
3113 In this case, the sign bit is duplicated. */)
3114 (register Lisp_Object value
, Lisp_Object count
)
3116 return ash_lsh_impl (value
, count
, false);
3119 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
3120 doc
: /* Return VALUE with its bits shifted left by COUNT.
3121 If COUNT is negative, shifting is actually to the right.
3122 In this case, zeros are shifted in on the left. */)
3123 (register Lisp_Object value
, Lisp_Object count
)
3125 return ash_lsh_impl (value
, count
, true);
3128 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3129 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3130 Markers are converted to integers. */)
3131 (register Lisp_Object number
)
3133 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3135 if (FLOATP (number
))
3136 return (make_float (1.0 + XFLOAT_DATA (number
)));
3138 XSETINT (number
, XINT (number
) + 1);
3142 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3143 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3144 Markers are converted to integers. */)
3145 (register Lisp_Object number
)
3147 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3149 if (FLOATP (number
))
3150 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3152 XSETINT (number
, XINT (number
) - 1);
3156 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3157 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3158 (register Lisp_Object number
)
3160 CHECK_NUMBER (number
);
3161 XSETINT (number
, ~XINT (number
));
3165 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3166 doc
: /* Return the byteorder for the machine.
3167 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3168 lowercase l) for small endian machines. */
3172 unsigned i
= 0x04030201;
3173 int order
= *(char *)&i
== 1 ? 108 : 66;
3175 return make_number (order
);
3178 /* Because we round up the bool vector allocate size to word_size
3179 units, we can safely read past the "end" of the vector in the
3180 operations below. These extra bits are always zero. */
3183 bool_vector_spare_mask (EMACS_INT nr_bits
)
3185 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
3188 /* Info about unsigned long long, falling back on unsigned long
3189 if unsigned long long is not available. */
3191 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH
3192 enum { ULL_WIDTH
= ULLONG_WIDTH
};
3193 # define ULL_MAX ULLONG_MAX
3195 enum { ULL_WIDTH
= ULONG_WIDTH
};
3196 # define ULL_MAX ULONG_MAX
3197 # define count_one_bits_ll count_one_bits_l
3198 # define count_trailing_zeros_ll count_trailing_zeros_l
3201 /* Shift VAL right by the width of an unsigned long long.
3202 ULL_WIDTH must be less than BITS_PER_BITS_WORD. */
3205 shift_right_ull (bits_word w
)
3207 /* Pacify bogus GCC warning about shift count exceeding type width. */
3208 int shift
= ULL_WIDTH
- BITS_PER_BITS_WORD
< 0 ? ULL_WIDTH
: 0;
3212 /* Return the number of 1 bits in W. */
3215 count_one_bits_word (bits_word w
)
3217 if (BITS_WORD_MAX
<= UINT_MAX
)
3218 return count_one_bits (w
);
3219 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3220 return count_one_bits_l (w
);
3223 int i
= 0, count
= 0;
3224 while (count
+= count_one_bits_ll (w
),
3225 (i
+= ULL_WIDTH
) < BITS_PER_BITS_WORD
)
3226 w
= shift_right_ull (w
);
3231 enum bool_vector_op
{ bool_vector_exclusive_or
,
3233 bool_vector_intersection
,
3234 bool_vector_set_difference
,
3235 bool_vector_subsetp
};
3238 bool_vector_binop_driver (Lisp_Object a
,
3241 enum bool_vector_op op
)
3244 bits_word
*adata
, *bdata
, *destdata
;
3248 CHECK_BOOL_VECTOR (a
);
3249 CHECK_BOOL_VECTOR (b
);
3251 nr_bits
= bool_vector_size (a
);
3252 if (bool_vector_size (b
) != nr_bits
)
3253 wrong_length_argument (a
, b
, dest
);
3255 nr_words
= bool_vector_words (nr_bits
);
3256 adata
= bool_vector_data (a
);
3257 bdata
= bool_vector_data (b
);
3261 dest
= make_uninit_bool_vector (nr_bits
);
3262 destdata
= bool_vector_data (dest
);
3266 CHECK_BOOL_VECTOR (dest
);
3267 destdata
= bool_vector_data (dest
);
3268 if (bool_vector_size (dest
) != nr_bits
)
3269 wrong_length_argument (a
, b
, dest
);
3273 case bool_vector_exclusive_or
:
3274 for (; i
< nr_words
; i
++)
3275 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3279 case bool_vector_subsetp
:
3280 for (; i
< nr_words
; i
++)
3281 if (adata
[i
] &~ bdata
[i
])
3285 case bool_vector_union
:
3286 for (; i
< nr_words
; i
++)
3287 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3291 case bool_vector_intersection
:
3292 for (; i
< nr_words
; i
++)
3293 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3297 case bool_vector_set_difference
:
3298 for (; i
< nr_words
; i
++)
3299 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3310 case bool_vector_exclusive_or
:
3311 for (; i
< nr_words
; i
++)
3312 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3315 case bool_vector_union
:
3316 for (; i
< nr_words
; i
++)
3317 destdata
[i
] = adata
[i
] | bdata
[i
];
3320 case bool_vector_intersection
:
3321 for (; i
< nr_words
; i
++)
3322 destdata
[i
] = adata
[i
] & bdata
[i
];
3325 case bool_vector_set_difference
:
3326 for (; i
< nr_words
; i
++)
3327 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3337 /* PRECONDITION must be true. Return VALUE. This odd construction
3338 works around a bogus GCC diagnostic "shift count >= width of type". */
3341 pre_value (bool precondition
, int value
)
3343 eassume (precondition
);
3344 return precondition
? value
: 0;
3347 /* Compute the number of trailing zero bits in val. If val is zero,
3348 return the number of bits in val. */
3350 count_trailing_zero_bits (bits_word val
)
3352 if (BITS_WORD_MAX
== UINT_MAX
)
3353 return count_trailing_zeros (val
);
3354 if (BITS_WORD_MAX
== ULONG_MAX
)
3355 return count_trailing_zeros_l (val
);
3356 if (BITS_WORD_MAX
== ULL_MAX
)
3357 return count_trailing_zeros_ll (val
);
3359 /* The rest of this code is for the unlikely platform where bits_word differs
3360 in width from unsigned int, unsigned long, and unsigned long long. */
3361 val
|= ~ BITS_WORD_MAX
;
3362 if (BITS_WORD_MAX
<= UINT_MAX
)
3363 return count_trailing_zeros (val
);
3364 if (BITS_WORD_MAX
<= ULONG_MAX
)
3365 return count_trailing_zeros_l (val
);
3370 count
< BITS_PER_BITS_WORD
- ULL_WIDTH
;
3374 return count
+ count_trailing_zeros_ll (val
);
3375 val
= shift_right_ull (val
);
3378 if (BITS_PER_BITS_WORD
% ULL_WIDTH
!= 0
3379 && BITS_WORD_MAX
== (bits_word
) -1)
3380 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3381 BITS_PER_BITS_WORD
% ULL_WIDTH
);
3382 return count
+ count_trailing_zeros_ll (val
);
3387 bits_word_to_host_endian (bits_word val
)
3389 #ifndef WORDS_BIGENDIAN
3392 if (BITS_WORD_MAX
>> 31 == 1)
3393 return bswap_32 (val
);
3394 # if HAVE_UNSIGNED_LONG_LONG
3395 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3396 return bswap_64 (val
);
3401 for (i
= 0; i
< sizeof val
; i
++)
3403 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3404 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3405 val
= val
>> 1 >> (CHAR_BIT
- 1);
3412 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3413 Sbool_vector_exclusive_or
, 2, 3, 0,
3414 doc
: /* Return A ^ B, bitwise exclusive or.
3415 If optional third argument C is given, store result into C.
3416 A, B, and C must be bool vectors of the same length.
3417 Return the destination vector if it changed or nil otherwise. */)
3418 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3420 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3423 DEFUN ("bool-vector-union", Fbool_vector_union
,
3424 Sbool_vector_union
, 2, 3, 0,
3425 doc
: /* Return A | B, bitwise or.
3426 If optional third argument C is given, store result into C.
3427 A, B, and C must be bool vectors of the same length.
3428 Return the destination vector if it changed or nil otherwise. */)
3429 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3431 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3434 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3435 Sbool_vector_intersection
, 2, 3, 0,
3436 doc
: /* Return A & B, bitwise and.
3437 If optional third argument C is given, store result into C.
3438 A, B, and C must be bool vectors of the same length.
3439 Return the destination vector if it changed or nil otherwise. */)
3440 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3442 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3445 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3446 Sbool_vector_set_difference
, 2, 3, 0,
3447 doc
: /* Return A &~ B, set difference.
3448 If optional third argument C is given, store result into C.
3449 A, B, and C must be bool vectors of the same length.
3450 Return the destination vector if it changed or nil otherwise. */)
3451 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3453 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3456 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3457 Sbool_vector_subsetp
, 2, 2, 0,
3458 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3459 A and B must be bool vectors of the same length. */)
3460 (Lisp_Object a
, Lisp_Object b
)
3462 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3465 DEFUN ("bool-vector-not", Fbool_vector_not
,
3466 Sbool_vector_not
, 1, 2, 0,
3467 doc
: /* Compute ~A, set complement.
3468 If optional second argument B is given, store result into B.
3469 A and B must be bool vectors of the same length.
3470 Return the destination vector. */)
3471 (Lisp_Object a
, Lisp_Object b
)
3474 bits_word
*bdata
, *adata
;
3477 CHECK_BOOL_VECTOR (a
);
3478 nr_bits
= bool_vector_size (a
);
3481 b
= make_uninit_bool_vector (nr_bits
);
3484 CHECK_BOOL_VECTOR (b
);
3485 if (bool_vector_size (b
) != nr_bits
)
3486 wrong_length_argument (a
, b
, Qnil
);
3489 bdata
= bool_vector_data (b
);
3490 adata
= bool_vector_data (a
);
3492 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3493 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3495 if (nr_bits
% BITS_PER_BITS_WORD
)
3497 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3499 mword
&= bool_vector_spare_mask (nr_bits
);
3500 bdata
[i
] = bits_word_to_host_endian (mword
);
3506 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3507 Sbool_vector_count_population
, 1, 1, 0,
3508 doc
: /* Count how many elements in A are t.
3509 A is a bool vector. To count A's nil elements, subtract the return
3510 value from A's length. */)
3516 ptrdiff_t i
, nwords
;
3518 CHECK_BOOL_VECTOR (a
);
3520 nr_bits
= bool_vector_size (a
);
3521 nwords
= bool_vector_words (nr_bits
);
3523 adata
= bool_vector_data (a
);
3525 for (i
= 0; i
< nwords
; i
++)
3526 count
+= count_one_bits_word (adata
[i
]);
3528 return make_number (count
);
3531 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3532 Sbool_vector_count_consecutive
, 3, 3, 0,
3533 doc
: /* Count how many consecutive elements in A equal B starting at I.
3534 A is a bool vector, B is t or nil, and I is an index into A. */)
3535 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3542 bits_word mword
; /* Machine word. */
3543 ptrdiff_t pos
, pos0
;
3546 CHECK_BOOL_VECTOR (a
);
3549 nr_bits
= bool_vector_size (a
);
3550 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3551 args_out_of_range (a
, i
);
3553 adata
= bool_vector_data (a
);
3554 nr_words
= bool_vector_words (nr_bits
);
3555 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3556 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3559 /* By XORing with twiddle, we transform the problem of "count
3560 consecutive equal values" into "count the zero bits". The latter
3561 operation usually has hardware support. */
3562 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3564 /* Scan the remainder of the mword at the current offset. */
3565 if (pos
< nr_words
&& offset
!= 0)
3567 mword
= bits_word_to_host_endian (adata
[pos
]);
3571 /* Do not count the pad bits. */
3572 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3574 count
= count_trailing_zero_bits (mword
);
3576 if (count
+ offset
< BITS_PER_BITS_WORD
)
3577 return make_number (count
);
3580 /* Scan whole words until we either reach the end of the vector or
3581 find an mword that doesn't completely match. twiddle is
3582 endian-independent. */
3584 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3586 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3590 /* If we stopped because of a mismatch, see how many bits match
3591 in the current mword. */
3592 mword
= bits_word_to_host_endian (adata
[pos
]);
3594 count
+= count_trailing_zero_bits (mword
);
3596 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3598 /* If we hit the end, we might have overshot our count. Reduce
3599 the total by the number of spare bits at the end of the
3601 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3604 return make_number (count
);
3611 Lisp_Object error_tail
, arith_tail
;
3613 DEFSYM (Qquote
, "quote");
3614 DEFSYM (Qlambda
, "lambda");
3615 DEFSYM (Qerror_conditions
, "error-conditions");
3616 DEFSYM (Qerror_message
, "error-message");
3617 DEFSYM (Qtop_level
, "top-level");
3619 DEFSYM (Qerror
, "error");
3620 DEFSYM (Quser_error
, "user-error");
3621 DEFSYM (Qquit
, "quit");
3622 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3623 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3624 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3625 DEFSYM (Qvoid_function
, "void-function");
3626 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3627 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3628 DEFSYM (Qvoid_variable
, "void-variable");
3629 DEFSYM (Qsetting_constant
, "setting-constant");
3630 DEFSYM (Qtrapping_constant
, "trapping-constant");
3631 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3633 DEFSYM (Qinvalid_function
, "invalid-function");
3634 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3635 DEFSYM (Qno_catch
, "no-catch");
3636 DEFSYM (Qend_of_file
, "end-of-file");
3637 DEFSYM (Qarith_error
, "arith-error");
3638 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3639 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3640 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3641 DEFSYM (Qtext_read_only
, "text-read-only");
3642 DEFSYM (Qmark_inactive
, "mark-inactive");
3644 DEFSYM (Qlistp
, "listp");
3645 DEFSYM (Qconsp
, "consp");
3646 DEFSYM (Qsymbolp
, "symbolp");
3647 DEFSYM (Qintegerp
, "integerp");
3648 DEFSYM (Qnatnump
, "natnump");
3649 DEFSYM (Qwholenump
, "wholenump");
3650 DEFSYM (Qstringp
, "stringp");
3651 DEFSYM (Qarrayp
, "arrayp");
3652 DEFSYM (Qsequencep
, "sequencep");
3653 DEFSYM (Qbufferp
, "bufferp");
3654 DEFSYM (Qvectorp
, "vectorp");
3655 DEFSYM (Qrecordp
, "recordp");
3656 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3657 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3658 DEFSYM (Qmarkerp
, "markerp");
3660 DEFSYM (Quser_ptrp
, "user-ptrp");
3662 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3663 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3664 DEFSYM (Qfboundp
, "fboundp");
3666 DEFSYM (Qfloatp
, "floatp");
3667 DEFSYM (Qnumberp
, "numberp");
3668 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3670 DEFSYM (Qchar_table_p
, "char-table-p");
3671 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3673 DEFSYM (Qsubrp
, "subrp");
3674 DEFSYM (Qunevalled
, "unevalled");
3675 DEFSYM (Qmany
, "many");
3677 DEFSYM (Qcdr
, "cdr");
3679 error_tail
= pure_cons (Qerror
, Qnil
);
3681 /* ERROR is used as a signaler for random errors for which nothing else is
3684 Fput (Qerror
, Qerror_conditions
,
3686 Fput (Qerror
, Qerror_message
,
3687 build_pure_c_string ("error"));
3689 #define PUT_ERROR(sym, tail, msg) \
3690 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3691 Fput (sym, Qerror_message, build_pure_c_string (msg))
3693 PUT_ERROR (Qquit
, Qnil
, "Quit");
3695 PUT_ERROR (Quser_error
, error_tail
, "");
3696 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3697 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3698 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3699 PUT_ERROR (Qvoid_function
, error_tail
,
3700 "Symbol's function definition is void");
3701 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3702 "Symbol's chain of function indirections contains a loop");
3703 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3704 "Symbol's chain of variable indirections contains a loop");
3705 DEFSYM (Qcircular_list
, "circular-list");
3706 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3707 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3708 PUT_ERROR (Qsetting_constant
, error_tail
,
3709 "Attempt to set a constant symbol");
3710 PUT_ERROR (Qtrapping_constant
, error_tail
,
3711 "Attempt to trap writes to a constant symbol");
3712 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3713 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3714 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3715 "Wrong number of arguments");
3716 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3717 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3719 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3720 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3721 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3723 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3724 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3725 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3726 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3727 "Text is read-only");
3729 DEFSYM (Qrange_error
, "range-error");
3730 DEFSYM (Qdomain_error
, "domain-error");
3731 DEFSYM (Qsingularity_error
, "singularity-error");
3732 DEFSYM (Qoverflow_error
, "overflow-error");
3733 DEFSYM (Qunderflow_error
, "underflow-error");
3735 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3737 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3739 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3740 "Arithmetic singularity error");
3742 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3743 "Arithmetic overflow error");
3744 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3745 "Arithmetic underflow error");
3747 /* Types that type-of returns. */
3748 DEFSYM (Qinteger
, "integer");
3749 DEFSYM (Qsymbol
, "symbol");
3750 DEFSYM (Qstring
, "string");
3751 DEFSYM (Qcons
, "cons");
3752 DEFSYM (Qmarker
, "marker");
3753 DEFSYM (Qoverlay
, "overlay");
3754 DEFSYM (Qfinalizer
, "finalizer");
3756 DEFSYM (Qmodule_function
, "module-function");
3757 DEFSYM (Quser_ptr
, "user-ptr");
3759 DEFSYM (Qfloat
, "float");
3760 DEFSYM (Qwindow_configuration
, "window-configuration");
3761 DEFSYM (Qprocess
, "process");
3762 DEFSYM (Qwindow
, "window");
3763 DEFSYM (Qsubr
, "subr");
3764 DEFSYM (Qcompiled_function
, "compiled-function");
3765 DEFSYM (Qbuffer
, "buffer");
3766 DEFSYM (Qframe
, "frame");
3767 DEFSYM (Qvector
, "vector");
3768 DEFSYM (Qrecord
, "record");
3769 DEFSYM (Qchar_table
, "char-table");
3770 DEFSYM (Qbool_vector
, "bool-vector");
3771 DEFSYM (Qhash_table
, "hash-table");
3772 DEFSYM (Qthread
, "thread");
3773 DEFSYM (Qmutex
, "mutex");
3774 DEFSYM (Qcondition_variable
, "condition-variable");
3775 DEFSYM (Qfont_spec
, "font-spec");
3776 DEFSYM (Qfont_entity
, "font-entity");
3777 DEFSYM (Qfont_object
, "font-object");
3778 DEFSYM (Qterminal
, "terminal");
3780 DEFSYM (Qdefun
, "defun");
3782 DEFSYM (Qinteractive_form
, "interactive-form");
3783 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3785 defsubr (&Sindirect_variable
);
3786 defsubr (&Sinteractive_form
);
3789 defsubr (&Stype_of
);
3794 defsubr (&Sintegerp
);
3795 defsubr (&Sinteger_or_marker_p
);
3796 defsubr (&Snumberp
);
3797 defsubr (&Snumber_or_marker_p
);
3799 defsubr (&Snatnump
);
3800 defsubr (&Ssymbolp
);
3801 defsubr (&Skeywordp
);
3802 defsubr (&Sstringp
);
3803 defsubr (&Smultibyte_string_p
);
3804 defsubr (&Svectorp
);
3805 defsubr (&Srecordp
);
3806 defsubr (&Schar_table_p
);
3807 defsubr (&Svector_or_char_table_p
);
3808 defsubr (&Sbool_vector_p
);
3810 defsubr (&Ssequencep
);
3811 defsubr (&Sbufferp
);
3812 defsubr (&Smarkerp
);
3814 defsubr (&Sbyte_code_function_p
);
3815 defsubr (&Smodule_function_p
);
3816 defsubr (&Schar_or_string_p
);
3817 defsubr (&Sthreadp
);
3819 defsubr (&Scondition_variable_p
);
3822 defsubr (&Scar_safe
);
3823 defsubr (&Scdr_safe
);
3826 defsubr (&Ssymbol_function
);
3827 defsubr (&Sindirect_function
);
3828 defsubr (&Ssymbol_plist
);
3829 defsubr (&Ssymbol_name
);
3830 defsubr (&Smakunbound
);
3831 defsubr (&Sfmakunbound
);
3833 defsubr (&Sfboundp
);
3835 defsubr (&Sdefalias
);
3836 defsubr (&Ssetplist
);
3837 defsubr (&Ssymbol_value
);
3839 defsubr (&Sdefault_boundp
);
3840 defsubr (&Sdefault_value
);
3841 defsubr (&Sset_default
);
3842 defsubr (&Ssetq_default
);
3843 defsubr (&Smake_variable_buffer_local
);
3844 defsubr (&Smake_local_variable
);
3845 defsubr (&Skill_local_variable
);
3846 defsubr (&Slocal_variable_p
);
3847 defsubr (&Slocal_variable_if_set_p
);
3848 defsubr (&Svariable_binding_locus
);
3849 #if 0 /* XXX Remove this. --lorentey */
3850 defsubr (&Sterminal_local_value
);
3851 defsubr (&Sset_terminal_local_value
);
3855 defsubr (&Snumber_to_string
);
3856 defsubr (&Sstring_to_number
);
3857 defsubr (&Seqlsign
);
3874 defsubr (&Slogcount
);
3880 defsubr (&Sbyteorder
);
3881 defsubr (&Ssubr_arity
);
3882 defsubr (&Ssubr_name
);
3884 defsubr (&Suser_ptrp
);
3887 defsubr (&Sbool_vector_exclusive_or
);
3888 defsubr (&Sbool_vector_union
);
3889 defsubr (&Sbool_vector_intersection
);
3890 defsubr (&Sbool_vector_set_difference
);
3891 defsubr (&Sbool_vector_not
);
3892 defsubr (&Sbool_vector_subsetp
);
3893 defsubr (&Sbool_vector_count_consecutive
);
3894 defsubr (&Sbool_vector_count_population
);
3896 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->u
.s
.function
);
3898 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3899 doc
: /* The largest value that is representable in a Lisp integer.
3900 This variable cannot be set; trying to do so will signal an error. */);
3901 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3902 make_symbol_constant (intern_c_string ("most-positive-fixnum"));
3904 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3905 doc
: /* The smallest value that is representable in a Lisp integer.
3906 This variable cannot be set; trying to do so will signal an error. */);
3907 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3908 make_symbol_constant (intern_c_string ("most-negative-fixnum"));
3910 DEFSYM (Qwatchers
, "watchers");
3911 DEFSYM (Qmakunbound
, "makunbound");
3912 DEFSYM (Qunlet
, "unlet");
3913 DEFSYM (Qset
, "set");
3914 DEFSYM (Qset_default
, "set-default");
3915 defsubr (&Sadd_variable_watcher
);
3916 defsubr (&Sremove_variable_watcher
);
3917 defsubr (&Sget_variable_watchers
);