1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include <count-one-bits.h>
26 #include <count-trailing-zeros.h>
31 #include "character.h"
35 #include "syssignal.h"
36 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
41 Lisp_Object Qnil_
, Qt_
;
42 static Lisp_Object Qsubr
;
43 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
44 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
45 static Lisp_Object Qwrong_length_argument
;
46 static Lisp_Object Qwrong_type_argument
;
47 Lisp_Object Qvoid_variable
, Qvoid_function
;
48 static Lisp_Object Qcyclic_function_indirection
;
49 static Lisp_Object Qcyclic_variable_indirection
;
50 Lisp_Object Qcircular_list
;
51 static Lisp_Object Qsetting_constant
;
52 Lisp_Object Qinvalid_read_syntax
;
53 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
54 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
55 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
56 Lisp_Object Qtext_read_only
;
58 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
59 static Lisp_Object Qnatnump
;
60 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
61 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
62 Lisp_Object Qbool_vector_p
;
63 Lisp_Object Qbuffer_or_string_p
;
64 static Lisp_Object Qkeywordp
, Qboundp
;
66 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
69 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
71 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
72 Lisp_Object Qrange_error
, Qoverflow_error
;
75 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
77 Lisp_Object Qinteger
, Qsymbol
;
78 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
80 static Lisp_Object Qoverlay
, Qwindow_configuration
;
81 static Lisp_Object Qprocess
, Qmarker
;
82 static Lisp_Object Qcompiled_function
, Qframe
;
84 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
85 static Lisp_Object Qsubrp
;
86 static Lisp_Object Qmany
, Qunevalled
;
87 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
88 static Lisp_Object Qdefun
;
90 Lisp_Object Qinteractive_form
;
91 static Lisp_Object Qdefalias_fset_function
;
93 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
96 BOOLFWDP (union Lisp_Fwd
*a
)
98 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
101 INTFWDP (union Lisp_Fwd
*a
)
103 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
106 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
108 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
111 OBJFWDP (union Lisp_Fwd
*a
)
113 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
116 static struct Lisp_Boolfwd
*
117 XBOOLFWD (union Lisp_Fwd
*a
)
119 eassert (BOOLFWDP (a
));
120 return &a
->u_boolfwd
;
122 static struct Lisp_Kboard_Objfwd
*
123 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
125 eassert (KBOARD_OBJFWDP (a
));
126 return &a
->u_kboard_objfwd
;
128 static struct Lisp_Intfwd
*
129 XINTFWD (union Lisp_Fwd
*a
)
131 eassert (INTFWDP (a
));
134 static struct Lisp_Objfwd
*
135 XOBJFWD (union Lisp_Fwd
*a
)
137 eassert (OBJFWDP (a
));
142 CHECK_SUBR (Lisp_Object x
)
144 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
148 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
150 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
155 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
157 return XCDR (blv
->valcell
);
161 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
163 XSETCDR (blv
->valcell
, val
);
167 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
173 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
179 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
184 static _Noreturn
void
185 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
187 Lisp_Object size1
= make_number (bool_vector_size (a1
));
188 Lisp_Object size2
= make_number (bool_vector_size (a2
));
190 xsignal2 (Qwrong_length_argument
, size1
, size2
);
192 xsignal3 (Qwrong_length_argument
, size1
, size2
,
193 make_number (bool_vector_size (a3
)));
197 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
199 /* If VALUE is not even a valid Lisp object, we'd want to abort here
200 where we can get a backtrace showing where it came from. We used
201 to try and do that by checking the tagbits, but nowadays all
202 tagbits are potentially valid. */
203 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
206 xsignal2 (Qwrong_type_argument
, predicate
, value
);
210 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
212 xsignal2 (Qargs_out_of_range
, a1
, a2
);
216 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
218 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
222 /* Data type predicates. */
224 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
225 doc
: /* Return t if the two args are the same Lisp object. */)
226 (Lisp_Object obj1
, Lisp_Object obj2
)
233 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
234 doc
: /* Return t if OBJECT is nil. */)
242 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
243 doc
: /* Return a symbol representing the type of OBJECT.
244 The symbol returned names the object's basic type;
245 for example, (type-of 1) returns `integer'. */)
248 if (INTEGERP (object
))
250 else if (SYMBOLP (object
))
252 else if (STRINGP (object
))
254 else if (CONSP (object
))
256 else if (MISCP (object
))
258 switch (XMISCTYPE (object
))
260 case Lisp_Misc_Marker
:
262 case Lisp_Misc_Overlay
:
264 case Lisp_Misc_Float
:
269 else if (VECTORLIKEP (object
))
271 if (WINDOW_CONFIGURATIONP (object
))
272 return Qwindow_configuration
;
273 if (PROCESSP (object
))
275 if (WINDOWP (object
))
279 if (COMPILEDP (object
))
280 return Qcompiled_function
;
281 if (BUFFERP (object
))
283 if (CHAR_TABLE_P (object
))
285 if (BOOL_VECTOR_P (object
))
289 if (HASH_TABLE_P (object
))
291 if (FONT_SPEC_P (object
))
293 if (FONT_ENTITY_P (object
))
295 if (FONT_OBJECT_P (object
))
299 else if (FLOATP (object
))
305 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
306 doc
: /* Return t if OBJECT is a cons cell. */)
314 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
315 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
323 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
324 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
325 Otherwise, return nil. */)
328 if (CONSP (object
) || NILP (object
))
333 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
337 if (CONSP (object
) || NILP (object
))
342 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
343 doc
: /* Return t if OBJECT is a symbol. */)
346 if (SYMBOLP (object
))
352 SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym
)
354 /* Should be initial_obarray */
355 Lisp_Object tem
= Ffind_symbol (SYMBOL_NAME (sym
), Vobarray
);
356 return (! NILP (scm_c_value_ref (tem
, 1))
357 && (EQ (sym
, scm_c_value_ref (tem
, 0))));
360 /* Define this in C to avoid unnecessarily consing up the symbol
362 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a keyword.
364 This means that it is a symbol with a print name beginning with `:'
365 interned in the initial obarray. */)
369 && SREF (SYMBOL_NAME (object
), 0) == ':'
370 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
375 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
376 doc
: /* Return t if OBJECT is a vector. */)
379 if (VECTORP (object
))
384 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
385 doc
: /* Return t if OBJECT is a string. */)
388 if (STRINGP (object
))
393 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
395 doc
: /* Return t if OBJECT is a multibyte string.
396 Return nil if OBJECT is either a unibyte string, or not a string. */)
399 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
404 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is a char-table. */)
408 if (CHAR_TABLE_P (object
))
413 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
414 Svector_or_char_table_p
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is a char-table or vector. */)
418 if (VECTORP (object
) || CHAR_TABLE_P (object
))
423 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
424 doc
: /* Return t if OBJECT is a bool-vector. */)
427 if (BOOL_VECTOR_P (object
))
432 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
433 doc
: /* Return t if OBJECT is an array (string or vector). */)
441 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
442 doc
: /* Return t if OBJECT is a sequence (list or array). */)
443 (register Lisp_Object object
)
445 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
450 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
451 doc
: /* Return t if OBJECT is an editor buffer. */)
454 if (BUFFERP (object
))
459 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
460 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
463 if (MARKERP (object
))
468 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is a built-in function. */)
477 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
479 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
482 if (COMPILEDP (object
))
487 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
488 doc
: /* Return t if OBJECT is a character or a string. */)
489 (register Lisp_Object object
)
491 if (CHARACTERP (object
) || STRINGP (object
))
496 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
497 doc
: /* Return t if OBJECT is an integer. */)
500 if (INTEGERP (object
))
505 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
506 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
507 (register Lisp_Object object
)
509 if (MARKERP (object
) || INTEGERP (object
))
514 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
515 doc
: /* Return t if OBJECT is a nonnegative integer. */)
518 if (NATNUMP (object
))
523 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
524 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
527 if (NUMBERP (object
))
533 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
534 Snumber_or_marker_p
, 1, 1, 0,
535 doc
: /* Return t if OBJECT is a number or a marker. */)
538 if (NUMBERP (object
) || MARKERP (object
))
543 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
544 doc
: /* Return t if OBJECT is a floating point number. */)
553 /* Extract and set components of lists. */
555 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
556 doc
: /* Return the car of LIST. If arg is nil, return nil.
557 Error if arg is not nil and not a cons cell. See also `car-safe'.
559 See Info node `(elisp)Cons Cells' for a discussion of related basic
560 Lisp concepts such as car, cdr, cons cell and list. */)
561 (register Lisp_Object list
)
566 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
567 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
570 return CAR_SAFE (object
);
573 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
574 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
575 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
577 See Info node `(elisp)Cons Cells' for a discussion of related basic
578 Lisp concepts such as cdr, car, cons cell and list. */)
579 (register Lisp_Object list
)
584 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
585 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
588 return CDR_SAFE (object
);
591 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
592 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
593 (register Lisp_Object cell
, Lisp_Object newcar
)
597 XSETCAR (cell
, newcar
);
601 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
602 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
603 (register Lisp_Object cell
, Lisp_Object newcdr
)
607 XSETCDR (cell
, newcdr
);
611 /* Extract and set components of symbols. */
613 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
614 doc
: /* Return t if SYMBOL's value is not void.
615 Note that if `lexical-binding' is in effect, this refers to the
616 global value outside of any lexical scope. */)
617 (register Lisp_Object symbol
)
619 Lisp_Object valcontents
;
620 struct Lisp_Symbol
*sym
;
621 CHECK_SYMBOL (symbol
);
622 sym
= XSYMBOL (symbol
);
625 switch (sym
->redirect
)
627 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
628 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
629 case SYMBOL_LOCALIZED
:
631 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
633 /* In set_internal, we un-forward vars when their value is
638 swap_in_symval_forwarding (sym
, blv
);
639 valcontents
= blv_value (blv
);
643 case SYMBOL_FORWARDED
:
644 /* In set_internal, we un-forward vars when their value is
647 default: emacs_abort ();
650 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
653 /* FIXME: Make it an alias for function-symbol! */
654 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
655 doc
: /* Return t if SYMBOL's function definition is not void. */)
656 (register Lisp_Object symbol
)
658 CHECK_SYMBOL (symbol
);
659 return NILP (SYMBOL_FUNCTION (symbol
)) ? Qnil
: Qt
;
662 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
663 doc
: /* Make SYMBOL's value be void.
665 (register Lisp_Object symbol
)
667 CHECK_SYMBOL (symbol
);
668 if (SYMBOL_CONSTANT_P (symbol
))
669 xsignal1 (Qsetting_constant
, symbol
);
670 Fset (symbol
, Qunbound
);
674 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
675 doc
: /* Make SYMBOL's function definition be nil.
677 (register Lisp_Object symbol
)
679 CHECK_SYMBOL (symbol
);
680 if (NILP (symbol
) || EQ (symbol
, Qt
))
681 xsignal1 (Qsetting_constant
, symbol
);
682 set_symbol_function (symbol
, Qnil
);
686 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
687 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
688 (register Lisp_Object symbol
)
690 CHECK_SYMBOL (symbol
);
691 return SYMBOL_FUNCTION (symbol
);
694 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
695 doc
: /* Return SYMBOL's property list. */)
696 (register Lisp_Object symbol
)
698 CHECK_SYMBOL (symbol
);
699 return symbol_plist (symbol
);
702 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
703 doc
: /* Return SYMBOL's name, a string. */)
704 (register Lisp_Object symbol
)
706 register Lisp_Object name
;
708 CHECK_SYMBOL (symbol
);
709 name
= SYMBOL_NAME (symbol
);
713 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
714 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
715 (register Lisp_Object symbol
, Lisp_Object definition
)
717 register Lisp_Object function
;
718 CHECK_SYMBOL (symbol
);
720 function
= SYMBOL_FUNCTION (symbol
);
722 if (!NILP (Vautoload_queue
) && !NILP (function
))
723 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
725 if (AUTOLOADP (function
))
726 Fput (symbol
, Qautoload
, XCDR (function
));
728 /* Convert to eassert or remove after GC bug is found. In the
729 meantime, check unconditionally, at a slight perf hit. */
730 if (valid_lisp_object_p (definition
) < 1)
733 set_symbol_function (symbol
, definition
);
738 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
739 doc
: /* Set SYMBOL's function definition to DEFINITION.
740 Associates the function with the current load file, if any.
741 The optional third argument DOCSTRING specifies the documentation string
742 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
743 determined by DEFINITION.
745 Internally, this normally uses `fset', but if SYMBOL has a
746 `defalias-fset-function' property, the associated value is used instead.
748 The return value is undefined. */)
749 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
751 CHECK_SYMBOL (symbol
);
752 if (!NILP (Vpurify_flag
)
753 /* If `definition' is a keymap, immutable (and copying) is wrong. */
754 && !KEYMAPP (definition
))
755 definition
= Fpurecopy (definition
);
758 bool autoload
= AUTOLOADP (definition
);
759 if (NILP (Vpurify_flag
) || !autoload
)
760 { /* Only add autoload entries after dumping, because the ones before are
761 not useful and else we get loads of them from the loaddefs.el. */
763 if (AUTOLOADP (SYMBOL_FUNCTION (symbol
)))
764 /* Remember that the function was already an autoload. */
765 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
766 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
770 { /* Handle automatic advice activation. */
771 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
773 call2 (hook
, symbol
, definition
);
775 Ffset (symbol
, definition
);
778 if (!NILP (docstring
))
779 Fput (symbol
, Qfunction_documentation
, docstring
);
780 /* We used to return `definition', but now that `defun' and `defmacro' expand
781 to a call to `defalias', we return `symbol' for backward compatibility
786 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
787 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
788 (register Lisp_Object symbol
, Lisp_Object newplist
)
790 CHECK_SYMBOL (symbol
);
791 set_symbol_plist (symbol
, newplist
);
795 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
796 doc
: /* Return minimum and maximum number of args allowed for SUBR.
797 SUBR must be a built-in function.
798 The returned value is a pair (MIN . MAX). MIN is the minimum number
799 of args. MAX is the maximum number or the symbol `many', for a
800 function with `&rest' args, or `unevalled' for a special form. */)
803 short minargs
, maxargs
;
805 minargs
= XSUBR (subr
)->min_args
;
806 maxargs
= XSUBR (subr
)->max_args
;
807 return Fcons (make_number (minargs
),
808 maxargs
== MANY
? Qmany
809 : maxargs
== UNEVALLED
? Qunevalled
810 : make_number (maxargs
));
813 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
814 doc
: /* Return name of subroutine SUBR.
815 SUBR must be a built-in function. */)
820 name
= XSUBR (subr
)->symbol_name
;
821 return build_string (name
);
824 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
825 doc
: /* Return the interactive form of CMD or nil if none.
826 If CMD is not a command, the return value is nil.
827 Value, if non-nil, is a list \(interactive SPEC). */)
830 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
835 /* Use an `interactive-form' property if present, analogous to the
836 function-documentation property. */
838 while (SYMBOLP (fun
))
840 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
844 fun
= Fsymbol_function (fun
);
849 const char *spec
= XSUBR (fun
)->intspec
;
851 return list2 (Qinteractive
,
852 (*spec
!= '(') ? build_string (spec
) :
853 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
855 else if (COMPILEDP (fun
))
857 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
858 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
860 else if (AUTOLOADP (fun
))
861 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
862 else if (CONSP (fun
))
864 Lisp_Object funcar
= XCAR (fun
);
865 if (EQ (funcar
, Qclosure
))
866 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
867 else if (EQ (funcar
, Qlambda
))
868 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
874 /***********************************************************************
875 Getting and Setting Values of Symbols
876 ***********************************************************************/
878 /* Return the symbol holding SYMBOL's value. Signal
879 `cyclic-variable-indirection' if SYMBOL's chain of variable
880 indirections contains a loop. */
883 indirect_variable (struct Lisp_Symbol
*symbol
)
885 struct Lisp_Symbol
*tortoise
, *hare
;
887 hare
= tortoise
= symbol
;
889 while (hare
->redirect
== SYMBOL_VARALIAS
)
891 hare
= SYMBOL_ALIAS (hare
);
892 if (hare
->redirect
!= SYMBOL_VARALIAS
)
895 hare
= SYMBOL_ALIAS (hare
);
896 tortoise
= SYMBOL_ALIAS (tortoise
);
898 if (hare
== tortoise
)
901 XSETSYMBOL (tem
, symbol
);
902 xsignal1 (Qcyclic_variable_indirection
, tem
);
910 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
911 doc
: /* Return the variable at the end of OBJECT's variable chain.
912 If OBJECT is a symbol, follow its variable indirections (if any), and
913 return the variable at the end of the chain of aliases. See Info node
914 `(elisp)Variable Aliases'.
916 If OBJECT is not a symbol, just return it. If there is a loop in the
917 chain of aliases, signal a `cyclic-variable-indirection' error. */)
920 if (SYMBOLP (object
))
922 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
923 XSETSYMBOL (object
, sym
);
929 /* Given the raw contents of a symbol value cell,
930 return the Lisp value of the symbol.
931 This does not handle buffer-local variables; use
932 swap_in_symval_forwarding for that. */
935 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
937 register Lisp_Object val
;
938 switch (XFWDTYPE (valcontents
))
941 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
945 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
948 return *XOBJFWD (valcontents
)->objvar
;
950 case Lisp_Fwd_Buffer_Obj
:
951 return per_buffer_value (current_buffer
,
952 XBUFFER_OBJFWD (valcontents
)->offset
);
954 case Lisp_Fwd_Kboard_Obj
:
955 /* We used to simply use current_kboard here, but from Lisp
956 code, its value is often unexpected. It seems nicer to
957 allow constructions like this to work as intuitively expected:
959 (with-selected-frame frame
960 (define-key local-function-map "\eOP" [f1]))
962 On the other hand, this affects the semantics of
963 last-command and real-last-command, and people may rely on
964 that. I took a quick look at the Lisp codebase, and I
965 don't think anything will break. --lorentey */
966 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
967 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
968 default: emacs_abort ();
972 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
973 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
974 buffer-independent contents of the value cell: forwarded just one
975 step past the buffer-localness.
977 BUF non-zero means set the value in buffer BUF instead of the
978 current buffer. This only plays a role for per-buffer variables. */
981 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
983 switch (XFWDTYPE (valcontents
))
986 CHECK_NUMBER (newval
);
987 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
991 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
995 *XOBJFWD (valcontents
)->objvar
= newval
;
997 /* If this variable is a default for something stored
998 in the buffer itself, such as default-fill-column,
999 find the buffers that don't have local values for it
1001 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1002 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1004 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1005 - (char *) &buffer_defaults
);
1006 int idx
= PER_BUFFER_IDX (offset
);
1008 Lisp_Object tail
, buf
;
1013 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1015 struct buffer
*b
= XBUFFER (buf
);
1017 if (! PER_BUFFER_VALUE_P (b
, idx
))
1018 set_per_buffer_value (b
, offset
, newval
);
1023 case Lisp_Fwd_Buffer_Obj
:
1025 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1026 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1028 if (!NILP (predicate
) && !NILP (newval
)
1029 && NILP (call1 (predicate
, newval
)))
1030 wrong_type_argument (predicate
, newval
);
1033 buf
= current_buffer
;
1034 set_per_buffer_value (buf
, offset
, newval
);
1038 case Lisp_Fwd_Kboard_Obj
:
1040 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1041 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1042 *(Lisp_Object
*) p
= newval
;
1047 emacs_abort (); /* goto def; */
1051 /* Set up SYMBOL to refer to its global binding. This makes it safe
1052 to alter the status of other bindings. BEWARE: this may be called
1053 during the mark phase of GC, where we assume that Lisp_Object slots
1054 of BLV are marked after this function has changed them. */
1057 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1059 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1061 /* Unload the previously loaded binding. */
1063 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1065 /* Select the global binding in the symbol. */
1066 set_blv_valcell (blv
, blv
->defcell
);
1068 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1070 /* Indicate that the global binding is set up now. */
1071 set_blv_where (blv
, Qnil
);
1072 set_blv_found (blv
, 0);
1075 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1076 VALCONTENTS is the contents of its value cell,
1077 which points to a struct Lisp_Buffer_Local_Value.
1079 Return the value forwarded one step past the buffer-local stage.
1080 This could be another forwarding pointer. */
1083 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1085 register Lisp_Object tem1
;
1087 eassert (blv
== SYMBOL_BLV (symbol
));
1092 || (blv
->frame_local
1093 ? !EQ (selected_frame
, tem1
)
1094 : current_buffer
!= XBUFFER (tem1
)))
1097 /* Unload the previously loaded binding. */
1098 tem1
= blv
->valcell
;
1100 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1101 /* Choose the new binding. */
1104 XSETSYMBOL (var
, symbol
);
1105 if (blv
->frame_local
)
1107 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1108 set_blv_where (blv
, selected_frame
);
1112 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1113 set_blv_where (blv
, Fcurrent_buffer ());
1116 if (!(blv
->found
= !NILP (tem1
)))
1117 tem1
= blv
->defcell
;
1119 /* Load the new binding. */
1120 set_blv_valcell (blv
, tem1
);
1122 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1126 /* Find the value of a symbol, returning Qunbound if it's not bound.
1127 This is helpful for code which just wants to get a variable's value
1128 if it has one, without signaling an error.
1129 Note that it must not be possible to quit
1130 within this function. Great care is required for this. */
1133 find_symbol_value (Lisp_Object symbol
)
1135 struct Lisp_Symbol
*sym
;
1137 CHECK_SYMBOL (symbol
);
1138 sym
= XSYMBOL (symbol
);
1141 switch (sym
->redirect
)
1143 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1144 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1145 case SYMBOL_LOCALIZED
:
1147 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1148 swap_in_symval_forwarding (sym
, blv
);
1149 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1152 case SYMBOL_FORWARDED
:
1153 return do_symval_forwarding (SYMBOL_FWD (sym
));
1154 default: emacs_abort ();
1158 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1159 doc
: /* Return SYMBOL's value. Error if that is void.
1160 Note that if `lexical-binding' is in effect, this returns the
1161 global value outside of any lexical scope. */)
1162 (Lisp_Object symbol
)
1166 val
= find_symbol_value (symbol
);
1167 if (!EQ (val
, Qunbound
))
1170 xsignal1 (Qvoid_variable
, symbol
);
1173 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1174 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1175 (register Lisp_Object symbol
, Lisp_Object newval
)
1177 set_internal (symbol
, newval
, Qnil
, 0);
1181 /* Store the value NEWVAL into SYMBOL.
1182 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1183 (nil stands for the current buffer/frame).
1185 If BINDFLAG is false, then if this symbol is supposed to become
1186 local in every buffer where it is set, then we make it local.
1187 If BINDFLAG is true, we don't do that. */
1190 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1193 bool voide
= EQ (newval
, Qunbound
);
1194 struct Lisp_Symbol
*sym
;
1197 /* If restoring in a dead buffer, do nothing. */
1198 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1201 CHECK_SYMBOL (symbol
);
1202 if (SYMBOL_CONSTANT_P (symbol
))
1204 if (NILP (Fkeywordp (symbol
))
1205 || !EQ (newval
, Fsymbol_value (symbol
)))
1206 xsignal1 (Qsetting_constant
, symbol
);
1208 /* Allow setting keywords to their own value. */
1212 sym
= XSYMBOL (symbol
);
1215 switch (sym
->redirect
)
1217 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1218 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1219 case SYMBOL_LOCALIZED
:
1221 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1224 if (blv
->frame_local
)
1225 where
= selected_frame
;
1227 XSETBUFFER (where
, current_buffer
);
1229 /* If the current buffer is not the buffer whose binding is
1230 loaded, or if there may be frame-local bindings and the frame
1231 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1232 the default binding is loaded, the loaded binding may be the
1234 if (!EQ (blv
->where
, where
)
1235 /* Also unload a global binding (if the var is local_if_set). */
1236 || (EQ (blv
->valcell
, blv
->defcell
)))
1238 /* The currently loaded binding is not necessarily valid.
1239 We need to unload it, and choose a new binding. */
1241 /* Write out `realvalue' to the old loaded binding. */
1243 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1245 /* Find the new binding. */
1246 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1247 tem1
= Fassq (symbol
,
1249 ? XFRAME (where
)->param_alist
1250 : BVAR (XBUFFER (where
), local_var_alist
)));
1251 set_blv_where (blv
, where
);
1256 /* This buffer still sees the default value. */
1258 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1259 or if this is `let' rather than `set',
1260 make CURRENT-ALIST-ELEMENT point to itself,
1261 indicating that we're seeing the default value.
1262 Likewise if the variable has been let-bound
1263 in the current buffer. */
1264 if (bindflag
|| !blv
->local_if_set
1265 || let_shadows_buffer_binding_p (sym
))
1268 tem1
= blv
->defcell
;
1270 /* If it's a local_if_set, being set not bound,
1271 and we're not within a let that was made for this buffer,
1272 create a new buffer-local binding for the variable.
1273 That means, give this buffer a new assoc for a local value
1274 and load that binding. */
1277 /* local_if_set is only supported for buffer-local
1278 bindings, not for frame-local bindings. */
1279 eassert (!blv
->frame_local
);
1280 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1281 bset_local_var_alist
1283 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1287 /* Record which binding is now loaded. */
1288 set_blv_valcell (blv
, tem1
);
1291 /* Store the new value in the cons cell. */
1292 set_blv_value (blv
, newval
);
1297 /* If storing void (making the symbol void), forward only through
1298 buffer-local indicator, not through Lisp_Objfwd, etc. */
1301 store_symval_forwarding (blv
->fwd
, newval
,
1303 ? XBUFFER (where
) : current_buffer
);
1307 case SYMBOL_FORWARDED
:
1310 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1311 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1312 if (BUFFER_OBJFWDP (innercontents
))
1314 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1315 int idx
= PER_BUFFER_IDX (offset
);
1318 && !let_shadows_buffer_binding_p (sym
))
1319 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1323 { /* If storing void (making the symbol void), forward only through
1324 buffer-local indicator, not through Lisp_Objfwd, etc. */
1325 sym
->redirect
= SYMBOL_PLAINVAL
;
1326 SET_SYMBOL_VAL (sym
, newval
);
1329 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1332 default: emacs_abort ();
1337 /* Access or set a buffer-local symbol's default value. */
1339 /* Return the default value of SYMBOL, but don't check for voidness.
1340 Return Qunbound if it is void. */
1343 default_value (Lisp_Object symbol
)
1345 struct Lisp_Symbol
*sym
;
1347 CHECK_SYMBOL (symbol
);
1348 sym
= XSYMBOL (symbol
);
1351 switch (sym
->redirect
)
1353 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1354 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1355 case SYMBOL_LOCALIZED
:
1357 /* If var is set up for a buffer that lacks a local value for it,
1358 the current value is nominally the default value.
1359 But the `realvalue' slot may be more up to date, since
1360 ordinary setq stores just that slot. So use that. */
1361 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1362 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1363 return do_symval_forwarding (blv
->fwd
);
1365 return XCDR (blv
->defcell
);
1367 case SYMBOL_FORWARDED
:
1369 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1371 /* For a built-in buffer-local variable, get the default value
1372 rather than letting do_symval_forwarding get the current value. */
1373 if (BUFFER_OBJFWDP (valcontents
))
1375 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1376 if (PER_BUFFER_IDX (offset
) != 0)
1377 return per_buffer_default (offset
);
1380 /* For other variables, get the current value. */
1381 return do_symval_forwarding (valcontents
);
1383 default: emacs_abort ();
1387 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1388 doc
: /* Return t if SYMBOL has a non-void default value.
1389 This is the value that is seen in buffers that do not have their own values
1390 for this variable. */)
1391 (Lisp_Object symbol
)
1393 register Lisp_Object value
;
1395 value
= default_value (symbol
);
1396 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1399 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1400 doc
: /* Return SYMBOL's default value.
1401 This is the value that is seen in buffers that do not have their own values
1402 for this variable. The default value is meaningful for variables with
1403 local bindings in certain buffers. */)
1404 (Lisp_Object symbol
)
1406 Lisp_Object value
= default_value (symbol
);
1407 if (!EQ (value
, Qunbound
))
1410 xsignal1 (Qvoid_variable
, symbol
);
1413 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1414 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1415 The default value is seen in buffers that do not have their own values
1416 for this variable. */)
1417 (Lisp_Object symbol
, Lisp_Object value
)
1419 struct Lisp_Symbol
*sym
;
1421 CHECK_SYMBOL (symbol
);
1422 if (SYMBOL_CONSTANT_P (symbol
))
1424 if (NILP (Fkeywordp (symbol
))
1425 || !EQ (value
, Fdefault_value (symbol
)))
1426 xsignal1 (Qsetting_constant
, symbol
);
1428 /* Allow setting keywords to their own value. */
1431 sym
= XSYMBOL (symbol
);
1434 switch (sym
->redirect
)
1436 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1437 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1438 case SYMBOL_LOCALIZED
:
1440 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1442 /* Store new value into the DEFAULT-VALUE slot. */
1443 XSETCDR (blv
->defcell
, value
);
1445 /* If the default binding is now loaded, set the REALVALUE slot too. */
1446 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1447 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1450 case SYMBOL_FORWARDED
:
1452 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1454 /* Handle variables like case-fold-search that have special slots
1456 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1457 if (BUFFER_OBJFWDP (valcontents
))
1459 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1460 int idx
= PER_BUFFER_IDX (offset
);
1462 set_per_buffer_default (offset
, value
);
1464 /* If this variable is not always local in all buffers,
1465 set it in the buffers that don't nominally have a local value. */
1471 if (!PER_BUFFER_VALUE_P (b
, idx
))
1472 set_per_buffer_value (b
, offset
, value
);
1477 return Fset (symbol
, value
);
1479 default: emacs_abort ();
1483 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1484 doc
: /* Set the default value of variable VAR to VALUE.
1485 VAR, the variable name, is literal (not evaluated);
1486 VALUE is an expression: it is evaluated and its value returned.
1487 The default value of a variable is seen in buffers
1488 that do not have their own values for the variable.
1490 More generally, you can use multiple variables and values, as in
1491 (setq-default VAR VALUE VAR VALUE...)
1492 This sets each VAR's default value to the corresponding VALUE.
1493 The VALUE for the Nth VAR can refer to the new default values
1495 usage: (setq-default [VAR VALUE]...) */)
1498 Lisp_Object args_left
, symbol
, val
;
1499 struct gcpro gcpro1
;
1501 args_left
= val
= args
;
1504 while (CONSP (args_left
))
1506 val
= eval_sub (Fcar (XCDR (args_left
)));
1507 symbol
= XCAR (args_left
);
1508 Fset_default (symbol
, val
);
1509 args_left
= Fcdr (XCDR (args_left
));
1516 /* Lisp functions for creating and removing buffer-local variables. */
1521 union Lisp_Fwd
*fwd
;
1524 static struct Lisp_Buffer_Local_Value
*
1525 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1526 union Lisp_Val_Fwd valcontents
)
1528 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1532 XSETSYMBOL (symbol
, sym
);
1533 tem
= Fcons (symbol
, (forwarded
1534 ? do_symval_forwarding (valcontents
.fwd
)
1535 : valcontents
.value
));
1537 /* Buffer_Local_Values cannot have as realval a buffer-local
1538 or keyboard-local forwarding. */
1539 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1540 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1541 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1542 set_blv_where (blv
, Qnil
);
1543 blv
->frame_local
= 0;
1544 blv
->local_if_set
= 0;
1545 set_blv_defcell (blv
, tem
);
1546 set_blv_valcell (blv
, tem
);
1547 set_blv_found (blv
, 0);
1551 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1552 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1553 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1554 At any time, the value for the current buffer is in effect,
1555 unless the variable has never been set in this buffer,
1556 in which case the default value is in effect.
1557 Note that binding the variable with `let', or setting it while
1558 a `let'-style binding made in this buffer is in effect,
1559 does not make the variable buffer-local. Return VARIABLE.
1561 This globally affects all uses of this variable, so it belongs together with
1562 the variable declaration, rather than with its uses (if you just want to make
1563 a variable local to the current buffer for one particular use, use
1564 `make-local-variable'). Buffer-local bindings are normally cleared
1565 while setting up a new major mode, unless they have a `permanent-local'
1568 The function `default-value' gets the default value and `set-default' sets it. */)
1569 (register Lisp_Object variable
)
1571 struct Lisp_Symbol
*sym
;
1572 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1573 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1574 bool forwarded
IF_LINT (= 0);
1576 CHECK_SYMBOL (variable
);
1577 sym
= XSYMBOL (variable
);
1580 switch (sym
->redirect
)
1582 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1583 case SYMBOL_PLAINVAL
:
1584 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1585 if (EQ (valcontents
.value
, Qunbound
))
1586 valcontents
.value
= Qnil
;
1588 case SYMBOL_LOCALIZED
:
1589 blv
= SYMBOL_BLV (sym
);
1590 if (blv
->frame_local
)
1591 error ("Symbol %s may not be buffer-local",
1592 SDATA (SYMBOL_NAME (variable
)));
1594 case SYMBOL_FORWARDED
:
1595 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1596 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1597 error ("Symbol %s may not be buffer-local",
1598 SDATA (SYMBOL_NAME (variable
)));
1599 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1602 default: emacs_abort ();
1606 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1610 blv
= make_blv (sym
, forwarded
, valcontents
);
1611 sym
->redirect
= SYMBOL_LOCALIZED
;
1612 SET_SYMBOL_BLV (sym
, blv
);
1615 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1616 if (let_shadows_global_binding_p (symbol
))
1617 message ("Making %s buffer-local while let-bound!",
1618 SDATA (SYMBOL_NAME (variable
)));
1622 blv
->local_if_set
= 1;
1626 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1627 1, 1, "vMake Local Variable: ",
1628 doc
: /* Make VARIABLE have a separate value in the current buffer.
1629 Other buffers will continue to share a common default value.
1630 \(The buffer-local value of VARIABLE starts out as the same value
1631 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1634 If the variable is already arranged to become local when set,
1635 this function causes a local value to exist for this buffer,
1636 just as setting the variable would do.
1638 This function returns VARIABLE, and therefore
1639 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1642 See also `make-variable-buffer-local'.
1644 Do not use `make-local-variable' to make a hook variable buffer-local.
1645 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1646 (Lisp_Object variable
)
1649 bool forwarded
IF_LINT (= 0);
1650 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1651 struct Lisp_Symbol
*sym
;
1652 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1654 CHECK_SYMBOL (variable
);
1655 sym
= XSYMBOL (variable
);
1658 switch (sym
->redirect
)
1660 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1661 case SYMBOL_PLAINVAL
:
1662 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1663 case SYMBOL_LOCALIZED
:
1664 blv
= SYMBOL_BLV (sym
);
1665 if (blv
->frame_local
)
1666 error ("Symbol %s may not be buffer-local",
1667 SDATA (SYMBOL_NAME (variable
)));
1669 case SYMBOL_FORWARDED
:
1670 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1671 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1672 error ("Symbol %s may not be buffer-local",
1673 SDATA (SYMBOL_NAME (variable
)));
1675 default: emacs_abort ();
1679 error ("Symbol %s may not be buffer-local",
1680 SDATA (SYMBOL_NAME (variable
)));
1682 if (blv
? blv
->local_if_set
1683 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1685 tem
= Fboundp (variable
);
1686 /* Make sure the symbol has a local value in this particular buffer,
1687 by setting it to the same value it already has. */
1688 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1693 blv
= make_blv (sym
, forwarded
, valcontents
);
1694 sym
->redirect
= SYMBOL_LOCALIZED
;
1695 SET_SYMBOL_BLV (sym
, blv
);
1698 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1699 if (let_shadows_global_binding_p (symbol
))
1700 message ("Making %s local to %s while let-bound!",
1701 SDATA (SYMBOL_NAME (variable
)),
1702 SDATA (BVAR (current_buffer
, name
)));
1706 /* Make sure this buffer has its own value of symbol. */
1707 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1708 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1711 if (let_shadows_buffer_binding_p (sym
))
1712 message ("Making %s buffer-local while locally let-bound!",
1713 SDATA (SYMBOL_NAME (variable
)));
1715 /* Swap out any local binding for some other buffer, and make
1716 sure the current value is permanently recorded, if it's the
1718 find_symbol_value (variable
);
1720 bset_local_var_alist
1722 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1723 BVAR (current_buffer
, local_var_alist
)));
1725 /* Make sure symbol does not think it is set up for this buffer;
1726 force it to look once again for this buffer's value. */
1727 if (current_buffer
== XBUFFER (blv
->where
))
1728 set_blv_where (blv
, Qnil
);
1729 set_blv_found (blv
, 0);
1732 /* If the symbol forwards into a C variable, then load the binding
1733 for this buffer now. If C code modifies the variable before we
1734 load the binding in, then that new value will clobber the default
1735 binding the next time we unload it. */
1737 swap_in_symval_forwarding (sym
, blv
);
1742 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1743 1, 1, "vKill Local Variable: ",
1744 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1745 From now on the default value will apply in this buffer. Return VARIABLE. */)
1746 (register Lisp_Object variable
)
1748 register Lisp_Object tem
;
1749 struct Lisp_Buffer_Local_Value
*blv
;
1750 struct Lisp_Symbol
*sym
;
1752 CHECK_SYMBOL (variable
);
1753 sym
= XSYMBOL (variable
);
1756 switch (sym
->redirect
)
1758 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1759 case SYMBOL_PLAINVAL
: return variable
;
1760 case SYMBOL_FORWARDED
:
1762 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1763 if (BUFFER_OBJFWDP (valcontents
))
1765 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1766 int idx
= PER_BUFFER_IDX (offset
);
1770 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1771 set_per_buffer_value (current_buffer
, offset
,
1772 per_buffer_default (offset
));
1777 case SYMBOL_LOCALIZED
:
1778 blv
= SYMBOL_BLV (sym
);
1779 if (blv
->frame_local
)
1782 default: emacs_abort ();
1785 /* Get rid of this buffer's alist element, if any. */
1786 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1787 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1789 bset_local_var_alist
1791 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1793 /* If the symbol is set up with the current buffer's binding
1794 loaded, recompute its value. We have to do it now, or else
1795 forwarded objects won't work right. */
1797 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1798 if (EQ (buf
, blv
->where
))
1800 set_blv_where (blv
, Qnil
);
1802 find_symbol_value (variable
);
1809 /* Lisp functions for creating and removing buffer-local variables. */
1811 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1812 when/if this is removed. */
1814 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1815 1, 1, "vMake Variable Frame Local: ",
1816 doc
: /* Enable VARIABLE to have frame-local bindings.
1817 This does not create any frame-local bindings for VARIABLE,
1818 it just makes them possible.
1820 A frame-local binding is actually a frame parameter value.
1821 If a frame F has a value for the frame parameter named VARIABLE,
1822 that also acts as a frame-local binding for VARIABLE in F--
1823 provided this function has been called to enable VARIABLE
1824 to have frame-local bindings at all.
1826 The only way to create a frame-local binding for VARIABLE in a frame
1827 is to set the VARIABLE frame parameter of that frame. See
1828 `modify-frame-parameters' for how to set frame parameters.
1830 Note that since Emacs 23.1, variables cannot be both buffer-local and
1831 frame-local any more (buffer-local bindings used to take precedence over
1832 frame-local bindings). */)
1833 (Lisp_Object variable
)
1836 union Lisp_Val_Fwd valcontents
;
1837 struct Lisp_Symbol
*sym
;
1838 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1840 CHECK_SYMBOL (variable
);
1841 sym
= XSYMBOL (variable
);
1844 switch (sym
->redirect
)
1846 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1847 case SYMBOL_PLAINVAL
:
1848 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1849 if (EQ (valcontents
.value
, Qunbound
))
1850 valcontents
.value
= Qnil
;
1852 case SYMBOL_LOCALIZED
:
1853 if (SYMBOL_BLV (sym
)->frame_local
)
1856 error ("Symbol %s may not be frame-local",
1857 SDATA (SYMBOL_NAME (variable
)));
1858 case SYMBOL_FORWARDED
:
1859 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1860 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1861 error ("Symbol %s may not be frame-local",
1862 SDATA (SYMBOL_NAME (variable
)));
1864 default: emacs_abort ();
1868 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1870 blv
= make_blv (sym
, forwarded
, valcontents
);
1871 blv
->frame_local
= 1;
1872 sym
->redirect
= SYMBOL_LOCALIZED
;
1873 SET_SYMBOL_BLV (sym
, blv
);
1876 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1877 if (let_shadows_global_binding_p (symbol
))
1878 message ("Making %s frame-local while let-bound!",
1879 SDATA (SYMBOL_NAME (variable
)));
1884 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1886 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1887 BUFFER defaults to the current buffer. */)
1888 (register Lisp_Object variable
, Lisp_Object buffer
)
1890 register struct buffer
*buf
;
1891 struct Lisp_Symbol
*sym
;
1894 buf
= current_buffer
;
1897 CHECK_BUFFER (buffer
);
1898 buf
= XBUFFER (buffer
);
1901 CHECK_SYMBOL (variable
);
1902 sym
= XSYMBOL (variable
);
1905 switch (sym
->redirect
)
1907 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1908 case SYMBOL_PLAINVAL
: return Qnil
;
1909 case SYMBOL_LOCALIZED
:
1911 Lisp_Object tail
, elt
, tmp
;
1912 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1913 XSETBUFFER (tmp
, buf
);
1914 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1916 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1917 return blv_found (blv
) ? Qt
: Qnil
;
1919 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1922 if (EQ (variable
, XCAR (elt
)))
1924 eassert (!blv
->frame_local
);
1930 case SYMBOL_FORWARDED
:
1932 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1933 if (BUFFER_OBJFWDP (valcontents
))
1935 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1936 int idx
= PER_BUFFER_IDX (offset
);
1937 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1942 default: emacs_abort ();
1946 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1948 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1949 BUFFER defaults to the current buffer.
1951 More precisely, return non-nil if either VARIABLE already has a local
1952 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1953 `make-variable-buffer-local'). */)
1954 (register Lisp_Object variable
, Lisp_Object buffer
)
1956 struct Lisp_Symbol
*sym
;
1958 CHECK_SYMBOL (variable
);
1959 sym
= XSYMBOL (variable
);
1962 switch (sym
->redirect
)
1964 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1965 case SYMBOL_PLAINVAL
: return Qnil
;
1966 case SYMBOL_LOCALIZED
:
1968 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1969 if (blv
->local_if_set
)
1971 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1972 return Flocal_variable_p (variable
, buffer
);
1974 case SYMBOL_FORWARDED
:
1975 /* All BUFFER_OBJFWD slots become local if they are set. */
1976 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1977 default: emacs_abort ();
1981 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1983 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1984 If the current binding is buffer-local, the value is the current buffer.
1985 If the current binding is frame-local, the value is the selected frame.
1986 If the current binding is global (the default), the value is nil. */)
1987 (register Lisp_Object variable
)
1989 struct Lisp_Symbol
*sym
;
1991 CHECK_SYMBOL (variable
);
1992 sym
= XSYMBOL (variable
);
1994 /* Make sure the current binding is actually swapped in. */
1995 find_symbol_value (variable
);
1998 switch (sym
->redirect
)
2000 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2001 case SYMBOL_PLAINVAL
: return Qnil
;
2002 case SYMBOL_FORWARDED
:
2004 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2005 if (KBOARD_OBJFWDP (valcontents
))
2006 return Fframe_terminal (selected_frame
);
2007 else if (!BUFFER_OBJFWDP (valcontents
))
2011 case SYMBOL_LOCALIZED
:
2012 /* For a local variable, record both the symbol and which
2013 buffer's or frame's value we are saving. */
2014 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2015 return Fcurrent_buffer ();
2016 else if (sym
->redirect
== SYMBOL_LOCALIZED
2017 && blv_found (SYMBOL_BLV (sym
)))
2018 return SYMBOL_BLV (sym
)->where
;
2021 default: emacs_abort ();
2025 /* This code is disabled now that we use the selected frame to return
2026 keyboard-local-values. */
2028 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2030 DEFUN ("terminal-local-value", Fterminal_local_value
,
2031 Sterminal_local_value
, 2, 2, 0,
2032 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2033 If SYMBOL is not a terminal-local variable, then return its normal
2034 value, like `symbol-value'.
2036 TERMINAL may be a terminal object, a frame, or nil (meaning the
2037 selected frame's terminal device). */)
2038 (Lisp_Object symbol
, Lisp_Object terminal
)
2041 struct terminal
*t
= get_terminal (terminal
, 1);
2042 push_kboard (t
->kboard
);
2043 result
= Fsymbol_value (symbol
);
2048 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2049 Sset_terminal_local_value
, 3, 3, 0,
2050 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2051 If VARIABLE is not a terminal-local variable, then set its normal
2052 binding, like `set'.
2054 TERMINAL may be a terminal object, a frame, or nil (meaning the
2055 selected frame's terminal device). */)
2056 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2059 struct terminal
*t
= get_terminal (terminal
, 1);
2060 push_kboard (d
->kboard
);
2061 result
= Fset (symbol
, value
);
2067 /* Find the function at the end of a chain of symbol function indirections. */
2069 /* If OBJECT is a symbol, find the end of its function chain and
2070 return the value found there. If OBJECT is not a symbol, just
2071 return it. If there is a cycle in the function chain, signal a
2072 cyclic-function-indirection error.
2074 This is like Findirect_function, except that it doesn't signal an
2075 error if the chain ends up unbound. */
2077 indirect_function (register Lisp_Object object
)
2079 Lisp_Object tortoise
, hare
;
2081 hare
= tortoise
= object
;
2085 if (!SYMBOLP (hare
) || NILP (hare
))
2087 hare
= SYMBOL_FUNCTION (hare
);
2088 if (!SYMBOLP (hare
) || NILP (hare
))
2090 hare
= SYMBOL_FUNCTION (hare
);
2092 tortoise
= SYMBOL_FUNCTION (tortoise
);
2094 if (EQ (hare
, tortoise
))
2095 xsignal1 (Qcyclic_function_indirection
, object
);
2101 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2102 doc
: /* Return the function at the end of OBJECT's function chain.
2103 If OBJECT is not a symbol, just return it. Otherwise, follow all
2104 function indirections to find the final function binding and return it.
2105 If the final symbol in the chain is unbound, signal a void-function error.
2106 Optional arg NOERROR non-nil means to return nil instead of signaling.
2107 Signal a cyclic-function-indirection error if there is a loop in the
2108 function chain of symbols. */)
2109 (register Lisp_Object object
, Lisp_Object noerror
)
2113 /* Optimize for no indirection. */
2115 if (SYMBOLP (result
) && !NILP (result
)
2116 && (result
= SYMBOL_FUNCTION (result
), SYMBOLP (result
)))
2117 result
= indirect_function (result
);
2122 xsignal1 (Qvoid_function
, object
);
2127 /* Extract and set vector and string elements. */
2129 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2130 doc
: /* Return the element of ARRAY at index IDX.
2131 ARRAY may be a vector, a string, a char-table, a bool-vector,
2132 or a byte-code object. IDX starts at 0. */)
2133 (register Lisp_Object array
, Lisp_Object idx
)
2135 register EMACS_INT idxval
;
2138 idxval
= XINT (idx
);
2139 if (STRINGP (array
))
2142 ptrdiff_t idxval_byte
;
2144 if (idxval
< 0 || idxval
>= SCHARS (array
))
2145 args_out_of_range (array
, idx
);
2146 if (! STRING_MULTIBYTE (array
))
2147 return make_number ((unsigned char) SREF (array
, idxval
));
2148 idxval_byte
= string_char_to_byte (array
, idxval
);
2150 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2151 return make_number (c
);
2153 else if (BOOL_VECTOR_P (array
))
2155 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2156 args_out_of_range (array
, idx
);
2157 return bool_vector_ref (array
, idxval
);
2159 else if (CHAR_TABLE_P (array
))
2161 CHECK_CHARACTER (idx
);
2162 return CHAR_TABLE_REF (array
, idxval
);
2167 if (VECTORP (array
))
2168 size
= ASIZE (array
);
2169 else if (COMPILEDP (array
))
2170 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2172 wrong_type_argument (Qarrayp
, array
);
2174 if (idxval
< 0 || idxval
>= size
)
2175 args_out_of_range (array
, idx
);
2176 return AREF (array
, idxval
);
2180 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2181 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2182 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2183 bool-vector. IDX starts at 0. */)
2184 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2186 register EMACS_INT idxval
;
2189 idxval
= XINT (idx
);
2190 CHECK_ARRAY (array
, Qarrayp
);
2191 CHECK_IMPURE (array
);
2193 if (VECTORP (array
))
2195 if (idxval
< 0 || idxval
>= ASIZE (array
))
2196 args_out_of_range (array
, idx
);
2197 ASET (array
, idxval
, newelt
);
2199 else if (BOOL_VECTOR_P (array
))
2201 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2202 args_out_of_range (array
, idx
);
2203 bool_vector_set (array
, idxval
, !NILP (newelt
));
2205 else if (CHAR_TABLE_P (array
))
2207 CHECK_CHARACTER (idx
);
2208 CHAR_TABLE_SET (array
, idxval
, newelt
);
2214 if (idxval
< 0 || idxval
>= SCHARS (array
))
2215 args_out_of_range (array
, idx
);
2216 CHECK_CHARACTER (newelt
);
2217 c
= XFASTINT (newelt
);
2219 if (STRING_MULTIBYTE (array
))
2221 ptrdiff_t idxval_byte
, nbytes
;
2222 int prev_bytes
, new_bytes
;
2223 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2225 nbytes
= SBYTES (array
);
2226 idxval_byte
= string_char_to_byte (array
, idxval
);
2227 p1
= SDATA (array
) + idxval_byte
;
2228 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2229 new_bytes
= CHAR_STRING (c
, p0
);
2230 if (prev_bytes
!= new_bytes
)
2232 /* We must relocate the string data. */
2233 ptrdiff_t nchars
= SCHARS (array
);
2235 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2237 memcpy (str
, SDATA (array
), nbytes
);
2238 allocate_string_data (XSTRING (array
), nchars
,
2239 nbytes
+ new_bytes
- prev_bytes
);
2240 memcpy (SDATA (array
), str
, idxval_byte
);
2241 p1
= SDATA (array
) + idxval_byte
;
2242 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2243 nbytes
- (idxval_byte
+ prev_bytes
));
2245 clear_string_char_byte_cache ();
2252 if (! SINGLE_BYTE_CHAR_P (c
))
2256 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2257 if (SREF (array
, i
) >= 0x80)
2258 args_out_of_range (array
, newelt
);
2259 /* ARRAY is an ASCII string. Convert it to a multibyte
2260 string, and try `aset' again. */
2261 STRING_SET_MULTIBYTE (array
);
2262 return Faset (array
, idx
, newelt
);
2264 SSET (array
, idxval
, c
);
2271 /* Arithmetic functions */
2274 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2276 double f1
= 0, f2
= 0;
2279 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2280 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2282 if (FLOATP (num1
) || FLOATP (num2
))
2285 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2286 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2292 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2296 case ARITH_NOTEQUAL
:
2297 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2302 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2306 case ARITH_LESS_OR_EQUAL
:
2307 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2312 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2316 case ARITH_GRTR_OR_EQUAL
:
2317 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2327 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2328 enum Arith_Comparison comparison
)
2331 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2333 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2339 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2340 doc
: /* Return t if args, all numbers or markers, are equal.
2341 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2342 (ptrdiff_t nargs
, Lisp_Object
*args
)
2344 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2347 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2348 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2349 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2350 (ptrdiff_t nargs
, Lisp_Object
*args
)
2352 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2355 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2356 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2357 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2358 (ptrdiff_t nargs
, Lisp_Object
*args
)
2360 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2363 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2364 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2365 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2366 (ptrdiff_t nargs
, Lisp_Object
*args
)
2368 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2371 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2372 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2373 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2374 (ptrdiff_t nargs
, Lisp_Object
*args
)
2376 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2379 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2380 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2381 (register Lisp_Object num1
, Lisp_Object num2
)
2383 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2386 /* Convert the cons-of-integers, integer, or float value C to an
2387 unsigned value with maximum value MAX. Signal an error if C does not
2388 have a valid format or is out of range. */
2390 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2393 uintmax_t val
IF_LINT (= 0);
2396 valid
= 0 <= XINT (c
);
2399 else if (FLOATP (c
))
2401 double d
= XFLOAT_DATA (c
);
2403 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2409 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2411 uintmax_t top
= XFASTINT (XCAR (c
));
2412 Lisp_Object rest
= XCDR (c
);
2413 if (top
<= UINTMAX_MAX
>> 24 >> 16
2415 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2416 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2418 uintmax_t mid
= XFASTINT (XCAR (rest
));
2419 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2422 else if (top
<= UINTMAX_MAX
>> 16)
2426 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2428 val
= top
<< 16 | XFASTINT (rest
);
2434 if (! (valid
&& val
<= max
))
2435 error ("Not an in-range integer, float, or cons of integers");
2439 /* Convert the cons-of-integers, integer, or float value C to a signed
2440 value with extrema MIN and MAX. Signal an error if C does not have
2441 a valid format or is out of range. */
2443 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2446 intmax_t val
IF_LINT (= 0);
2452 else if (FLOATP (c
))
2454 double d
= XFLOAT_DATA (c
);
2456 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2462 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2464 intmax_t top
= XINT (XCAR (c
));
2465 Lisp_Object rest
= XCDR (c
);
2466 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2468 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2469 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2471 intmax_t mid
= XFASTINT (XCAR (rest
));
2472 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2475 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2479 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2481 val
= top
<< 16 | XFASTINT (rest
);
2487 if (! (valid
&& min
<= val
&& val
<= max
))
2488 error ("Not an in-range integer, float, or cons of integers");
2492 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2493 doc
: /* Return the decimal representation of NUMBER as a string.
2494 Uses a minus sign if negative.
2495 NUMBER may be an integer or a floating point number. */)
2496 (Lisp_Object number
)
2498 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2501 CHECK_NUMBER_OR_FLOAT (number
);
2503 if (FLOATP (number
))
2504 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2506 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2508 return make_unibyte_string (buffer
, len
);
2511 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2512 doc
: /* Parse STRING as a decimal number and return the number.
2513 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2514 STRING cannot be parsed as an integer or floating point number.
2516 If BASE, interpret STRING as a number in that base. If BASE isn't
2517 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2518 If the base used is not 10, STRING is always parsed as an integer. */)
2519 (register Lisp_Object string
, Lisp_Object base
)
2525 CHECK_STRING (string
);
2531 CHECK_NUMBER (base
);
2532 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2533 xsignal1 (Qargs_out_of_range
, base
);
2537 p
= SSDATA (string
);
2538 while (*p
== ' ' || *p
== '\t')
2541 val
= string_to_number (p
, b
, 1);
2542 return NILP (val
) ? make_number (0) : val
;
2558 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2559 ptrdiff_t, Lisp_Object
*);
2561 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2564 ptrdiff_t argnum
, ok_args
;
2565 EMACS_INT accum
= 0;
2566 EMACS_INT next
, ok_accum
;
2587 for (argnum
= 0; argnum
< nargs
; argnum
++)
2595 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2597 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2600 return float_arith_driver (ok_accum
, ok_args
, code
,
2603 next
= XINT (args
[argnum
]);
2607 if (INT_ADD_OVERFLOW (accum
, next
))
2615 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2620 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2623 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2625 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2627 accum
= ab
& INTMASK
;
2638 xsignal0 (Qarith_error
);
2652 if (!argnum
|| next
> accum
)
2656 if (!argnum
|| next
< accum
)
2662 XSETINT (val
, accum
);
2667 #define isnan(x) ((x) != (x))
2670 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2671 ptrdiff_t nargs
, Lisp_Object
*args
)
2673 register Lisp_Object val
;
2676 for (; argnum
< nargs
; argnum
++)
2678 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2679 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2683 next
= XFLOAT_DATA (val
);
2687 args
[argnum
] = val
; /* runs into a compiler bug. */
2688 next
= XINT (args
[argnum
]);
2696 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2706 if (! IEEE_FLOATING_POINT
&& next
== 0)
2707 xsignal0 (Qarith_error
);
2714 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2716 if (!argnum
|| isnan (next
) || next
> accum
)
2720 if (!argnum
|| isnan (next
) || next
< accum
)
2726 return make_float (accum
);
2730 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2731 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2732 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2733 (ptrdiff_t nargs
, Lisp_Object
*args
)
2735 return arith_driver (Aadd
, nargs
, args
);
2738 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2739 doc
: /* Negate number or subtract numbers or markers and return the result.
2740 With one arg, negates it. With more than one arg,
2741 subtracts all but the first from the first.
2742 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2743 (ptrdiff_t nargs
, Lisp_Object
*args
)
2745 return arith_driver (Asub
, nargs
, args
);
2748 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2749 doc
: /* Return product of any number of arguments, which are numbers or markers.
2750 usage: (* &rest NUMBERS-OR-MARKERS) */)
2751 (ptrdiff_t nargs
, Lisp_Object
*args
)
2753 return arith_driver (Amult
, nargs
, args
);
2756 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2757 doc
: /* Return first argument divided by all the remaining arguments.
2758 The arguments must be numbers or markers.
2759 usage: (/ DIVIDEND &rest DIVISORS) */)
2760 (ptrdiff_t nargs
, Lisp_Object
*args
)
2763 for (argnum
= 2; argnum
< nargs
; argnum
++)
2764 if (FLOATP (args
[argnum
]))
2765 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2766 return arith_driver (Adiv
, nargs
, args
);
2769 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2770 doc
: /* Return remainder of X divided by Y.
2771 Both must be integers or markers. */)
2772 (register Lisp_Object x
, Lisp_Object y
)
2776 CHECK_NUMBER_COERCE_MARKER (x
);
2777 CHECK_NUMBER_COERCE_MARKER (y
);
2780 xsignal0 (Qarith_error
);
2782 XSETINT (val
, XINT (x
) % XINT (y
));
2786 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2787 doc
: /* Return X modulo Y.
2788 The result falls between zero (inclusive) and Y (exclusive).
2789 Both X and Y must be numbers or markers. */)
2790 (register Lisp_Object x
, Lisp_Object y
)
2795 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2796 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2798 if (FLOATP (x
) || FLOATP (y
))
2799 return fmod_float (x
, y
);
2805 xsignal0 (Qarith_error
);
2809 /* If the "remainder" comes out with the wrong sign, fix it. */
2810 if (i2
< 0 ? i1
> 0 : i1
< 0)
2817 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2818 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2819 The value is always a number; markers are converted to numbers.
2820 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2821 (ptrdiff_t nargs
, Lisp_Object
*args
)
2823 return arith_driver (Amax
, nargs
, args
);
2826 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2827 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2828 The value is always a number; markers are converted to numbers.
2829 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2830 (ptrdiff_t nargs
, Lisp_Object
*args
)
2832 return arith_driver (Amin
, nargs
, args
);
2835 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2836 doc
: /* Return bitwise-and of all the arguments.
2837 Arguments may be integers, or markers converted to integers.
2838 usage: (logand &rest INTS-OR-MARKERS) */)
2839 (ptrdiff_t nargs
, Lisp_Object
*args
)
2841 return arith_driver (Alogand
, nargs
, args
);
2844 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2845 doc
: /* Return bitwise-or of all the arguments.
2846 Arguments may be integers, or markers converted to integers.
2847 usage: (logior &rest INTS-OR-MARKERS) */)
2848 (ptrdiff_t nargs
, Lisp_Object
*args
)
2850 return arith_driver (Alogior
, nargs
, args
);
2853 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2854 doc
: /* Return bitwise-exclusive-or of all the arguments.
2855 Arguments may be integers, or markers converted to integers.
2856 usage: (logxor &rest INTS-OR-MARKERS) */)
2857 (ptrdiff_t nargs
, Lisp_Object
*args
)
2859 return arith_driver (Alogxor
, nargs
, args
);
2862 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2863 doc
: /* Return VALUE with its bits shifted left by COUNT.
2864 If COUNT is negative, shifting is actually to the right.
2865 In this case, the sign bit is duplicated. */)
2866 (register Lisp_Object value
, Lisp_Object count
)
2868 register Lisp_Object val
;
2870 CHECK_NUMBER (value
);
2871 CHECK_NUMBER (count
);
2873 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2875 else if (XINT (count
) > 0)
2876 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2877 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2878 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2880 XSETINT (val
, XINT (value
) >> -XINT (count
));
2884 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2885 doc
: /* Return VALUE with its bits shifted left by COUNT.
2886 If COUNT is negative, shifting is actually to the right.
2887 In this case, zeros are shifted in on the left. */)
2888 (register Lisp_Object value
, Lisp_Object count
)
2890 register Lisp_Object val
;
2892 CHECK_NUMBER (value
);
2893 CHECK_NUMBER (count
);
2895 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2897 else if (XINT (count
) > 0)
2898 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2899 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2902 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2906 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2907 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2908 Markers are converted to integers. */)
2909 (register Lisp_Object number
)
2911 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2913 if (FLOATP (number
))
2914 return (make_float (1.0 + XFLOAT_DATA (number
)));
2916 XSETINT (number
, XINT (number
) + 1);
2920 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2921 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2922 Markers are converted to integers. */)
2923 (register Lisp_Object number
)
2925 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2927 if (FLOATP (number
))
2928 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2930 XSETINT (number
, XINT (number
) - 1);
2934 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2935 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2936 (register Lisp_Object number
)
2938 CHECK_NUMBER (number
);
2939 XSETINT (number
, ~XINT (number
));
2943 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2944 doc
: /* Return the byteorder for the machine.
2945 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2946 lowercase l) for small endian machines. */)
2949 unsigned i
= 0x04030201;
2950 int order
= *(char *)&i
== 1 ? 108 : 66;
2952 return make_number (order
);
2955 /* Because we round up the bool vector allocate size to word_size
2956 units, we can safely read past the "end" of the vector in the
2957 operations below. These extra bits are always zero. */
2960 bool_vector_spare_mask (EMACS_INT nr_bits
)
2962 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2965 /* Info about unsigned long long, falling back on unsigned long
2966 if unsigned long long is not available. */
2968 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2969 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2970 # define ULL_MAX ULLONG_MAX
2972 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
2973 # define ULL_MAX ULONG_MAX
2974 # define count_one_bits_ll count_one_bits_l
2975 # define count_trailing_zeros_ll count_trailing_zeros_l
2978 /* Shift VAL right by the width of an unsigned long long.
2979 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
2982 shift_right_ull (bits_word w
)
2984 /* Pacify bogus GCC warning about shift count exceeding type width. */
2985 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
2989 /* Return the number of 1 bits in W. */
2992 count_one_bits_word (bits_word w
)
2994 if (BITS_WORD_MAX
<= UINT_MAX
)
2995 return count_one_bits (w
);
2996 else if (BITS_WORD_MAX
<= ULONG_MAX
)
2997 return count_one_bits_l (w
);
3000 int i
= 0, count
= 0;
3001 while (count
+= count_one_bits_ll (w
),
3002 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3003 w
= shift_right_ull (w
);
3008 enum bool_vector_op
{ bool_vector_exclusive_or
,
3010 bool_vector_intersection
,
3011 bool_vector_set_difference
,
3012 bool_vector_subsetp
};
3015 bool_vector_binop_driver (Lisp_Object a
,
3018 enum bool_vector_op op
)
3021 bits_word
*adata
, *bdata
, *destdata
;
3025 CHECK_BOOL_VECTOR (a
);
3026 CHECK_BOOL_VECTOR (b
);
3028 nr_bits
= bool_vector_size (a
);
3029 if (bool_vector_size (b
) != nr_bits
)
3030 wrong_length_argument (a
, b
, dest
);
3032 nr_words
= bool_vector_words (nr_bits
);
3033 adata
= bool_vector_data (a
);
3034 bdata
= bool_vector_data (b
);
3038 dest
= make_uninit_bool_vector (nr_bits
);
3039 destdata
= bool_vector_data (dest
);
3043 CHECK_BOOL_VECTOR (dest
);
3044 destdata
= bool_vector_data (dest
);
3045 if (bool_vector_size (dest
) != nr_bits
)
3046 wrong_length_argument (a
, b
, dest
);
3050 case bool_vector_exclusive_or
:
3051 for (; i
< nr_words
; i
++)
3052 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3056 case bool_vector_subsetp
:
3057 for (; i
< nr_words
; i
++)
3058 if (adata
[i
] &~ bdata
[i
])
3062 case bool_vector_union
:
3063 for (; i
< nr_words
; i
++)
3064 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3068 case bool_vector_intersection
:
3069 for (; i
< nr_words
; i
++)
3070 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3074 case bool_vector_set_difference
:
3075 for (; i
< nr_words
; i
++)
3076 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3087 case bool_vector_exclusive_or
:
3088 for (; i
< nr_words
; i
++)
3089 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3092 case bool_vector_union
:
3093 for (; i
< nr_words
; i
++)
3094 destdata
[i
] = adata
[i
] | bdata
[i
];
3097 case bool_vector_intersection
:
3098 for (; i
< nr_words
; i
++)
3099 destdata
[i
] = adata
[i
] & bdata
[i
];
3102 case bool_vector_set_difference
:
3103 for (; i
< nr_words
; i
++)
3104 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3114 /* PRECONDITION must be true. Return VALUE. This odd construction
3115 works around a bogus GCC diagnostic "shift count >= width of type". */
3118 pre_value (bool precondition
, int value
)
3120 eassume (precondition
);
3121 return precondition
? value
: 0;
3124 /* Compute the number of trailing zero bits in val. If val is zero,
3125 return the number of bits in val. */
3127 count_trailing_zero_bits (bits_word val
)
3129 if (BITS_WORD_MAX
== UINT_MAX
)
3130 return count_trailing_zeros (val
);
3131 if (BITS_WORD_MAX
== ULONG_MAX
)
3132 return count_trailing_zeros_l (val
);
3133 if (BITS_WORD_MAX
== ULL_MAX
)
3134 return count_trailing_zeros_ll (val
);
3136 /* The rest of this code is for the unlikely platform where bits_word differs
3137 in width from unsigned int, unsigned long, and unsigned long long. */
3138 val
|= ~ BITS_WORD_MAX
;
3139 if (BITS_WORD_MAX
<= UINT_MAX
)
3140 return count_trailing_zeros (val
);
3141 if (BITS_WORD_MAX
<= ULONG_MAX
)
3142 return count_trailing_zeros_l (val
);
3147 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3148 count
+= BITS_PER_ULL
)
3151 return count
+ count_trailing_zeros_ll (val
);
3152 val
= shift_right_ull (val
);
3155 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3156 && BITS_WORD_MAX
== (bits_word
) -1)
3157 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3158 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3159 return count
+ count_trailing_zeros_ll (val
);
3164 bits_word_to_host_endian (bits_word val
)
3166 #ifndef WORDS_BIGENDIAN
3169 if (BITS_WORD_MAX
>> 31 == 1)
3170 return bswap_32 (val
);
3171 # if HAVE_UNSIGNED_LONG_LONG
3172 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3173 return bswap_64 (val
);
3178 for (i
= 0; i
< sizeof val
; i
++)
3180 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3181 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3182 val
= val
>> 1 >> (CHAR_BIT
- 1);
3189 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3190 Sbool_vector_exclusive_or
, 2, 3, 0,
3191 doc
: /* Return A ^ B, bitwise exclusive or.
3192 If optional third argument C is given, store result into C.
3193 A, B, and C must be bool vectors of the same length.
3194 Return the destination vector if it changed or nil otherwise. */)
3195 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3197 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3200 DEFUN ("bool-vector-union", Fbool_vector_union
,
3201 Sbool_vector_union
, 2, 3, 0,
3202 doc
: /* Return A | B, bitwise or.
3203 If optional third argument C is given, store result into C.
3204 A, B, and C must be bool vectors of the same length.
3205 Return the destination vector if it changed or nil otherwise. */)
3206 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3208 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3211 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3212 Sbool_vector_intersection
, 2, 3, 0,
3213 doc
: /* Return A & B, bitwise and.
3214 If optional third argument C is given, store result into C.
3215 A, B, and C must be bool vectors of the same length.
3216 Return the destination vector if it changed or nil otherwise. */)
3217 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3219 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3222 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3223 Sbool_vector_set_difference
, 2, 3, 0,
3224 doc
: /* Return A &~ B, set difference.
3225 If optional third argument C is given, store result into C.
3226 A, B, and C must be bool vectors of the same length.
3227 Return the destination vector if it changed or nil otherwise. */)
3228 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3230 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3233 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3234 Sbool_vector_subsetp
, 2, 2, 0,
3235 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3236 A and B must be bool vectors of the same length. */)
3237 (Lisp_Object a
, Lisp_Object b
)
3239 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3242 DEFUN ("bool-vector-not", Fbool_vector_not
,
3243 Sbool_vector_not
, 1, 2, 0,
3244 doc
: /* Compute ~A, set complement.
3245 If optional second argument B is given, store result into B.
3246 A and B must be bool vectors of the same length.
3247 Return the destination vector. */)
3248 (Lisp_Object a
, Lisp_Object b
)
3251 bits_word
*bdata
, *adata
;
3254 CHECK_BOOL_VECTOR (a
);
3255 nr_bits
= bool_vector_size (a
);
3258 b
= make_uninit_bool_vector (nr_bits
);
3261 CHECK_BOOL_VECTOR (b
);
3262 if (bool_vector_size (b
) != nr_bits
)
3263 wrong_length_argument (a
, b
, Qnil
);
3266 bdata
= bool_vector_data (b
);
3267 adata
= bool_vector_data (a
);
3269 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3270 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3272 if (nr_bits
% BITS_PER_BITS_WORD
)
3274 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3276 mword
&= bool_vector_spare_mask (nr_bits
);
3277 bdata
[i
] = bits_word_to_host_endian (mword
);
3283 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3284 Sbool_vector_count_population
, 1, 1, 0,
3285 doc
: /* Count how many elements in A are t.
3286 A is a bool vector. To count A's nil elements, subtract the return
3287 value from A's length. */)
3293 ptrdiff_t i
, nwords
;
3295 CHECK_BOOL_VECTOR (a
);
3297 nr_bits
= bool_vector_size (a
);
3298 nwords
= bool_vector_words (nr_bits
);
3300 adata
= bool_vector_data (a
);
3302 for (i
= 0; i
< nwords
; i
++)
3303 count
+= count_one_bits_word (adata
[i
]);
3305 return make_number (count
);
3308 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3309 Sbool_vector_count_consecutive
, 3, 3, 0,
3310 doc
: /* Count how many consecutive elements in A equal B starting at I.
3311 A is a bool vector, B is t or nil, and I is an index into A. */)
3312 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3319 bits_word mword
; /* Machine word. */
3320 ptrdiff_t pos
, pos0
;
3323 CHECK_BOOL_VECTOR (a
);
3326 nr_bits
= bool_vector_size (a
);
3327 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3328 args_out_of_range (a
, i
);
3330 adata
= bool_vector_data (a
);
3331 nr_words
= bool_vector_words (nr_bits
);
3332 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3333 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3336 /* By XORing with twiddle, we transform the problem of "count
3337 consecutive equal values" into "count the zero bits". The latter
3338 operation usually has hardware support. */
3339 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3341 /* Scan the remainder of the mword at the current offset. */
3342 if (pos
< nr_words
&& offset
!= 0)
3344 mword
= bits_word_to_host_endian (adata
[pos
]);
3348 /* Do not count the pad bits. */
3349 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3351 count
= count_trailing_zero_bits (mword
);
3353 if (count
+ offset
< BITS_PER_BITS_WORD
)
3354 return make_number (count
);
3357 /* Scan whole words until we either reach the end of the vector or
3358 find an mword that doesn't completely match. twiddle is
3359 endian-independent. */
3361 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3363 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3367 /* If we stopped because of a mismatch, see how many bits match
3368 in the current mword. */
3369 mword
= bits_word_to_host_endian (adata
[pos
]);
3371 count
+= count_trailing_zero_bits (mword
);
3373 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3375 /* If we hit the end, we might have overshot our count. Reduce
3376 the total by the number of spare bits at the end of the
3378 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3381 return make_number (count
);
3388 Lisp_Object error_tail
, arith_tail
;
3392 DEFSYM (Qquote
, "quote");
3393 DEFSYM (Qlambda
, "lambda");
3394 DEFSYM (Qsubr
, "subr");
3395 DEFSYM (Qerror_conditions
, "error-conditions");
3396 DEFSYM (Qerror_message
, "error-message");
3397 DEFSYM (Qtop_level
, "top-level");
3399 DEFSYM (Qerror
, "error");
3400 DEFSYM (Quser_error
, "user-error");
3401 DEFSYM (Qquit
, "quit");
3402 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3403 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3404 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3405 DEFSYM (Qvoid_function
, "void-function");
3406 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3407 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3408 DEFSYM (Qvoid_variable
, "void-variable");
3409 DEFSYM (Qsetting_constant
, "setting-constant");
3410 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3412 DEFSYM (Qinvalid_function
, "invalid-function");
3413 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3414 DEFSYM (Qno_catch
, "no-catch");
3415 DEFSYM (Qend_of_file
, "end-of-file");
3416 DEFSYM (Qarith_error
, "arith-error");
3417 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3418 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3419 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3420 DEFSYM (Qtext_read_only
, "text-read-only");
3421 DEFSYM (Qmark_inactive
, "mark-inactive");
3423 DEFSYM (Qlistp
, "listp");
3424 DEFSYM (Qconsp
, "consp");
3425 DEFSYM (Qsymbolp
, "symbolp");
3426 DEFSYM (Qkeywordp
, "keywordp");
3427 DEFSYM (Qintegerp
, "integerp");
3428 DEFSYM (Qnatnump
, "natnump");
3429 DEFSYM (Qwholenump
, "wholenump");
3430 DEFSYM (Qstringp
, "stringp");
3431 DEFSYM (Qarrayp
, "arrayp");
3432 DEFSYM (Qsequencep
, "sequencep");
3433 DEFSYM (Qbufferp
, "bufferp");
3434 DEFSYM (Qvectorp
, "vectorp");
3435 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3436 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3437 DEFSYM (Qmarkerp
, "markerp");
3438 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3439 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3440 DEFSYM (Qboundp
, "boundp");
3441 DEFSYM (Qfboundp
, "fboundp");
3443 DEFSYM (Qfloatp
, "floatp");
3444 DEFSYM (Qnumberp
, "numberp");
3445 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3447 DEFSYM (Qchar_table_p
, "char-table-p");
3448 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3450 DEFSYM (Qsubrp
, "subrp");
3451 DEFSYM (Qunevalled
, "unevalled");
3452 DEFSYM (Qmany
, "many");
3454 DEFSYM (Qcdr
, "cdr");
3456 /* Handle automatic advice activation. */
3457 DEFSYM (Qad_advice_info
, "ad-advice-info");
3458 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3460 error_tail
= pure_cons (Qerror
, Qnil
);
3462 /* ERROR is used as a signaler for random errors for which nothing else is
3465 Fput (Qerror
, Qerror_conditions
,
3467 Fput (Qerror
, Qerror_message
,
3468 build_pure_c_string ("error"));
3470 #define PUT_ERROR(sym, tail, msg) \
3471 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3472 Fput (sym, Qerror_message, build_pure_c_string (msg))
3474 PUT_ERROR (Qquit
, Qnil
, "Quit");
3476 PUT_ERROR (Quser_error
, error_tail
, "");
3477 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3478 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3479 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3480 PUT_ERROR (Qvoid_function
, error_tail
,
3481 "Symbol's function definition is void");
3482 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3483 "Symbol's chain of function indirections contains a loop");
3484 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3485 "Symbol's chain of variable indirections contains a loop");
3486 DEFSYM (Qcircular_list
, "circular-list");
3487 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3488 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3489 PUT_ERROR (Qsetting_constant
, error_tail
,
3490 "Attempt to set a constant symbol");
3491 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3492 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3493 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3494 "Wrong number of arguments");
3495 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3496 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3498 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3499 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3500 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3502 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3503 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3504 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3505 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3506 "Text is read-only");
3508 DEFSYM (Qrange_error
, "range-error");
3509 DEFSYM (Qdomain_error
, "domain-error");
3510 DEFSYM (Qsingularity_error
, "singularity-error");
3511 DEFSYM (Qoverflow_error
, "overflow-error");
3512 DEFSYM (Qunderflow_error
, "underflow-error");
3514 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3516 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3518 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3519 "Arithmetic singularity error");
3521 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3522 "Arithmetic overflow error");
3523 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3524 "Arithmetic underflow error");
3528 staticpro (&Qunbound
);
3530 /* Types that type-of returns. */
3531 DEFSYM (Qinteger
, "integer");
3532 DEFSYM (Qsymbol
, "symbol");
3533 DEFSYM (Qstring
, "string");
3534 DEFSYM (Qcons
, "cons");
3535 DEFSYM (Qmarker
, "marker");
3536 DEFSYM (Qoverlay
, "overlay");
3537 DEFSYM (Qfloat
, "float");
3538 DEFSYM (Qwindow_configuration
, "window-configuration");
3539 DEFSYM (Qprocess
, "process");
3540 DEFSYM (Qwindow
, "window");
3541 DEFSYM (Qcompiled_function
, "compiled-function");
3542 DEFSYM (Qbuffer
, "buffer");
3543 DEFSYM (Qframe
, "frame");
3544 DEFSYM (Qvector
, "vector");
3545 DEFSYM (Qchar_table
, "char-table");
3546 DEFSYM (Qbool_vector
, "bool-vector");
3547 DEFSYM (Qhash_table
, "hash-table");
3548 DEFSYM (Qmisc
, "misc");
3550 DEFSYM (Qdefun
, "defun");
3552 DEFSYM (Qfont_spec
, "font-spec");
3553 DEFSYM (Qfont_entity
, "font-entity");
3554 DEFSYM (Qfont_object
, "font-object");
3556 DEFSYM (Qinteractive_form
, "interactive-form");
3557 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3559 set_symbol_function (Qwholenump
, SYMBOL_FUNCTION (Qnatnump
));
3561 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3562 doc
: /* The largest value that is representable in a Lisp integer. */);
3563 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3564 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3566 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3567 doc
: /* The smallest value that is representable in a Lisp integer. */);
3568 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3569 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;