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
, false);
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
);
1260 case SYMBOL_FORWARDED
:
1261 return do_symval_forwarding (SYMBOL_FWD (sym
));
1262 default: emacs_abort ();
1266 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1267 doc
: /* Return SYMBOL's value. Error if that is void.
1268 Note that if `lexical-binding' is in effect, this returns the
1269 global value outside of any lexical scope. */)
1270 (Lisp_Object symbol
)
1274 val
= find_symbol_value (symbol
);
1275 if (!EQ (val
, Qunbound
))
1278 xsignal1 (Qvoid_variable
, symbol
);
1281 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1282 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1283 (register Lisp_Object symbol
, Lisp_Object newval
)
1285 set_internal (symbol
, newval
, Qnil
, SET_INTERNAL_SET
);
1289 /* Store the value NEWVAL into SYMBOL.
1290 If buffer-locality is an issue, WHERE specifies which context to use.
1291 (nil stands for the current buffer/frame).
1293 If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to
1294 become local in every buffer where it is set, then we make it
1295 local. If BINDFLAG is SET_INTERNAL_BIND or SET_INTERNAL_UNBIND, we
1299 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1300 enum Set_Internal_Bind bindflag
)
1302 bool voide
= EQ (newval
, Qunbound
);
1303 struct Lisp_Symbol
*sym
;
1306 /* If restoring in a dead buffer, do nothing. */
1307 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1310 CHECK_SYMBOL (symbol
);
1311 sym
= XSYMBOL (symbol
);
1312 switch (sym
->u
.s
.trapped_write
)
1314 case SYMBOL_NOWRITE
:
1315 if (NILP (Fkeywordp (symbol
))
1316 || !EQ (newval
, Fsymbol_value (symbol
)))
1317 xsignal1 (Qsetting_constant
, symbol
);
1319 /* Allow setting keywords to their own value. */
1322 case SYMBOL_TRAPPED_WRITE
:
1323 /* Setting due to thread-switching doesn't count. */
1324 if (bindflag
!= SET_INTERNAL_THREAD_SWITCH
)
1325 notify_variable_watchers (symbol
, voide
? Qnil
: newval
,
1326 (bindflag
== SET_INTERNAL_BIND
? Qlet
:
1327 bindflag
== SET_INTERNAL_UNBIND
? Qunlet
:
1328 voide
? Qmakunbound
: Qset
),
1331 case SYMBOL_UNTRAPPED_WRITE
:
1334 default: emacs_abort ();
1338 switch (sym
->u
.s
.redirect
)
1340 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1341 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1342 case SYMBOL_LOCALIZED
:
1344 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1346 XSETBUFFER (where
, current_buffer
);
1348 /* If the current buffer is not the buffer whose binding is
1349 loaded, or if it's a Lisp_Buffer_Local_Value and
1350 the default binding is loaded, the loaded binding may be the
1352 if (!EQ (blv
->where
, where
)
1353 /* Also unload a global binding (if the var is local_if_set). */
1354 || (EQ (blv
->valcell
, blv
->defcell
)))
1356 /* The currently loaded binding is not necessarily valid.
1357 We need to unload it, and choose a new binding. */
1359 /* Write out `realvalue' to the old loaded binding. */
1361 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1363 /* Find the new binding. */
1364 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1365 tem1
= assq_no_quit (symbol
,
1366 BVAR (XBUFFER (where
), local_var_alist
));
1367 set_blv_where (blv
, where
);
1372 /* This buffer still sees the default value. */
1374 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1375 or if this is `let' rather than `set',
1376 make CURRENT-ALIST-ELEMENT point to itself,
1377 indicating that we're seeing the default value.
1378 Likewise if the variable has been let-bound
1379 in the current buffer. */
1380 if (bindflag
|| !blv
->local_if_set
1381 || let_shadows_buffer_binding_p (sym
))
1384 tem1
= blv
->defcell
;
1386 /* If it's a local_if_set, being set not bound,
1387 and we're not within a let that was made for this buffer,
1388 create a new buffer-local binding for the variable.
1389 That means, give this buffer a new assoc for a local value
1390 and load that binding. */
1393 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1394 bset_local_var_alist
1396 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1400 /* Record which binding is now loaded. */
1401 set_blv_valcell (blv
, tem1
);
1404 /* Store the new value in the cons cell. */
1405 set_blv_value (blv
, newval
);
1410 /* If storing void (making the symbol void), forward only through
1411 buffer-local indicator, not through Lisp_Objfwd, etc. */
1414 store_symval_forwarding (blv
->fwd
, newval
,
1416 ? XBUFFER (where
) : current_buffer
);
1420 case SYMBOL_FORWARDED
:
1423 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1424 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1425 if (BUFFER_OBJFWDP (innercontents
))
1427 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1428 int idx
= PER_BUFFER_IDX (offset
);
1430 && bindflag
== SET_INTERNAL_SET
1431 && !let_shadows_buffer_binding_p (sym
))
1432 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1436 { /* If storing void (making the symbol void), forward only through
1437 buffer-local indicator, not through Lisp_Objfwd, etc. */
1438 sym
->u
.s
.redirect
= SYMBOL_PLAINVAL
;
1439 SET_SYMBOL_VAL (sym
, newval
);
1442 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1445 default: emacs_abort ();
1451 set_symbol_trapped_write (Lisp_Object symbol
, enum symbol_trapped_write trap
)
1453 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1454 if (sym
->u
.s
.trapped_write
== SYMBOL_NOWRITE
)
1455 xsignal1 (Qtrapping_constant
, symbol
);
1456 sym
->u
.s
.trapped_write
= trap
;
1460 restore_symbol_trapped_write (Lisp_Object symbol
)
1462 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1466 harmonize_variable_watchers (Lisp_Object alias
, Lisp_Object base_variable
)
1468 if (!EQ (base_variable
, alias
)
1469 && EQ (base_variable
, Findirect_variable (alias
)))
1470 set_symbol_trapped_write
1471 (alias
, XSYMBOL (base_variable
)->u
.s
.trapped_write
);
1474 DEFUN ("add-variable-watcher", Fadd_variable_watcher
, Sadd_variable_watcher
,
1476 doc
: /* Cause WATCH-FUNCTION to be called when SYMBOL is set.
1478 It will be called with 4 arguments: (SYMBOL NEWVAL OPERATION WHERE).
1479 SYMBOL is the variable being changed.
1480 NEWVAL is the value it will be changed to.
1481 OPERATION is a symbol representing the kind of change, one of: `set',
1482 `let', `unlet', `makunbound', and `defvaralias'.
1483 WHERE is a buffer if the buffer-local value of the variable is being
1484 changed, nil otherwise.
1486 All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */)
1487 (Lisp_Object symbol
, Lisp_Object watch_function
)
1489 symbol
= Findirect_variable (symbol
);
1490 set_symbol_trapped_write (symbol
, SYMBOL_TRAPPED_WRITE
);
1491 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1493 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1494 Lisp_Object member
= Fmember (watch_function
, watchers
);
1496 Fput (symbol
, Qwatchers
, Fcons (watch_function
, watchers
));
1500 DEFUN ("remove-variable-watcher", Fremove_variable_watcher
, Sremove_variable_watcher
,
1502 doc
: /* Undo the effect of `add-variable-watcher'.
1503 Remove WATCH-FUNCTION from the list of functions to be called when
1504 SYMBOL (or its aliases) are set. */)
1505 (Lisp_Object symbol
, Lisp_Object watch_function
)
1507 symbol
= Findirect_variable (symbol
);
1508 Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1509 watchers
= Fdelete (watch_function
, watchers
);
1510 if (NILP (watchers
))
1512 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1513 map_obarray (Vobarray
, harmonize_variable_watchers
, symbol
);
1515 Fput (symbol
, Qwatchers
, watchers
);
1519 DEFUN ("get-variable-watchers", Fget_variable_watchers
, Sget_variable_watchers
,
1521 doc
: /* Return a list of SYMBOL's active watchers. */)
1522 (Lisp_Object symbol
)
1524 return (SYMBOL_TRAPPED_WRITE_P (symbol
) == SYMBOL_TRAPPED_WRITE
)
1525 ? Fget (Findirect_variable (symbol
), Qwatchers
)
1530 notify_variable_watchers (Lisp_Object symbol
,
1532 Lisp_Object operation
,
1535 symbol
= Findirect_variable (symbol
);
1537 ptrdiff_t count
= SPECPDL_INDEX ();
1538 record_unwind_protect (restore_symbol_trapped_write
, symbol
);
1539 /* Avoid recursion. */
1540 set_symbol_trapped_write (symbol
, SYMBOL_UNTRAPPED_WRITE
);
1543 && !EQ (operation
, Qset_default
) && !EQ (operation
, Qmakunbound
)
1544 && !NILP (Flocal_variable_if_set_p (symbol
, Fcurrent_buffer ())))
1546 XSETBUFFER (where
, current_buffer
);
1549 if (EQ (operation
, Qset_default
))
1552 for (Lisp_Object watchers
= Fget (symbol
, Qwatchers
);
1554 watchers
= XCDR (watchers
))
1556 Lisp_Object watcher
= XCAR (watchers
);
1557 /* Call subr directly to avoid gc. */
1558 if (SUBRP (watcher
))
1560 Lisp_Object args
[] = { symbol
, newval
, operation
, where
};
1561 funcall_subr (XSUBR (watcher
), ARRAYELTS (args
), args
);
1564 CALLN (Ffuncall
, watcher
, symbol
, newval
, operation
, where
);
1567 unbind_to (count
, Qnil
);
1571 /* Access or set a buffer-local symbol's default value. */
1573 /* Return the default value of SYMBOL, but don't check for voidness.
1574 Return Qunbound if it is void. */
1577 default_value (Lisp_Object symbol
)
1579 struct Lisp_Symbol
*sym
;
1581 CHECK_SYMBOL (symbol
);
1582 sym
= XSYMBOL (symbol
);
1585 switch (sym
->u
.s
.redirect
)
1587 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1588 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1589 case SYMBOL_LOCALIZED
:
1591 /* If var is set up for a buffer that lacks a local value for it,
1592 the current value is nominally the default value.
1593 But the `realvalue' slot may be more up to date, since
1594 ordinary setq stores just that slot. So use that. */
1595 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1596 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1597 return do_symval_forwarding (blv
->fwd
);
1599 return XCDR (blv
->defcell
);
1601 case SYMBOL_FORWARDED
:
1603 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1605 /* For a built-in buffer-local variable, get the default value
1606 rather than letting do_symval_forwarding get the current value. */
1607 if (BUFFER_OBJFWDP (valcontents
))
1609 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1610 if (PER_BUFFER_IDX (offset
) != 0)
1611 return per_buffer_default (offset
);
1614 /* For other variables, get the current value. */
1615 return do_symval_forwarding (valcontents
);
1617 default: emacs_abort ();
1621 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1622 doc
: /* Return t if SYMBOL has a non-void default value.
1623 This is the value that is seen in buffers that do not have their own values
1624 for this variable. */)
1625 (Lisp_Object symbol
)
1627 register Lisp_Object value
;
1629 value
= default_value (symbol
);
1630 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1633 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1634 doc
: /* Return SYMBOL's default value.
1635 This is the value that is seen in buffers that do not have their own values
1636 for this variable. The default value is meaningful for variables with
1637 local bindings in certain buffers. */)
1638 (Lisp_Object symbol
)
1640 Lisp_Object value
= default_value (symbol
);
1641 if (!EQ (value
, Qunbound
))
1644 xsignal1 (Qvoid_variable
, symbol
);
1648 set_default_internal (Lisp_Object symbol
, Lisp_Object value
,
1649 enum Set_Internal_Bind bindflag
)
1651 struct Lisp_Symbol
*sym
;
1653 CHECK_SYMBOL (symbol
);
1654 sym
= XSYMBOL (symbol
);
1655 switch (sym
->u
.s
.trapped_write
)
1657 case SYMBOL_NOWRITE
:
1658 if (NILP (Fkeywordp (symbol
))
1659 || !EQ (value
, Fsymbol_value (symbol
)))
1660 xsignal1 (Qsetting_constant
, symbol
);
1662 /* Allow setting keywords to their own value. */
1665 case SYMBOL_TRAPPED_WRITE
:
1666 /* Don't notify here if we're going to call Fset anyway. */
1667 if (sym
->u
.s
.redirect
!= SYMBOL_PLAINVAL
1668 /* Setting due to thread switching doesn't count. */
1669 && bindflag
!= SET_INTERNAL_THREAD_SWITCH
)
1670 notify_variable_watchers (symbol
, value
, Qset_default
, Qnil
);
1672 case SYMBOL_UNTRAPPED_WRITE
:
1675 default: emacs_abort ();
1679 switch (sym
->u
.s
.redirect
)
1681 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1682 case SYMBOL_PLAINVAL
: set_internal (symbol
, value
, Qnil
, bindflag
); return;
1683 case SYMBOL_LOCALIZED
:
1685 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1687 /* Store new value into the DEFAULT-VALUE slot. */
1688 XSETCDR (blv
->defcell
, value
);
1690 /* If the default binding is now loaded, set the REALVALUE slot too. */
1691 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1692 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1695 case SYMBOL_FORWARDED
:
1697 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1699 /* Handle variables like case-fold-search that have special slots
1701 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1702 if (BUFFER_OBJFWDP (valcontents
))
1704 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1705 int idx
= PER_BUFFER_IDX (offset
);
1707 set_per_buffer_default (offset
, value
);
1709 /* If this variable is not always local in all buffers,
1710 set it in the buffers that don't nominally have a local value. */
1716 if (!PER_BUFFER_VALUE_P (b
, idx
))
1717 set_per_buffer_value (b
, offset
, value
);
1721 set_internal (symbol
, value
, Qnil
, bindflag
);
1724 default: emacs_abort ();
1728 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1729 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1730 The default value is seen in buffers that do not have their own values
1731 for this variable. */)
1732 (Lisp_Object symbol
, Lisp_Object value
)
1734 set_default_internal (symbol
, value
, SET_INTERNAL_SET
);
1738 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1739 doc
: /* Set the default value of variable VAR to VALUE.
1740 VAR, the variable name, is literal (not evaluated);
1741 VALUE is an expression: it is evaluated and its value returned.
1742 The default value of a variable is seen in buffers
1743 that do not have their own values for the variable.
1745 More generally, you can use multiple variables and values, as in
1746 (setq-default VAR VALUE VAR VALUE...)
1747 This sets each VAR's default value to the corresponding VALUE.
1748 The VALUE for the Nth VAR can refer to the new default values
1750 usage: (setq-default [VAR VALUE]...) */)
1753 Lisp_Object args_left
, symbol
, val
;
1755 args_left
= val
= args
;
1757 while (CONSP (args_left
))
1759 val
= eval_sub (Fcar (XCDR (args_left
)));
1760 symbol
= XCAR (args_left
);
1761 Fset_default (symbol
, val
);
1762 args_left
= Fcdr (XCDR (args_left
));
1768 /* Lisp functions for creating and removing buffer-local variables. */
1773 union Lisp_Fwd
*fwd
;
1776 static struct Lisp_Buffer_Local_Value
*
1777 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1778 union Lisp_Val_Fwd valcontents
)
1780 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1784 XSETSYMBOL (symbol
, sym
);
1785 tem
= Fcons (symbol
, (forwarded
1786 ? do_symval_forwarding (valcontents
.fwd
)
1787 : valcontents
.value
));
1789 /* Buffer_Local_Values cannot have as realval a buffer-local
1790 or keyboard-local forwarding. */
1791 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1792 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1793 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1794 set_blv_where (blv
, Qnil
);
1795 blv
->local_if_set
= 0;
1796 set_blv_defcell (blv
, tem
);
1797 set_blv_valcell (blv
, tem
);
1798 set_blv_found (blv
, false);
1802 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1803 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1804 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1805 At any time, the value for the current buffer is in effect,
1806 unless the variable has never been set in this buffer,
1807 in which case the default value is in effect.
1808 Note that binding the variable with `let', or setting it while
1809 a `let'-style binding made in this buffer is in effect,
1810 does not make the variable buffer-local. Return VARIABLE.
1812 This globally affects all uses of this variable, so it belongs together with
1813 the variable declaration, rather than with its uses (if you just want to make
1814 a variable local to the current buffer for one particular use, use
1815 `make-local-variable'). Buffer-local bindings are normally cleared
1816 while setting up a new major mode, unless they have a `permanent-local'
1819 The function `default-value' gets the default value and `set-default' sets it. */)
1820 (register Lisp_Object variable
)
1822 struct Lisp_Symbol
*sym
;
1823 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1824 union Lisp_Val_Fwd valcontents
;
1825 bool forwarded UNINIT
;
1827 CHECK_SYMBOL (variable
);
1828 sym
= XSYMBOL (variable
);
1831 switch (sym
->u
.s
.redirect
)
1833 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1834 case SYMBOL_PLAINVAL
:
1835 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1836 if (EQ (valcontents
.value
, Qunbound
))
1837 valcontents
.value
= Qnil
;
1839 case SYMBOL_LOCALIZED
:
1840 blv
= SYMBOL_BLV (sym
);
1842 case SYMBOL_FORWARDED
:
1843 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1844 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1845 error ("Symbol %s may not be buffer-local",
1846 SDATA (SYMBOL_NAME (variable
)));
1847 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1850 default: emacs_abort ();
1853 if (SYMBOL_CONSTANT_P (variable
))
1854 xsignal1 (Qsetting_constant
, variable
);
1858 blv
= make_blv (sym
, forwarded
, valcontents
);
1859 sym
->u
.s
.redirect
= SYMBOL_LOCALIZED
;
1860 SET_SYMBOL_BLV (sym
, blv
);
1863 blv
->local_if_set
= 1;
1867 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1868 1, 1, "vMake Local Variable: ",
1869 doc
: /* Make VARIABLE have a separate value in the current buffer.
1870 Other buffers will continue to share a common default value.
1871 \(The buffer-local value of VARIABLE starts out as the same value
1872 VARIABLE previously had. If VARIABLE was void, it remains void.)
1875 If the variable is already arranged to become local when set,
1876 this function causes a local value to exist for this buffer,
1877 just as setting the variable would do.
1879 This function returns VARIABLE, and therefore
1880 (set (make-local-variable \\='VARIABLE) VALUE-EXP)
1883 See also `make-variable-buffer-local'.
1885 Do not use `make-local-variable' to make a hook variable buffer-local.
1886 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1887 (Lisp_Object variable
)
1890 bool forwarded UNINIT
;
1891 union Lisp_Val_Fwd valcontents
;
1892 struct Lisp_Symbol
*sym
;
1893 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1895 CHECK_SYMBOL (variable
);
1896 sym
= XSYMBOL (variable
);
1899 switch (sym
->u
.s
.redirect
)
1901 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1902 case SYMBOL_PLAINVAL
:
1903 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1904 case SYMBOL_LOCALIZED
:
1905 blv
= SYMBOL_BLV (sym
);
1907 case SYMBOL_FORWARDED
:
1908 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1909 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1910 error ("Symbol %s may not be buffer-local",
1911 SDATA (SYMBOL_NAME (variable
)));
1913 default: emacs_abort ();
1916 if (sym
->u
.s
.trapped_write
== SYMBOL_NOWRITE
)
1917 xsignal1 (Qsetting_constant
, variable
);
1919 if (blv
? blv
->local_if_set
1920 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1922 tem
= Fboundp (variable
);
1923 /* Make sure the symbol has a local value in this particular buffer,
1924 by setting it to the same value it already has. */
1925 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1930 blv
= make_blv (sym
, forwarded
, valcontents
);
1931 sym
->u
.s
.redirect
= SYMBOL_LOCALIZED
;
1932 SET_SYMBOL_BLV (sym
, blv
);
1935 /* Make sure this buffer has its own value of symbol. */
1936 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1937 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1940 if (let_shadows_buffer_binding_p (sym
))
1942 AUTO_STRING (format
,
1943 "Making %s buffer-local while locally let-bound!");
1944 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1947 if (BUFFERP (blv
->where
) && current_buffer
== XBUFFER (blv
->where
))
1948 /* Make sure the current value is permanently recorded, if it's the
1950 swap_in_global_binding (sym
);
1952 bset_local_var_alist
1954 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1955 BVAR (current_buffer
, local_var_alist
)));
1961 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1962 1, 1, "vKill Local Variable: ",
1963 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1964 From now on the default value will apply in this buffer. Return VARIABLE. */)
1965 (register Lisp_Object variable
)
1967 register Lisp_Object tem
;
1968 struct Lisp_Buffer_Local_Value
*blv
;
1969 struct Lisp_Symbol
*sym
;
1971 CHECK_SYMBOL (variable
);
1972 sym
= XSYMBOL (variable
);
1975 switch (sym
->u
.s
.redirect
)
1977 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1978 case SYMBOL_PLAINVAL
: return variable
;
1979 case SYMBOL_FORWARDED
:
1981 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1982 if (BUFFER_OBJFWDP (valcontents
))
1984 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1985 int idx
= PER_BUFFER_IDX (offset
);
1989 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1990 set_per_buffer_value (current_buffer
, offset
,
1991 per_buffer_default (offset
));
1996 case SYMBOL_LOCALIZED
:
1997 blv
= SYMBOL_BLV (sym
);
1999 default: emacs_abort ();
2002 if (sym
->u
.s
.trapped_write
== SYMBOL_TRAPPED_WRITE
)
2003 notify_variable_watchers (variable
, Qnil
, Qmakunbound
, Fcurrent_buffer ());
2005 /* Get rid of this buffer's alist element, if any. */
2006 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
2007 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
2009 bset_local_var_alist
2011 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
2013 /* If the symbol is set up with the current buffer's binding
2014 loaded, recompute its value. We have to do it now, or else
2015 forwarded objects won't work right. */
2017 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
2018 if (EQ (buf
, blv
->where
))
2019 swap_in_global_binding (sym
);
2025 /* Lisp functions for creating and removing buffer-local variables. */
2027 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
2029 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
2030 BUFFER defaults to the current buffer. */)
2031 (Lisp_Object variable
, Lisp_Object buffer
)
2033 struct buffer
*buf
= decode_buffer (buffer
);
2034 struct Lisp_Symbol
*sym
;
2036 CHECK_SYMBOL (variable
);
2037 sym
= XSYMBOL (variable
);
2040 switch (sym
->u
.s
.redirect
)
2042 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2043 case SYMBOL_PLAINVAL
: return Qnil
;
2044 case SYMBOL_LOCALIZED
:
2046 Lisp_Object tail
, elt
, tmp
;
2047 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2048 XSETBUFFER (tmp
, buf
);
2049 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2051 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
2052 return blv_found (blv
) ? Qt
: Qnil
;
2054 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
2057 if (EQ (variable
, XCAR (elt
)))
2062 case SYMBOL_FORWARDED
:
2064 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2065 if (BUFFER_OBJFWDP (valcontents
))
2067 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2068 int idx
= PER_BUFFER_IDX (offset
);
2069 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2074 default: emacs_abort ();
2078 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2080 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
2081 BUFFER defaults to the current buffer.
2083 More precisely, return non-nil if either VARIABLE already has a local
2084 value in BUFFER, or if VARIABLE is automatically buffer-local (see
2085 `make-variable-buffer-local'). */)
2086 (register Lisp_Object variable
, Lisp_Object buffer
)
2088 struct Lisp_Symbol
*sym
;
2090 CHECK_SYMBOL (variable
);
2091 sym
= XSYMBOL (variable
);
2094 switch (sym
->u
.s
.redirect
)
2096 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2097 case SYMBOL_PLAINVAL
: return Qnil
;
2098 case SYMBOL_LOCALIZED
:
2100 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2101 if (blv
->local_if_set
)
2103 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2104 return Flocal_variable_p (variable
, buffer
);
2106 case SYMBOL_FORWARDED
:
2107 /* All BUFFER_OBJFWD slots become local if they are set. */
2108 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2109 default: emacs_abort ();
2113 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2115 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2116 If the current binding is buffer-local, the value is the current buffer.
2117 If the current binding is global (the default), the value is nil. */)
2118 (register Lisp_Object variable
)
2120 struct Lisp_Symbol
*sym
;
2122 CHECK_SYMBOL (variable
);
2123 sym
= XSYMBOL (variable
);
2125 /* Make sure the current binding is actually swapped in. */
2126 find_symbol_value (variable
);
2129 switch (sym
->u
.s
.redirect
)
2131 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2132 case SYMBOL_PLAINVAL
: return Qnil
;
2133 case SYMBOL_FORWARDED
:
2135 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2136 if (KBOARD_OBJFWDP (valcontents
))
2137 return Fframe_terminal (selected_frame
);
2138 else if (!BUFFER_OBJFWDP (valcontents
))
2142 case SYMBOL_LOCALIZED
:
2143 /* For a local variable, record both the symbol and which
2144 buffer's or frame's value we are saving. */
2145 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2146 return Fcurrent_buffer ();
2147 else if (sym
->u
.s
.redirect
== SYMBOL_LOCALIZED
2148 && blv_found (SYMBOL_BLV (sym
)))
2149 return SYMBOL_BLV (sym
)->where
;
2152 default: emacs_abort ();
2156 /* This code is disabled now that we use the selected frame to return
2157 keyboard-local-values. */
2159 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2161 DEFUN ("terminal-local-value", Fterminal_local_value
,
2162 Sterminal_local_value
, 2, 2, 0,
2163 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2164 If SYMBOL is not a terminal-local variable, then return its normal
2165 value, like `symbol-value'.
2167 TERMINAL may be a terminal object, a frame, or nil (meaning the
2168 selected frame's terminal device). */)
2169 (Lisp_Object symbol
, Lisp_Object terminal
)
2172 struct terminal
*t
= get_terminal (terminal
, 1);
2173 push_kboard (t
->kboard
);
2174 result
= Fsymbol_value (symbol
);
2179 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2180 Sset_terminal_local_value
, 3, 3, 0,
2181 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2182 If VARIABLE is not a terminal-local variable, then set its normal
2183 binding, like `set'.
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
, Lisp_Object value
)
2190 struct terminal
*t
= get_terminal (terminal
, 1);
2191 push_kboard (d
->kboard
);
2192 result
= Fset (symbol
, value
);
2198 /* Find the function at the end of a chain of symbol function indirections. */
2200 /* If OBJECT is a symbol, find the end of its function chain and
2201 return the value found there. If OBJECT is not a symbol, just
2202 return it. If there is a cycle in the function chain, signal a
2203 cyclic-function-indirection error.
2205 This is like Findirect_function, except that it doesn't signal an
2206 error if the chain ends up unbound. */
2208 indirect_function (register Lisp_Object object
)
2210 Lisp_Object tortoise
, hare
;
2212 hare
= tortoise
= object
;
2216 if (!SYMBOLP (hare
) || NILP (hare
))
2218 hare
= XSYMBOL (hare
)->u
.s
.function
;
2219 if (!SYMBOLP (hare
) || NILP (hare
))
2221 hare
= XSYMBOL (hare
)->u
.s
.function
;
2223 tortoise
= XSYMBOL (tortoise
)->u
.s
.function
;
2225 if (EQ (hare
, tortoise
))
2226 xsignal1 (Qcyclic_function_indirection
, object
);
2232 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2233 doc
: /* Return the function at the end of OBJECT's function chain.
2234 If OBJECT is not a symbol, just return it. Otherwise, follow all
2235 function indirections to find the final function binding and return it.
2236 Signal a cyclic-function-indirection error if there is a loop in the
2237 function chain of symbols. */)
2238 (register Lisp_Object object
, Lisp_Object noerror
)
2242 /* Optimize for no indirection. */
2244 if (SYMBOLP (result
) && !NILP (result
)
2245 && (result
= XSYMBOL (result
)->u
.s
.function
, SYMBOLP (result
)))
2246 result
= indirect_function (result
);
2253 /* Extract and set vector and string elements. */
2255 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2256 doc
: /* Return the element of ARRAY at index IDX.
2257 ARRAY may be a vector, a string, a char-table, a bool-vector, a record,
2258 or a byte-code object. IDX starts at 0. */)
2259 (register Lisp_Object array
, Lisp_Object idx
)
2261 register EMACS_INT idxval
;
2264 idxval
= XINT (idx
);
2265 if (STRINGP (array
))
2268 ptrdiff_t idxval_byte
;
2270 if (idxval
< 0 || idxval
>= SCHARS (array
))
2271 args_out_of_range (array
, idx
);
2272 if (! STRING_MULTIBYTE (array
))
2273 return make_number ((unsigned char) SREF (array
, idxval
));
2274 idxval_byte
= string_char_to_byte (array
, idxval
);
2276 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2277 return make_number (c
);
2279 else if (BOOL_VECTOR_P (array
))
2281 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2282 args_out_of_range (array
, idx
);
2283 return bool_vector_ref (array
, idxval
);
2285 else if (CHAR_TABLE_P (array
))
2287 CHECK_CHARACTER (idx
);
2288 return CHAR_TABLE_REF (array
, idxval
);
2293 if (VECTORP (array
))
2294 size
= ASIZE (array
);
2295 else if (COMPILEDP (array
) || RECORDP (array
))
2296 size
= PVSIZE (array
);
2298 wrong_type_argument (Qarrayp
, array
);
2300 if (idxval
< 0 || idxval
>= size
)
2301 args_out_of_range (array
, idx
);
2302 return AREF (array
, idxval
);
2306 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2307 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2308 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2309 bool-vector. IDX starts at 0. */)
2310 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2312 register EMACS_INT idxval
;
2315 idxval
= XINT (idx
);
2316 if (! RECORDP (array
))
2317 CHECK_ARRAY (array
, Qarrayp
);
2319 if (VECTORP (array
))
2321 CHECK_IMPURE (array
, XVECTOR (array
));
2322 if (idxval
< 0 || idxval
>= ASIZE (array
))
2323 args_out_of_range (array
, idx
);
2324 ASET (array
, idxval
, newelt
);
2326 else if (BOOL_VECTOR_P (array
))
2328 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2329 args_out_of_range (array
, idx
);
2330 bool_vector_set (array
, idxval
, !NILP (newelt
));
2332 else if (CHAR_TABLE_P (array
))
2334 CHECK_CHARACTER (idx
);
2335 CHAR_TABLE_SET (array
, idxval
, newelt
);
2337 else if (RECORDP (array
))
2339 if (idxval
< 0 || idxval
>= PVSIZE (array
))
2340 args_out_of_range (array
, idx
);
2341 ASET (array
, idxval
, newelt
);
2347 CHECK_IMPURE (array
, XSTRING (array
));
2348 if (idxval
< 0 || idxval
>= SCHARS (array
))
2349 args_out_of_range (array
, idx
);
2350 CHECK_CHARACTER (newelt
);
2351 c
= XFASTINT (newelt
);
2353 if (STRING_MULTIBYTE (array
))
2355 ptrdiff_t idxval_byte
, nbytes
;
2356 int prev_bytes
, new_bytes
;
2357 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2359 nbytes
= SBYTES (array
);
2360 idxval_byte
= string_char_to_byte (array
, idxval
);
2361 p1
= SDATA (array
) + idxval_byte
;
2362 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2363 new_bytes
= CHAR_STRING (c
, p0
);
2364 if (prev_bytes
!= new_bytes
)
2366 /* We must relocate the string data. */
2367 ptrdiff_t nchars
= SCHARS (array
);
2369 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2371 memcpy (str
, SDATA (array
), nbytes
);
2372 allocate_string_data (XSTRING (array
), nchars
,
2373 nbytes
+ new_bytes
- prev_bytes
);
2374 memcpy (SDATA (array
), str
, idxval_byte
);
2375 p1
= SDATA (array
) + idxval_byte
;
2376 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2377 nbytes
- (idxval_byte
+ prev_bytes
));
2379 clear_string_char_byte_cache ();
2386 if (! SINGLE_BYTE_CHAR_P (c
))
2390 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2391 if (SREF (array
, i
) >= 0x80)
2392 args_out_of_range (array
, newelt
);
2393 /* ARRAY is an ASCII string. Convert it to a multibyte
2394 string, and try `aset' again. */
2395 STRING_SET_MULTIBYTE (array
);
2396 return Faset (array
, idx
, newelt
);
2398 SSET (array
, idxval
, c
);
2405 /* Arithmetic functions */
2408 arithcompare (Lisp_Object num1
, Lisp_Object num2
,
2409 enum Arith_Comparison comparison
)
2416 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2417 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2419 /* If either arg is floating point, set F1 and F2 to the 'double'
2420 approximations of the two arguments, and set FNEQ if floating-point
2421 comparison reports that F1 is not equal to F2, possibly because F1
2422 or F2 is a NaN. Regardless, set I1 and I2 to integers that break
2423 ties if the floating-point comparison is either not done or reports
2428 f1
= XFLOAT_DATA (num1
);
2432 f2
= XFLOAT_DATA (num2
);
2436 /* Compare a float NUM1 to an integer NUM2 by converting the
2437 integer I2 (i.e., NUM2) to the double F2 (a conversion that
2438 can round on some platforms, if I2 is large enough), and then
2439 converting F2 back to the integer I1 (a conversion that is
2440 always exact), so that I1 exactly equals ((double) NUM2). If
2441 floating-point comparison reports a tie, NUM1 = F1 = F2 = I1
2442 (exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1
2443 to I2 will break the tie correctly. */
2444 i1
= f2
= i2
= XINT (num2
);
2453 /* Compare an integer NUM1 to a float NUM2. This is the
2454 converse of comparing float to integer (see above). */
2456 f2
= XFLOAT_DATA (num2
);
2469 test
= !fneq
&& i1
== i2
;
2472 case ARITH_NOTEQUAL
:
2473 test
= fneq
|| i1
!= i2
;
2477 test
= fneq
? f1
< f2
: i1
< i2
;
2480 case ARITH_LESS_OR_EQUAL
:
2481 test
= fneq
? f1
<= f2
: i1
<= i2
;
2485 test
= fneq
? f1
> f2
: i1
> i2
;
2488 case ARITH_GRTR_OR_EQUAL
:
2489 test
= fneq
? f1
>= f2
: i1
>= i2
;
2496 return test
? Qt
: Qnil
;
2500 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2501 enum Arith_Comparison comparison
)
2503 for (ptrdiff_t i
= 1; i
< nargs
; i
++)
2504 if (NILP (arithcompare (args
[i
- 1], args
[i
], comparison
)))
2509 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2510 doc
: /* Return t if args, all numbers or markers, are equal.
2511 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2512 (ptrdiff_t nargs
, Lisp_Object
*args
)
2514 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2517 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2518 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2519 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2520 (ptrdiff_t nargs
, Lisp_Object
*args
)
2522 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2525 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2526 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2527 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2528 (ptrdiff_t nargs
, Lisp_Object
*args
)
2530 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2533 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2534 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2535 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2536 (ptrdiff_t nargs
, Lisp_Object
*args
)
2538 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2541 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2542 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2543 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2544 (ptrdiff_t nargs
, Lisp_Object
*args
)
2546 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2549 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2550 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2551 (register Lisp_Object num1
, Lisp_Object num2
)
2553 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2556 /* Convert the integer I to a cons-of-integers, where I is not in
2559 #define INTBIG_TO_LISP(i, extremum) \
2560 (eassert (FIXNUM_OVERFLOW_P (i)), \
2561 (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \
2562 && FIXNUM_OVERFLOW_P ((i) >> 16)) \
2563 ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \
2564 : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \
2565 && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \
2566 ? Fcons (make_number ((i) >> 16 >> 24), \
2567 Fcons (make_number ((i) >> 16 & 0xffffff), \
2568 make_number ((i) & 0xffff))) \
2572 intbig_to_lisp (intmax_t i
)
2574 return INTBIG_TO_LISP (i
, INTMAX_MIN
);
2578 uintbig_to_lisp (uintmax_t i
)
2580 return INTBIG_TO_LISP (i
, UINTMAX_MAX
);
2583 /* Convert the cons-of-integers, integer, or float value C to an
2584 unsigned value with maximum value MAX, where MAX is one less than a
2585 power of 2. Signal an error if C does not have a valid format or
2588 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2591 uintmax_t val UNINIT
;
2594 valid
= XINT (c
) >= 0;
2597 else if (FLOATP (c
))
2599 double d
= XFLOAT_DATA (c
);
2600 if (d
>= 0 && d
< 1.0 + max
)
2606 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2608 uintmax_t top
= XFASTINT (XCAR (c
));
2609 Lisp_Object rest
= XCDR (c
);
2610 if (top
<= UINTMAX_MAX
>> 24 >> 16
2612 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2613 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2615 uintmax_t mid
= XFASTINT (XCAR (rest
));
2616 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2619 else if (top
<= UINTMAX_MAX
>> 16)
2623 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2625 val
= top
<< 16 | XFASTINT (rest
);
2631 if (! (valid
&& val
<= max
))
2632 error ("Not an in-range integer, integral float, or cons of integers");
2636 /* Convert the cons-of-integers, integer, or float value C to a signed
2637 value with extrema MIN and MAX. MAX should be one less than a
2638 power of 2, and MIN should be zero or the negative of a power of 2.
2639 Signal an error if C does not have a valid format or is out of
2642 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2645 intmax_t val UNINIT
;
2651 else if (FLOATP (c
))
2653 double d
= XFLOAT_DATA (c
);
2654 if (d
>= min
&& d
< 1.0 + max
)
2660 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2662 intmax_t top
= XINT (XCAR (c
));
2663 Lisp_Object rest
= XCDR (c
);
2664 if (top
>= INTMAX_MIN
>> 24 >> 16 && top
<= INTMAX_MAX
>> 24 >> 16
2666 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2667 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2669 intmax_t mid
= XFASTINT (XCAR (rest
));
2670 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2673 else if (top
>= INTMAX_MIN
>> 16 && top
<= INTMAX_MAX
>> 16)
2677 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2679 val
= top
<< 16 | XFASTINT (rest
);
2685 if (! (valid
&& min
<= val
&& val
<= max
))
2686 error ("Not an in-range integer, integral float, or cons of integers");
2690 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2691 doc
: /* Return the decimal representation of NUMBER as a string.
2692 Uses a minus sign if negative.
2693 NUMBER may be an integer or a floating point number. */)
2694 (Lisp_Object number
)
2696 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2699 CHECK_NUMBER_OR_FLOAT (number
);
2701 if (FLOATP (number
))
2702 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2704 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2706 return make_unibyte_string (buffer
, len
);
2709 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2710 doc
: /* Parse STRING as a decimal number and return the number.
2711 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2712 STRING cannot be parsed as an integer or floating point number.
2714 If BASE, interpret STRING as a number in that base. If BASE isn't
2715 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2716 If the base used is not 10, STRING is always parsed as an integer. */)
2717 (register Lisp_Object string
, Lisp_Object base
)
2721 CHECK_STRING (string
);
2727 CHECK_NUMBER (base
);
2728 if (! (XINT (base
) >= 2 && XINT (base
) <= 16))
2729 xsignal1 (Qargs_out_of_range
, base
);
2733 char *p
= SSDATA (string
);
2734 while (*p
== ' ' || *p
== '\t')
2737 int flags
= S2N_IGNORE_TRAILING
| S2N_OVERFLOW_TO_FLOAT
;
2738 Lisp_Object val
= string_to_number (p
, b
, flags
);
2739 return NILP (val
) ? make_number (0) : val
;
2753 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2754 ptrdiff_t, Lisp_Object
*);
2756 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2759 ptrdiff_t argnum
, ok_args
;
2760 EMACS_INT accum
= 0;
2761 EMACS_INT next
, ok_accum
;
2783 for (argnum
= 0; argnum
< nargs
; argnum
++)
2791 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2793 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2796 return float_arith_driver (ok_accum
, ok_args
, code
,
2799 next
= XINT (args
[argnum
]);
2803 overflow
|= INT_ADD_WRAPV (accum
, next
, &accum
);
2807 accum
= nargs
== 1 ? - next
: next
;
2809 overflow
|= INT_SUBTRACT_WRAPV (accum
, next
, &accum
);
2812 overflow
|= INT_MULTIPLY_WRAPV (accum
, next
, &accum
);
2815 if (! (argnum
|| nargs
== 1))
2820 xsignal0 (Qarith_error
);
2821 if (INT_DIVIDE_OVERFLOW (accum
, next
))
2839 XSETINT (val
, accum
);
2844 # define isnan(x) ((x) != (x))
2848 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2849 ptrdiff_t nargs
, Lisp_Object
*args
)
2851 register Lisp_Object val
;
2854 for (; argnum
< nargs
; argnum
++)
2856 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2857 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2861 next
= XFLOAT_DATA (val
);
2865 args
[argnum
] = val
; /* runs into a compiler bug. */
2866 next
= XINT (args
[argnum
]);
2874 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2880 if (! (argnum
|| nargs
== 1))
2884 if (! IEEE_FLOATING_POINT
&& next
== 0)
2885 xsignal0 (Qarith_error
);
2892 wrong_type_argument (Qinteger_or_marker_p
, val
);
2896 return make_float (accum
);
2900 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2901 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2902 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2903 (ptrdiff_t nargs
, Lisp_Object
*args
)
2905 return arith_driver (Aadd
, nargs
, args
);
2908 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2909 doc
: /* Negate number or subtract numbers or markers and return the result.
2910 With one arg, negates it. With more than one arg,
2911 subtracts all but the first from the first.
2912 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2913 (ptrdiff_t nargs
, Lisp_Object
*args
)
2915 return arith_driver (Asub
, nargs
, args
);
2918 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2919 doc
: /* Return product of any number of arguments, which are numbers or markers.
2920 usage: (* &rest NUMBERS-OR-MARKERS) */)
2921 (ptrdiff_t nargs
, Lisp_Object
*args
)
2923 return arith_driver (Amult
, nargs
, args
);
2926 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2927 doc
: /* Divide number by divisors and return the result.
2928 With two or more arguments, return first argument divided by the rest.
2929 With one argument, return 1 divided by the argument.
2930 The arguments must be numbers or markers.
2931 usage: (/ NUMBER &rest DIVISORS) */)
2932 (ptrdiff_t nargs
, Lisp_Object
*args
)
2935 for (argnum
= 2; argnum
< nargs
; argnum
++)
2936 if (FLOATP (args
[argnum
]))
2937 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2938 return arith_driver (Adiv
, nargs
, args
);
2941 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2942 doc
: /* Return remainder of X divided by Y.
2943 Both must be integers or markers. */)
2944 (register Lisp_Object x
, Lisp_Object y
)
2948 CHECK_NUMBER_COERCE_MARKER (x
);
2949 CHECK_NUMBER_COERCE_MARKER (y
);
2952 xsignal0 (Qarith_error
);
2954 XSETINT (val
, XINT (x
) % XINT (y
));
2958 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2959 doc
: /* Return X modulo Y.
2960 The result falls between zero (inclusive) and Y (exclusive).
2961 Both X and Y must be numbers or markers. */)
2962 (register Lisp_Object x
, Lisp_Object y
)
2967 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2968 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2970 if (FLOATP (x
) || FLOATP (y
))
2971 return fmod_float (x
, y
);
2977 xsignal0 (Qarith_error
);
2981 /* If the "remainder" comes out with the wrong sign, fix it. */
2982 if (i2
< 0 ? i1
> 0 : i1
< 0)
2990 minmax_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2991 enum Arith_Comparison comparison
)
2993 Lisp_Object accum
= args
[0];
2994 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (accum
);
2995 for (ptrdiff_t argnum
= 1; argnum
< nargs
; argnum
++)
2997 Lisp_Object val
= args
[argnum
];
2998 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2999 if (!NILP (arithcompare (val
, accum
, comparison
)))
3001 else if (FLOATP (val
) && isnan (XFLOAT_DATA (val
)))
3007 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
3008 doc
: /* Return largest of all the arguments (which must be numbers or markers).
3009 The value is always a number; markers are converted to numbers.
3010 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3011 (ptrdiff_t nargs
, Lisp_Object
*args
)
3013 return minmax_driver (nargs
, args
, ARITH_GRTR
);
3016 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
3017 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
3018 The value is always a number; markers are converted to numbers.
3019 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
3020 (ptrdiff_t nargs
, Lisp_Object
*args
)
3022 return minmax_driver (nargs
, args
, ARITH_LESS
);
3025 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
3026 doc
: /* Return bitwise-and of all the arguments.
3027 Arguments may be integers, or markers converted to integers.
3028 usage: (logand &rest INTS-OR-MARKERS) */)
3029 (ptrdiff_t nargs
, Lisp_Object
*args
)
3031 return arith_driver (Alogand
, nargs
, args
);
3034 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
3035 doc
: /* Return bitwise-or of all the arguments.
3036 Arguments may be integers, or markers converted to integers.
3037 usage: (logior &rest INTS-OR-MARKERS) */)
3038 (ptrdiff_t nargs
, Lisp_Object
*args
)
3040 return arith_driver (Alogior
, nargs
, args
);
3043 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
3044 doc
: /* Return bitwise-exclusive-or of all the arguments.
3045 Arguments may be integers, or markers converted to integers.
3046 usage: (logxor &rest INTS-OR-MARKERS) */)
3047 (ptrdiff_t nargs
, Lisp_Object
*args
)
3049 return arith_driver (Alogxor
, nargs
, args
);
3052 DEFUN ("logcount", Flogcount
, Slogcount
, 1, 1, 0,
3053 doc
: /* Return population count of VALUE.
3054 This is the number of one bits in the two's complement representation
3055 of VALUE. If VALUE is negative, return the number of zero bits in the
3059 CHECK_NUMBER (value
);
3060 EMACS_INT v
= XINT (value
) < 0 ? -1 - XINT (value
) : XINT (value
);
3061 return make_number (EMACS_UINT_WIDTH
<= UINT_WIDTH
3062 ? count_one_bits (v
)
3063 : EMACS_UINT_WIDTH
<= ULONG_WIDTH
3064 ? count_one_bits_l (v
)
3065 : count_one_bits_ll (v
));
3069 ash_lsh_impl (Lisp_Object value
, Lisp_Object count
, bool lsh
)
3071 /* This code assumes that signed right shifts are arithmetic. */
3072 verify ((EMACS_INT
) -1 >> 1 == -1);
3076 CHECK_NUMBER (value
);
3077 CHECK_NUMBER (count
);
3079 if (XINT (count
) >= EMACS_INT_WIDTH
)
3081 else if (XINT (count
) > 0)
3082 XSETINT (val
, XUINT (value
) << XINT (count
));
3083 else if (XINT (count
) <= -EMACS_INT_WIDTH
)
3084 XSETINT (val
, lsh
? 0 : XINT (value
) < 0 ? -1 : 0);
3086 XSETINT (val
, (lsh
? XUINT (value
) >> -XINT (count
)
3087 : XINT (value
) >> -XINT (count
)));
3091 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
3092 doc
: /* Return VALUE with its bits shifted left by COUNT.
3093 If COUNT is negative, shifting is actually to the right.
3094 In this case, the sign bit is duplicated. */)
3095 (register Lisp_Object value
, Lisp_Object count
)
3097 return ash_lsh_impl (value
, count
, false);
3100 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
3101 doc
: /* Return VALUE with its bits shifted left by COUNT.
3102 If COUNT is negative, shifting is actually to the right.
3103 In this case, zeros are shifted in on the left. */)
3104 (register Lisp_Object value
, Lisp_Object count
)
3106 return ash_lsh_impl (value
, count
, true);
3109 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3110 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3111 Markers are converted to integers. */)
3112 (register Lisp_Object number
)
3114 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3116 if (FLOATP (number
))
3117 return (make_float (1.0 + XFLOAT_DATA (number
)));
3119 XSETINT (number
, XINT (number
) + 1);
3123 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3124 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3125 Markers are converted to integers. */)
3126 (register Lisp_Object number
)
3128 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3130 if (FLOATP (number
))
3131 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3133 XSETINT (number
, XINT (number
) - 1);
3137 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3138 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3139 (register Lisp_Object number
)
3141 CHECK_NUMBER (number
);
3142 XSETINT (number
, ~XINT (number
));
3146 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3147 doc
: /* Return the byteorder for the machine.
3148 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3149 lowercase l) for small endian machines. */
3153 unsigned i
= 0x04030201;
3154 int order
= *(char *)&i
== 1 ? 108 : 66;
3156 return make_number (order
);
3159 /* Because we round up the bool vector allocate size to word_size
3160 units, we can safely read past the "end" of the vector in the
3161 operations below. These extra bits are always zero. */
3164 bool_vector_spare_mask (EMACS_INT nr_bits
)
3166 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
3169 /* Info about unsigned long long, falling back on unsigned long
3170 if unsigned long long is not available. */
3172 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH
3173 enum { ULL_WIDTH
= ULLONG_WIDTH
};
3174 # define ULL_MAX ULLONG_MAX
3176 enum { ULL_WIDTH
= ULONG_WIDTH
};
3177 # define ULL_MAX ULONG_MAX
3178 # define count_one_bits_ll count_one_bits_l
3179 # define count_trailing_zeros_ll count_trailing_zeros_l
3182 /* Shift VAL right by the width of an unsigned long long.
3183 ULL_WIDTH must be less than BITS_PER_BITS_WORD. */
3186 shift_right_ull (bits_word w
)
3188 /* Pacify bogus GCC warning about shift count exceeding type width. */
3189 int shift
= ULL_WIDTH
- BITS_PER_BITS_WORD
< 0 ? ULL_WIDTH
: 0;
3193 /* Return the number of 1 bits in W. */
3196 count_one_bits_word (bits_word w
)
3198 if (BITS_WORD_MAX
<= UINT_MAX
)
3199 return count_one_bits (w
);
3200 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3201 return count_one_bits_l (w
);
3204 int i
= 0, count
= 0;
3205 while (count
+= count_one_bits_ll (w
),
3206 (i
+= ULL_WIDTH
) < BITS_PER_BITS_WORD
)
3207 w
= shift_right_ull (w
);
3212 enum bool_vector_op
{ bool_vector_exclusive_or
,
3214 bool_vector_intersection
,
3215 bool_vector_set_difference
,
3216 bool_vector_subsetp
};
3219 bool_vector_binop_driver (Lisp_Object a
,
3222 enum bool_vector_op op
)
3225 bits_word
*adata
, *bdata
, *destdata
;
3229 CHECK_BOOL_VECTOR (a
);
3230 CHECK_BOOL_VECTOR (b
);
3232 nr_bits
= bool_vector_size (a
);
3233 if (bool_vector_size (b
) != nr_bits
)
3234 wrong_length_argument (a
, b
, dest
);
3236 nr_words
= bool_vector_words (nr_bits
);
3237 adata
= bool_vector_data (a
);
3238 bdata
= bool_vector_data (b
);
3242 dest
= make_uninit_bool_vector (nr_bits
);
3243 destdata
= bool_vector_data (dest
);
3247 CHECK_BOOL_VECTOR (dest
);
3248 destdata
= bool_vector_data (dest
);
3249 if (bool_vector_size (dest
) != nr_bits
)
3250 wrong_length_argument (a
, b
, dest
);
3254 case bool_vector_exclusive_or
:
3255 for (; i
< nr_words
; i
++)
3256 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3260 case bool_vector_subsetp
:
3261 for (; i
< nr_words
; i
++)
3262 if (adata
[i
] &~ bdata
[i
])
3266 case bool_vector_union
:
3267 for (; i
< nr_words
; i
++)
3268 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3272 case bool_vector_intersection
:
3273 for (; i
< nr_words
; i
++)
3274 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3278 case bool_vector_set_difference
:
3279 for (; i
< nr_words
; i
++)
3280 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3291 case bool_vector_exclusive_or
:
3292 for (; i
< nr_words
; i
++)
3293 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3296 case bool_vector_union
:
3297 for (; i
< nr_words
; i
++)
3298 destdata
[i
] = adata
[i
] | bdata
[i
];
3301 case bool_vector_intersection
:
3302 for (; i
< nr_words
; i
++)
3303 destdata
[i
] = adata
[i
] & bdata
[i
];
3306 case bool_vector_set_difference
:
3307 for (; i
< nr_words
; i
++)
3308 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3318 /* PRECONDITION must be true. Return VALUE. This odd construction
3319 works around a bogus GCC diagnostic "shift count >= width of type". */
3322 pre_value (bool precondition
, int value
)
3324 eassume (precondition
);
3325 return precondition
? value
: 0;
3328 /* Compute the number of trailing zero bits in val. If val is zero,
3329 return the number of bits in val. */
3331 count_trailing_zero_bits (bits_word val
)
3333 if (BITS_WORD_MAX
== UINT_MAX
)
3334 return count_trailing_zeros (val
);
3335 if (BITS_WORD_MAX
== ULONG_MAX
)
3336 return count_trailing_zeros_l (val
);
3337 if (BITS_WORD_MAX
== ULL_MAX
)
3338 return count_trailing_zeros_ll (val
);
3340 /* The rest of this code is for the unlikely platform where bits_word differs
3341 in width from unsigned int, unsigned long, and unsigned long long. */
3342 val
|= ~ BITS_WORD_MAX
;
3343 if (BITS_WORD_MAX
<= UINT_MAX
)
3344 return count_trailing_zeros (val
);
3345 if (BITS_WORD_MAX
<= ULONG_MAX
)
3346 return count_trailing_zeros_l (val
);
3351 count
< BITS_PER_BITS_WORD
- ULL_WIDTH
;
3355 return count
+ count_trailing_zeros_ll (val
);
3356 val
= shift_right_ull (val
);
3359 if (BITS_PER_BITS_WORD
% ULL_WIDTH
!= 0
3360 && BITS_WORD_MAX
== (bits_word
) -1)
3361 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3362 BITS_PER_BITS_WORD
% ULL_WIDTH
);
3363 return count
+ count_trailing_zeros_ll (val
);
3368 bits_word_to_host_endian (bits_word val
)
3370 #ifndef WORDS_BIGENDIAN
3373 if (BITS_WORD_MAX
>> 31 == 1)
3374 return bswap_32 (val
);
3375 # if HAVE_UNSIGNED_LONG_LONG
3376 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3377 return bswap_64 (val
);
3382 for (i
= 0; i
< sizeof val
; i
++)
3384 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3385 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3386 val
= val
>> 1 >> (CHAR_BIT
- 1);
3393 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3394 Sbool_vector_exclusive_or
, 2, 3, 0,
3395 doc
: /* Return A ^ B, bitwise exclusive or.
3396 If optional third argument C is given, store result into C.
3397 A, B, and C must be bool vectors of the same length.
3398 Return the destination vector if it changed or nil otherwise. */)
3399 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3401 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3404 DEFUN ("bool-vector-union", Fbool_vector_union
,
3405 Sbool_vector_union
, 2, 3, 0,
3406 doc
: /* Return A | B, bitwise or.
3407 If optional third argument C is given, store result into C.
3408 A, B, and C must be bool vectors of the same length.
3409 Return the destination vector if it changed or nil otherwise. */)
3410 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3412 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3415 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3416 Sbool_vector_intersection
, 2, 3, 0,
3417 doc
: /* Return A & B, bitwise and.
3418 If optional third argument C is given, store result into C.
3419 A, B, and C must be bool vectors of the same length.
3420 Return the destination vector if it changed or nil otherwise. */)
3421 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3423 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3426 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3427 Sbool_vector_set_difference
, 2, 3, 0,
3428 doc
: /* Return A &~ B, set difference.
3429 If optional third argument C is given, store result into C.
3430 A, B, and C must be bool vectors of the same length.
3431 Return the destination vector if it changed or nil otherwise. */)
3432 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3434 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3437 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3438 Sbool_vector_subsetp
, 2, 2, 0,
3439 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3440 A and B must be bool vectors of the same length. */)
3441 (Lisp_Object a
, Lisp_Object b
)
3443 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3446 DEFUN ("bool-vector-not", Fbool_vector_not
,
3447 Sbool_vector_not
, 1, 2, 0,
3448 doc
: /* Compute ~A, set complement.
3449 If optional second argument B is given, store result into B.
3450 A and B must be bool vectors of the same length.
3451 Return the destination vector. */)
3452 (Lisp_Object a
, Lisp_Object b
)
3455 bits_word
*bdata
, *adata
;
3458 CHECK_BOOL_VECTOR (a
);
3459 nr_bits
= bool_vector_size (a
);
3462 b
= make_uninit_bool_vector (nr_bits
);
3465 CHECK_BOOL_VECTOR (b
);
3466 if (bool_vector_size (b
) != nr_bits
)
3467 wrong_length_argument (a
, b
, Qnil
);
3470 bdata
= bool_vector_data (b
);
3471 adata
= bool_vector_data (a
);
3473 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3474 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3476 if (nr_bits
% BITS_PER_BITS_WORD
)
3478 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3480 mword
&= bool_vector_spare_mask (nr_bits
);
3481 bdata
[i
] = bits_word_to_host_endian (mword
);
3487 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3488 Sbool_vector_count_population
, 1, 1, 0,
3489 doc
: /* Count how many elements in A are t.
3490 A is a bool vector. To count A's nil elements, subtract the return
3491 value from A's length. */)
3497 ptrdiff_t i
, nwords
;
3499 CHECK_BOOL_VECTOR (a
);
3501 nr_bits
= bool_vector_size (a
);
3502 nwords
= bool_vector_words (nr_bits
);
3504 adata
= bool_vector_data (a
);
3506 for (i
= 0; i
< nwords
; i
++)
3507 count
+= count_one_bits_word (adata
[i
]);
3509 return make_number (count
);
3512 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3513 Sbool_vector_count_consecutive
, 3, 3, 0,
3514 doc
: /* Count how many consecutive elements in A equal B starting at I.
3515 A is a bool vector, B is t or nil, and I is an index into A. */)
3516 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3523 bits_word mword
; /* Machine word. */
3524 ptrdiff_t pos
, pos0
;
3527 CHECK_BOOL_VECTOR (a
);
3530 nr_bits
= bool_vector_size (a
);
3531 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3532 args_out_of_range (a
, i
);
3534 adata
= bool_vector_data (a
);
3535 nr_words
= bool_vector_words (nr_bits
);
3536 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3537 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3540 /* By XORing with twiddle, we transform the problem of "count
3541 consecutive equal values" into "count the zero bits". The latter
3542 operation usually has hardware support. */
3543 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3545 /* Scan the remainder of the mword at the current offset. */
3546 if (pos
< nr_words
&& offset
!= 0)
3548 mword
= bits_word_to_host_endian (adata
[pos
]);
3552 /* Do not count the pad bits. */
3553 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3555 count
= count_trailing_zero_bits (mword
);
3557 if (count
+ offset
< BITS_PER_BITS_WORD
)
3558 return make_number (count
);
3561 /* Scan whole words until we either reach the end of the vector or
3562 find an mword that doesn't completely match. twiddle is
3563 endian-independent. */
3565 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3567 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3571 /* If we stopped because of a mismatch, see how many bits match
3572 in the current mword. */
3573 mword
= bits_word_to_host_endian (adata
[pos
]);
3575 count
+= count_trailing_zero_bits (mword
);
3577 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3579 /* If we hit the end, we might have overshot our count. Reduce
3580 the total by the number of spare bits at the end of the
3582 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3585 return make_number (count
);
3592 Lisp_Object error_tail
, arith_tail
;
3594 DEFSYM (Qquote
, "quote");
3595 DEFSYM (Qlambda
, "lambda");
3596 DEFSYM (Qerror_conditions
, "error-conditions");
3597 DEFSYM (Qerror_message
, "error-message");
3598 DEFSYM (Qtop_level
, "top-level");
3600 DEFSYM (Qerror
, "error");
3601 DEFSYM (Quser_error
, "user-error");
3602 DEFSYM (Qquit
, "quit");
3603 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3604 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3605 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3606 DEFSYM (Qvoid_function
, "void-function");
3607 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3608 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3609 DEFSYM (Qvoid_variable
, "void-variable");
3610 DEFSYM (Qsetting_constant
, "setting-constant");
3611 DEFSYM (Qtrapping_constant
, "trapping-constant");
3612 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3614 DEFSYM (Qinvalid_function
, "invalid-function");
3615 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3616 DEFSYM (Qno_catch
, "no-catch");
3617 DEFSYM (Qend_of_file
, "end-of-file");
3618 DEFSYM (Qarith_error
, "arith-error");
3619 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3620 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3621 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3622 DEFSYM (Qtext_read_only
, "text-read-only");
3623 DEFSYM (Qmark_inactive
, "mark-inactive");
3625 DEFSYM (Qlistp
, "listp");
3626 DEFSYM (Qconsp
, "consp");
3627 DEFSYM (Qsymbolp
, "symbolp");
3628 DEFSYM (Qintegerp
, "integerp");
3629 DEFSYM (Qnatnump
, "natnump");
3630 DEFSYM (Qwholenump
, "wholenump");
3631 DEFSYM (Qstringp
, "stringp");
3632 DEFSYM (Qarrayp
, "arrayp");
3633 DEFSYM (Qsequencep
, "sequencep");
3634 DEFSYM (Qbufferp
, "bufferp");
3635 DEFSYM (Qvectorp
, "vectorp");
3636 DEFSYM (Qrecordp
, "recordp");
3637 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3638 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3639 DEFSYM (Qmarkerp
, "markerp");
3641 DEFSYM (Quser_ptrp
, "user-ptrp");
3643 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3644 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3645 DEFSYM (Qfboundp
, "fboundp");
3647 DEFSYM (Qfloatp
, "floatp");
3648 DEFSYM (Qnumberp
, "numberp");
3649 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3651 DEFSYM (Qchar_table_p
, "char-table-p");
3652 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3654 DEFSYM (Qsubrp
, "subrp");
3655 DEFSYM (Qunevalled
, "unevalled");
3656 DEFSYM (Qmany
, "many");
3658 DEFSYM (Qcdr
, "cdr");
3660 error_tail
= pure_cons (Qerror
, Qnil
);
3662 /* ERROR is used as a signaler for random errors for which nothing else is
3665 Fput (Qerror
, Qerror_conditions
,
3667 Fput (Qerror
, Qerror_message
,
3668 build_pure_c_string ("error"));
3670 #define PUT_ERROR(sym, tail, msg) \
3671 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3672 Fput (sym, Qerror_message, build_pure_c_string (msg))
3674 PUT_ERROR (Qquit
, Qnil
, "Quit");
3676 PUT_ERROR (Quser_error
, error_tail
, "");
3677 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3678 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3679 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3680 PUT_ERROR (Qvoid_function
, error_tail
,
3681 "Symbol's function definition is void");
3682 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3683 "Symbol's chain of function indirections contains a loop");
3684 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3685 "Symbol's chain of variable indirections contains a loop");
3686 DEFSYM (Qcircular_list
, "circular-list");
3687 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3688 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3689 PUT_ERROR (Qsetting_constant
, error_tail
,
3690 "Attempt to set a constant symbol");
3691 PUT_ERROR (Qtrapping_constant
, error_tail
,
3692 "Attempt to trap writes to a constant symbol");
3693 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3694 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3695 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3696 "Wrong number of arguments");
3697 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3698 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3700 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3701 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3702 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3704 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3705 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3706 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3707 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3708 "Text is read-only");
3710 DEFSYM (Qrange_error
, "range-error");
3711 DEFSYM (Qdomain_error
, "domain-error");
3712 DEFSYM (Qsingularity_error
, "singularity-error");
3713 DEFSYM (Qoverflow_error
, "overflow-error");
3714 DEFSYM (Qunderflow_error
, "underflow-error");
3716 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3718 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3720 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3721 "Arithmetic singularity error");
3723 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3724 "Arithmetic overflow error");
3725 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3726 "Arithmetic underflow error");
3728 /* Types that type-of returns. */
3729 DEFSYM (Qinteger
, "integer");
3730 DEFSYM (Qsymbol
, "symbol");
3731 DEFSYM (Qstring
, "string");
3732 DEFSYM (Qcons
, "cons");
3733 DEFSYM (Qmarker
, "marker");
3734 DEFSYM (Qoverlay
, "overlay");
3735 DEFSYM (Qfinalizer
, "finalizer");
3737 DEFSYM (Qmodule_function
, "module-function");
3738 DEFSYM (Quser_ptr
, "user-ptr");
3740 DEFSYM (Qfloat
, "float");
3741 DEFSYM (Qwindow_configuration
, "window-configuration");
3742 DEFSYM (Qprocess
, "process");
3743 DEFSYM (Qwindow
, "window");
3744 DEFSYM (Qsubr
, "subr");
3745 DEFSYM (Qcompiled_function
, "compiled-function");
3746 DEFSYM (Qbuffer
, "buffer");
3747 DEFSYM (Qframe
, "frame");
3748 DEFSYM (Qvector
, "vector");
3749 DEFSYM (Qrecord
, "record");
3750 DEFSYM (Qchar_table
, "char-table");
3751 DEFSYM (Qbool_vector
, "bool-vector");
3752 DEFSYM (Qhash_table
, "hash-table");
3753 DEFSYM (Qthread
, "thread");
3754 DEFSYM (Qmutex
, "mutex");
3755 DEFSYM (Qcondition_variable
, "condition-variable");
3756 DEFSYM (Qfont_spec
, "font-spec");
3757 DEFSYM (Qfont_entity
, "font-entity");
3758 DEFSYM (Qfont_object
, "font-object");
3759 DEFSYM (Qterminal
, "terminal");
3761 DEFSYM (Qdefun
, "defun");
3763 DEFSYM (Qinteractive_form
, "interactive-form");
3764 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3766 defsubr (&Sindirect_variable
);
3767 defsubr (&Sinteractive_form
);
3770 defsubr (&Stype_of
);
3775 defsubr (&Sintegerp
);
3776 defsubr (&Sinteger_or_marker_p
);
3777 defsubr (&Snumberp
);
3778 defsubr (&Snumber_or_marker_p
);
3780 defsubr (&Snatnump
);
3781 defsubr (&Ssymbolp
);
3782 defsubr (&Skeywordp
);
3783 defsubr (&Sstringp
);
3784 defsubr (&Smultibyte_string_p
);
3785 defsubr (&Svectorp
);
3786 defsubr (&Srecordp
);
3787 defsubr (&Schar_table_p
);
3788 defsubr (&Svector_or_char_table_p
);
3789 defsubr (&Sbool_vector_p
);
3791 defsubr (&Ssequencep
);
3792 defsubr (&Sbufferp
);
3793 defsubr (&Smarkerp
);
3795 defsubr (&Sbyte_code_function_p
);
3796 defsubr (&Smodule_function_p
);
3797 defsubr (&Schar_or_string_p
);
3798 defsubr (&Sthreadp
);
3800 defsubr (&Scondition_variable_p
);
3803 defsubr (&Scar_safe
);
3804 defsubr (&Scdr_safe
);
3807 defsubr (&Ssymbol_function
);
3808 defsubr (&Sindirect_function
);
3809 defsubr (&Ssymbol_plist
);
3810 defsubr (&Ssymbol_name
);
3811 defsubr (&Smakunbound
);
3812 defsubr (&Sfmakunbound
);
3814 defsubr (&Sfboundp
);
3816 defsubr (&Sdefalias
);
3817 defsubr (&Ssetplist
);
3818 defsubr (&Ssymbol_value
);
3820 defsubr (&Sdefault_boundp
);
3821 defsubr (&Sdefault_value
);
3822 defsubr (&Sset_default
);
3823 defsubr (&Ssetq_default
);
3824 defsubr (&Smake_variable_buffer_local
);
3825 defsubr (&Smake_local_variable
);
3826 defsubr (&Skill_local_variable
);
3827 defsubr (&Slocal_variable_p
);
3828 defsubr (&Slocal_variable_if_set_p
);
3829 defsubr (&Svariable_binding_locus
);
3830 #if 0 /* XXX Remove this. --lorentey */
3831 defsubr (&Sterminal_local_value
);
3832 defsubr (&Sset_terminal_local_value
);
3836 defsubr (&Snumber_to_string
);
3837 defsubr (&Sstring_to_number
);
3838 defsubr (&Seqlsign
);
3855 defsubr (&Slogcount
);
3861 defsubr (&Sbyteorder
);
3862 defsubr (&Ssubr_arity
);
3863 defsubr (&Ssubr_name
);
3865 defsubr (&Suser_ptrp
);
3868 defsubr (&Sbool_vector_exclusive_or
);
3869 defsubr (&Sbool_vector_union
);
3870 defsubr (&Sbool_vector_intersection
);
3871 defsubr (&Sbool_vector_set_difference
);
3872 defsubr (&Sbool_vector_not
);
3873 defsubr (&Sbool_vector_subsetp
);
3874 defsubr (&Sbool_vector_count_consecutive
);
3875 defsubr (&Sbool_vector_count_population
);
3877 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->u
.s
.function
);
3879 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3880 doc
: /* The largest value that is representable in a Lisp integer.
3881 This variable cannot be set; trying to do so will signal an error. */);
3882 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3883 make_symbol_constant (intern_c_string ("most-positive-fixnum"));
3885 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3886 doc
: /* The smallest value that is representable in a Lisp integer.
3887 This variable cannot be set; trying to do so will signal an error. */);
3888 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3889 make_symbol_constant (intern_c_string ("most-negative-fixnum"));
3891 DEFSYM (Qwatchers
, "watchers");
3892 DEFSYM (Qmakunbound
, "makunbound");
3893 DEFSYM (Qunlet
, "unlet");
3894 DEFSYM (Qset
, "set");
3895 DEFSYM (Qset_default
, "set-default");
3896 defsubr (&Sadd_variable_watcher
);
3897 defsubr (&Sremove_variable_watcher
);
3898 defsubr (&Sget_variable_watchers
);