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 static Lisp_Object Qsubr
;
42 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
43 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
44 static Lisp_Object Qwrong_length_argument
;
45 static Lisp_Object Qwrong_type_argument
;
46 Lisp_Object Qvoid_variable
, Qvoid_function
;
47 static Lisp_Object Qcyclic_function_indirection
;
48 static Lisp_Object Qcyclic_variable_indirection
;
49 Lisp_Object Qcircular_list
;
50 static Lisp_Object Qsetting_constant
;
51 Lisp_Object Qinvalid_read_syntax
;
52 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
53 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
54 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
55 Lisp_Object Qtext_read_only
;
57 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
58 static Lisp_Object Qnatnump
;
59 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
60 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
61 Lisp_Object Qbool_vector_p
;
62 Lisp_Object Qbuffer_or_string_p
;
63 static Lisp_Object Qkeywordp
, Qboundp
;
65 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
68 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
70 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
71 Lisp_Object Qrange_error
, Qoverflow_error
;
74 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
76 Lisp_Object Qinteger
, Qsymbol
;
77 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
79 static Lisp_Object Qoverlay
, Qwindow_configuration
;
80 static Lisp_Object Qprocess
, Qmarker
;
81 static Lisp_Object Qcompiled_function
, Qframe
;
83 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
84 static Lisp_Object Qsubrp
;
85 static Lisp_Object Qmany
, Qunevalled
;
86 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
87 static Lisp_Object Qdefun
;
89 Lisp_Object Qinteractive_form
;
90 static Lisp_Object Qdefalias_fset_function
;
92 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
95 BOOLFWDP (union Lisp_Fwd
*a
)
97 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
100 INTFWDP (union Lisp_Fwd
*a
)
102 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
105 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
107 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
110 OBJFWDP (union Lisp_Fwd
*a
)
112 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
115 static struct Lisp_Boolfwd
*
116 XBOOLFWD (union Lisp_Fwd
*a
)
118 eassert (BOOLFWDP (a
));
119 return &a
->u_boolfwd
;
121 static struct Lisp_Kboard_Objfwd
*
122 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
124 eassert (KBOARD_OBJFWDP (a
));
125 return &a
->u_kboard_objfwd
;
127 static struct Lisp_Intfwd
*
128 XINTFWD (union Lisp_Fwd
*a
)
130 eassert (INTFWDP (a
));
133 static struct Lisp_Objfwd
*
134 XOBJFWD (union Lisp_Fwd
*a
)
136 eassert (OBJFWDP (a
));
141 CHECK_SUBR (Lisp_Object x
)
143 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
147 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
149 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
154 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
156 return XCDR (blv
->valcell
);
160 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
162 XSETCDR (blv
->valcell
, val
);
166 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
172 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
178 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
183 static _Noreturn
void
184 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
186 Lisp_Object size1
= make_number (bool_vector_size (a1
));
187 Lisp_Object size2
= make_number (bool_vector_size (a2
));
189 xsignal2 (Qwrong_length_argument
, size1
, size2
);
191 xsignal3 (Qwrong_length_argument
, size1
, size2
,
192 make_number (bool_vector_size (a3
)));
196 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
198 /* If VALUE is not even a valid Lisp object, we'd want to abort here
199 where we can get a backtrace showing where it came from. We used
200 to try and do that by checking the tagbits, but nowadays all
201 tagbits are potentially valid. */
202 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
205 xsignal2 (Qwrong_type_argument
, predicate
, value
);
209 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
211 xsignal2 (Qargs_out_of_range
, a1
, a2
);
215 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
217 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
221 /* Data type predicates. */
223 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
224 doc
: /* Return t if the two args are the same Lisp object. */)
225 (Lisp_Object obj1
, Lisp_Object obj2
)
232 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
233 doc
: /* Return t if OBJECT is nil. */)
241 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
242 doc
: /* Return a symbol representing the type of OBJECT.
243 The symbol returned names the object's basic type;
244 for example, (type-of 1) returns `integer'. */)
247 if (INTEGERP (object
))
249 else if (SYMBOLP (object
))
251 else if (STRINGP (object
))
253 else if (CONSP (object
))
255 else if (MISCP (object
))
257 switch (XMISCTYPE (object
))
259 case Lisp_Misc_Marker
:
261 case Lisp_Misc_Overlay
:
263 case Lisp_Misc_Float
:
268 else if (VECTORLIKEP (object
))
270 if (WINDOW_CONFIGURATIONP (object
))
271 return Qwindow_configuration
;
272 if (PROCESSP (object
))
274 if (WINDOWP (object
))
278 if (COMPILEDP (object
))
279 return Qcompiled_function
;
280 if (BUFFERP (object
))
282 if (CHAR_TABLE_P (object
))
284 if (BOOL_VECTOR_P (object
))
288 if (HASH_TABLE_P (object
))
290 if (FONT_SPEC_P (object
))
292 if (FONT_ENTITY_P (object
))
294 if (FONT_OBJECT_P (object
))
298 else if (FLOATP (object
))
304 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
305 doc
: /* Return t if OBJECT is a cons cell. */)
313 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
314 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
322 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
323 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
324 Otherwise, return nil. */)
327 if (CONSP (object
) || NILP (object
))
332 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
333 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
336 if (CONSP (object
) || NILP (object
))
341 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
342 doc
: /* Return t if OBJECT is a symbol. */)
345 if (SYMBOLP (object
))
351 SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym
)
353 /* Should be initial_obarray */
354 Lisp_Object tem
= Ffind_symbol (SYMBOL_NAME (sym
), Vobarray
);
355 return (! NILP (scm_c_value_ref (tem
, 1))
356 && (EQ (sym
, scm_c_value_ref (tem
, 0))));
359 /* Define this in C to avoid unnecessarily consing up the symbol
361 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
362 doc
: /* Return t if OBJECT is a keyword.
363 This means that it is a symbol with a print name beginning with `:'
364 interned in the initial obarray. */)
368 && SREF (SYMBOL_NAME (object
), 0) == ':'
369 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
374 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
375 doc
: /* Return t if OBJECT is a vector. */)
378 if (VECTORP (object
))
383 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
384 doc
: /* Return t if OBJECT is a string. */)
387 if (STRINGP (object
))
392 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
394 doc
: /* Return t if OBJECT is a multibyte string.
395 Return nil if OBJECT is either a unibyte string, or not a string. */)
398 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
403 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
404 doc
: /* Return t if OBJECT is a char-table. */)
407 if (CHAR_TABLE_P (object
))
412 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
413 Svector_or_char_table_p
, 1, 1, 0,
414 doc
: /* Return t if OBJECT is a char-table or vector. */)
417 if (VECTORP (object
) || CHAR_TABLE_P (object
))
422 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
423 doc
: /* Return t if OBJECT is a bool-vector. */)
426 if (BOOL_VECTOR_P (object
))
431 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
432 doc
: /* Return t if OBJECT is an array (string or vector). */)
440 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
441 doc
: /* Return t if OBJECT is a sequence (list or array). */)
442 (register Lisp_Object object
)
444 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
449 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
450 doc
: /* Return t if OBJECT is an editor buffer. */)
453 if (BUFFERP (object
))
458 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
462 if (MARKERP (object
))
467 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
468 doc
: /* Return t if OBJECT is a built-in function. */)
476 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
478 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
481 if (COMPILEDP (object
))
486 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
487 doc
: /* Return t if OBJECT is a character or a string. */)
488 (register Lisp_Object object
)
490 if (CHARACTERP (object
) || STRINGP (object
))
495 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
496 doc
: /* Return t if OBJECT is an integer. */)
499 if (INTEGERP (object
))
504 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
505 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
506 (register Lisp_Object object
)
508 if (MARKERP (object
) || INTEGERP (object
))
513 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
514 doc
: /* Return t if OBJECT is a nonnegative integer. */)
517 if (NATNUMP (object
))
522 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
523 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
526 if (NUMBERP (object
))
532 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
533 Snumber_or_marker_p
, 1, 1, 0,
534 doc
: /* Return t if OBJECT is a number or a marker. */)
537 if (NUMBERP (object
) || MARKERP (object
))
542 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
543 doc
: /* Return t if OBJECT is a floating point number. */)
552 /* Extract and set components of lists. */
554 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
555 doc
: /* Return the car of LIST. If arg is nil, return nil.
556 Error if arg is not nil and not a cons cell. See also `car-safe'.
558 See Info node `(elisp)Cons Cells' for a discussion of related basic
559 Lisp concepts such as car, cdr, cons cell and list. */)
560 (register Lisp_Object list
)
565 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
566 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
569 return CAR_SAFE (object
);
572 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
573 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
574 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
576 See Info node `(elisp)Cons Cells' for a discussion of related basic
577 Lisp concepts such as cdr, car, cons cell and list. */)
578 (register Lisp_Object list
)
583 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
584 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
587 return CDR_SAFE (object
);
590 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
591 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
592 (register Lisp_Object cell
, Lisp_Object newcar
)
596 XSETCAR (cell
, newcar
);
600 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
601 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
602 (register Lisp_Object cell
, Lisp_Object newcdr
)
606 XSETCDR (cell
, newcdr
);
610 /* Extract and set components of symbols. */
612 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
613 doc
: /* Return t if SYMBOL's value is not void.
614 Note that if `lexical-binding' is in effect, this refers to the
615 global value outside of any lexical scope. */)
616 (register Lisp_Object symbol
)
618 Lisp_Object valcontents
;
619 struct Lisp_Symbol
*sym
;
620 CHECK_SYMBOL (symbol
);
621 sym
= XSYMBOL (symbol
);
624 switch (sym
->redirect
)
626 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
627 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
628 case SYMBOL_LOCALIZED
:
630 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
632 /* In set_internal, we un-forward vars when their value is
637 swap_in_symval_forwarding (sym
, blv
);
638 valcontents
= blv_value (blv
);
642 case SYMBOL_FORWARDED
:
643 /* In set_internal, we un-forward vars when their value is
646 default: emacs_abort ();
649 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
652 /* FIXME: Make it an alias for function-symbol! */
653 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
654 doc
: /* Return t if SYMBOL's function definition is not void. */)
655 (register Lisp_Object symbol
)
657 CHECK_SYMBOL (symbol
);
658 return NILP (SYMBOL_FUNCTION (symbol
)) ? Qnil
: Qt
;
661 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
662 doc
: /* Make SYMBOL's value be void.
664 (register Lisp_Object symbol
)
666 CHECK_SYMBOL (symbol
);
667 if (SYMBOL_CONSTANT_P (symbol
))
668 xsignal1 (Qsetting_constant
, symbol
);
669 Fset (symbol
, Qunbound
);
673 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
674 doc
: /* Make SYMBOL's function definition be nil.
676 (register Lisp_Object symbol
)
678 CHECK_SYMBOL (symbol
);
679 if (NILP (symbol
) || EQ (symbol
, Qt
))
680 xsignal1 (Qsetting_constant
, symbol
);
681 set_symbol_function (symbol
, Qnil
);
685 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
686 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
687 (register Lisp_Object symbol
)
689 CHECK_SYMBOL (symbol
);
690 return SYMBOL_FUNCTION (symbol
);
693 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
694 doc
: /* Return SYMBOL's property list. */)
695 (register Lisp_Object symbol
)
697 CHECK_SYMBOL (symbol
);
698 return symbol_plist (symbol
);
701 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
702 doc
: /* Return SYMBOL's name, a string. */)
703 (register Lisp_Object symbol
)
705 register Lisp_Object name
;
707 CHECK_SYMBOL (symbol
);
708 name
= SYMBOL_NAME (symbol
);
712 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
713 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
714 (register Lisp_Object symbol
, Lisp_Object definition
)
716 register Lisp_Object function
;
717 CHECK_SYMBOL (symbol
);
719 function
= SYMBOL_FUNCTION (symbol
);
721 if (!NILP (Vautoload_queue
) && !NILP (function
))
722 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
724 if (AUTOLOADP (function
))
725 Fput (symbol
, Qautoload
, XCDR (function
));
727 /* Convert to eassert or remove after GC bug is found. In the
728 meantime, check unconditionally, at a slight perf hit. */
729 if (valid_lisp_object_p (definition
) < 1)
732 set_symbol_function (symbol
, definition
);
737 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
738 doc
: /* Set SYMBOL's function definition to DEFINITION.
739 Associates the function with the current load file, if any.
740 The optional third argument DOCSTRING specifies the documentation string
741 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
742 determined by DEFINITION.
744 Internally, this normally uses `fset', but if SYMBOL has a
745 `defalias-fset-function' property, the associated value is used instead.
747 The return value is undefined. */)
748 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
750 CHECK_SYMBOL (symbol
);
751 if (!NILP (Vpurify_flag
)
752 /* If `definition' is a keymap, immutable (and copying) is wrong. */
753 && !KEYMAPP (definition
))
754 definition
= Fpurecopy (definition
);
757 bool autoload
= AUTOLOADP (definition
);
758 if (NILP (Vpurify_flag
) || !autoload
)
759 { /* Only add autoload entries after dumping, because the ones before are
760 not useful and else we get loads of them from the loaddefs.el. */
762 if (AUTOLOADP (SYMBOL_FUNCTION (symbol
)))
763 /* Remember that the function was already an autoload. */
764 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
765 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
769 { /* Handle automatic advice activation. */
770 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
772 call2 (hook
, symbol
, definition
);
774 Ffset (symbol
, definition
);
777 if (!NILP (docstring
))
778 Fput (symbol
, Qfunction_documentation
, docstring
);
779 /* We used to return `definition', but now that `defun' and `defmacro' expand
780 to a call to `defalias', we return `symbol' for backward compatibility
785 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
786 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
787 (register Lisp_Object symbol
, Lisp_Object newplist
)
789 CHECK_SYMBOL (symbol
);
790 set_symbol_plist (symbol
, newplist
);
794 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
795 doc
: /* Return minimum and maximum number of args allowed for SUBR.
796 SUBR must be a built-in function.
797 The returned value is a pair (MIN . MAX). MIN is the minimum number
798 of args. MAX is the maximum number or the symbol `many', for a
799 function with `&rest' args, or `unevalled' for a special form. */)
802 short minargs
, maxargs
;
804 minargs
= XSUBR (subr
)->min_args
;
805 maxargs
= XSUBR (subr
)->max_args
;
806 return Fcons (make_number (minargs
),
807 maxargs
== MANY
? Qmany
808 : maxargs
== UNEVALLED
? Qunevalled
809 : make_number (maxargs
));
812 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
813 doc
: /* Return name of subroutine SUBR.
814 SUBR must be a built-in function. */)
819 name
= XSUBR (subr
)->symbol_name
;
820 return build_string (name
);
823 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
824 doc
: /* Return the interactive form of CMD or nil if none.
825 If CMD is not a command, the return value is nil.
826 Value, if non-nil, is a list \(interactive SPEC). */)
829 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
834 /* Use an `interactive-form' property if present, analogous to the
835 function-documentation property. */
837 while (SYMBOLP (fun
))
839 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
843 fun
= Fsymbol_function (fun
);
848 const char *spec
= XSUBR (fun
)->intspec
;
850 return list2 (Qinteractive
,
851 (*spec
!= '(') ? build_string (spec
) :
852 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
854 else if (COMPILEDP (fun
))
856 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
857 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
859 else if (AUTOLOADP (fun
))
860 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
861 else if (CONSP (fun
))
863 Lisp_Object funcar
= XCAR (fun
);
864 if (EQ (funcar
, Qclosure
))
865 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
866 else if (EQ (funcar
, Qlambda
))
867 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
873 /***********************************************************************
874 Getting and Setting Values of Symbols
875 ***********************************************************************/
877 /* Return the symbol holding SYMBOL's value. Signal
878 `cyclic-variable-indirection' if SYMBOL's chain of variable
879 indirections contains a loop. */
882 indirect_variable (struct Lisp_Symbol
*symbol
)
884 struct Lisp_Symbol
*tortoise
, *hare
;
886 hare
= tortoise
= symbol
;
888 while (hare
->redirect
== SYMBOL_VARALIAS
)
890 hare
= SYMBOL_ALIAS (hare
);
891 if (hare
->redirect
!= SYMBOL_VARALIAS
)
894 hare
= SYMBOL_ALIAS (hare
);
895 tortoise
= SYMBOL_ALIAS (tortoise
);
897 if (hare
== tortoise
)
900 XSETSYMBOL (tem
, symbol
);
901 xsignal1 (Qcyclic_variable_indirection
, tem
);
909 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
910 doc
: /* Return the variable at the end of OBJECT's variable chain.
911 If OBJECT is a symbol, follow its variable indirections (if any), and
912 return the variable at the end of the chain of aliases. See Info node
913 `(elisp)Variable Aliases'.
915 If OBJECT is not a symbol, just return it. If there is a loop in the
916 chain of aliases, signal a `cyclic-variable-indirection' error. */)
919 if (SYMBOLP (object
))
921 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
922 XSETSYMBOL (object
, sym
);
928 /* Given the raw contents of a symbol value cell,
929 return the Lisp value of the symbol.
930 This does not handle buffer-local variables; use
931 swap_in_symval_forwarding for that. */
934 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
936 register Lisp_Object val
;
937 switch (XFWDTYPE (valcontents
))
940 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
944 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
947 return *XOBJFWD (valcontents
)->objvar
;
949 case Lisp_Fwd_Buffer_Obj
:
950 return per_buffer_value (current_buffer
,
951 XBUFFER_OBJFWD (valcontents
)->offset
);
953 case Lisp_Fwd_Kboard_Obj
:
954 /* We used to simply use current_kboard here, but from Lisp
955 code, its value is often unexpected. It seems nicer to
956 allow constructions like this to work as intuitively expected:
958 (with-selected-frame frame
959 (define-key local-function-map "\eOP" [f1]))
961 On the other hand, this affects the semantics of
962 last-command and real-last-command, and people may rely on
963 that. I took a quick look at the Lisp codebase, and I
964 don't think anything will break. --lorentey */
965 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
966 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
967 default: emacs_abort ();
971 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
972 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
973 buffer-independent contents of the value cell: forwarded just one
974 step past the buffer-localness.
976 BUF non-zero means set the value in buffer BUF instead of the
977 current buffer. This only plays a role for per-buffer variables. */
980 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
982 switch (XFWDTYPE (valcontents
))
985 CHECK_NUMBER (newval
);
986 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
990 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
994 *XOBJFWD (valcontents
)->objvar
= newval
;
996 /* If this variable is a default for something stored
997 in the buffer itself, such as default-fill-column,
998 find the buffers that don't have local values for it
1000 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1001 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1003 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1004 - (char *) &buffer_defaults
);
1005 int idx
= PER_BUFFER_IDX (offset
);
1007 Lisp_Object tail
, buf
;
1012 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1014 struct buffer
*b
= XBUFFER (buf
);
1016 if (! PER_BUFFER_VALUE_P (b
, idx
))
1017 set_per_buffer_value (b
, offset
, newval
);
1022 case Lisp_Fwd_Buffer_Obj
:
1024 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1025 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1027 if (!NILP (predicate
) && !NILP (newval
)
1028 && NILP (call1 (predicate
, newval
)))
1029 wrong_type_argument (predicate
, newval
);
1032 buf
= current_buffer
;
1033 set_per_buffer_value (buf
, offset
, newval
);
1037 case Lisp_Fwd_Kboard_Obj
:
1039 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1040 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1041 *(Lisp_Object
*) p
= newval
;
1046 emacs_abort (); /* goto def; */
1050 /* Set up SYMBOL to refer to its global binding. This makes it safe
1051 to alter the status of other bindings. BEWARE: this may be called
1052 during the mark phase of GC, where we assume that Lisp_Object slots
1053 of BLV are marked after this function has changed them. */
1056 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1058 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1060 /* Unload the previously loaded binding. */
1062 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1064 /* Select the global binding in the symbol. */
1065 set_blv_valcell (blv
, blv
->defcell
);
1067 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1069 /* Indicate that the global binding is set up now. */
1070 set_blv_where (blv
, Qnil
);
1071 set_blv_found (blv
, 0);
1074 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1075 VALCONTENTS is the contents of its value cell,
1076 which points to a struct Lisp_Buffer_Local_Value.
1078 Return the value forwarded one step past the buffer-local stage.
1079 This could be another forwarding pointer. */
1082 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1084 register Lisp_Object tem1
;
1086 eassert (blv
== SYMBOL_BLV (symbol
));
1091 || (blv
->frame_local
1092 ? !EQ (selected_frame
, tem1
)
1093 : current_buffer
!= XBUFFER (tem1
)))
1096 /* Unload the previously loaded binding. */
1097 tem1
= blv
->valcell
;
1099 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1100 /* Choose the new binding. */
1103 XSETSYMBOL (var
, symbol
);
1104 if (blv
->frame_local
)
1106 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1107 set_blv_where (blv
, selected_frame
);
1111 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1112 set_blv_where (blv
, Fcurrent_buffer ());
1115 if (!(blv
->found
= !NILP (tem1
)))
1116 tem1
= blv
->defcell
;
1118 /* Load the new binding. */
1119 set_blv_valcell (blv
, tem1
);
1121 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1125 /* Find the value of a symbol, returning Qunbound if it's not bound.
1126 This is helpful for code which just wants to get a variable's value
1127 if it has one, without signaling an error.
1128 Note that it must not be possible to quit
1129 within this function. Great care is required for this. */
1132 find_symbol_value (Lisp_Object symbol
)
1134 struct Lisp_Symbol
*sym
;
1136 CHECK_SYMBOL (symbol
);
1137 sym
= XSYMBOL (symbol
);
1140 switch (sym
->redirect
)
1142 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1143 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1144 case SYMBOL_LOCALIZED
:
1146 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1147 swap_in_symval_forwarding (sym
, blv
);
1148 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1151 case SYMBOL_FORWARDED
:
1152 return do_symval_forwarding (SYMBOL_FWD (sym
));
1153 default: emacs_abort ();
1157 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1158 doc
: /* Return SYMBOL's value. Error if that is void.
1159 Note that if `lexical-binding' is in effect, this returns the
1160 global value outside of any lexical scope. */)
1161 (Lisp_Object symbol
)
1165 val
= find_symbol_value (symbol
);
1166 if (!EQ (val
, Qunbound
))
1169 xsignal1 (Qvoid_variable
, symbol
);
1172 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1173 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1174 (register Lisp_Object symbol
, Lisp_Object newval
)
1176 set_internal (symbol
, newval
, Qnil
, 0);
1180 /* Store the value NEWVAL into SYMBOL.
1181 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1182 (nil stands for the current buffer/frame).
1184 If BINDFLAG is false, then if this symbol is supposed to become
1185 local in every buffer where it is set, then we make it local.
1186 If BINDFLAG is true, we don't do that. */
1189 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1192 bool voide
= EQ (newval
, Qunbound
);
1193 struct Lisp_Symbol
*sym
;
1196 /* If restoring in a dead buffer, do nothing. */
1197 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1200 CHECK_SYMBOL (symbol
);
1201 if (SYMBOL_CONSTANT_P (symbol
))
1203 if (NILP (Fkeywordp (symbol
))
1204 || !EQ (newval
, Fsymbol_value (symbol
)))
1205 xsignal1 (Qsetting_constant
, symbol
);
1207 /* Allow setting keywords to their own value. */
1211 sym
= XSYMBOL (symbol
);
1214 switch (sym
->redirect
)
1216 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1217 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1218 case SYMBOL_LOCALIZED
:
1220 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1223 if (blv
->frame_local
)
1224 where
= selected_frame
;
1226 XSETBUFFER (where
, current_buffer
);
1228 /* If the current buffer is not the buffer whose binding is
1229 loaded, or if there may be frame-local bindings and the frame
1230 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1231 the default binding is loaded, the loaded binding may be the
1233 if (!EQ (blv
->where
, where
)
1234 /* Also unload a global binding (if the var is local_if_set). */
1235 || (EQ (blv
->valcell
, blv
->defcell
)))
1237 /* The currently loaded binding is not necessarily valid.
1238 We need to unload it, and choose a new binding. */
1240 /* Write out `realvalue' to the old loaded binding. */
1242 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1244 /* Find the new binding. */
1245 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1246 tem1
= Fassq (symbol
,
1248 ? XFRAME (where
)->param_alist
1249 : BVAR (XBUFFER (where
), local_var_alist
)));
1250 set_blv_where (blv
, where
);
1255 /* This buffer still sees the default value. */
1257 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1258 or if this is `let' rather than `set',
1259 make CURRENT-ALIST-ELEMENT point to itself,
1260 indicating that we're seeing the default value.
1261 Likewise if the variable has been let-bound
1262 in the current buffer. */
1263 if (bindflag
|| !blv
->local_if_set
1264 || let_shadows_buffer_binding_p (sym
))
1267 tem1
= blv
->defcell
;
1269 /* If it's a local_if_set, being set not bound,
1270 and we're not within a let that was made for this buffer,
1271 create a new buffer-local binding for the variable.
1272 That means, give this buffer a new assoc for a local value
1273 and load that binding. */
1276 /* local_if_set is only supported for buffer-local
1277 bindings, not for frame-local bindings. */
1278 eassert (!blv
->frame_local
);
1279 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1280 bset_local_var_alist
1282 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1286 /* Record which binding is now loaded. */
1287 set_blv_valcell (blv
, tem1
);
1290 /* Store the new value in the cons cell. */
1291 set_blv_value (blv
, newval
);
1296 /* If storing void (making the symbol void), forward only through
1297 buffer-local indicator, not through Lisp_Objfwd, etc. */
1300 store_symval_forwarding (blv
->fwd
, newval
,
1302 ? XBUFFER (where
) : current_buffer
);
1306 case SYMBOL_FORWARDED
:
1309 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1310 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1311 if (BUFFER_OBJFWDP (innercontents
))
1313 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1314 int idx
= PER_BUFFER_IDX (offset
);
1317 && !let_shadows_buffer_binding_p (sym
))
1318 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1322 { /* If storing void (making the symbol void), forward only through
1323 buffer-local indicator, not through Lisp_Objfwd, etc. */
1324 sym
->redirect
= SYMBOL_PLAINVAL
;
1325 SET_SYMBOL_VAL (sym
, newval
);
1328 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1331 default: emacs_abort ();
1336 /* Access or set a buffer-local symbol's default value. */
1338 /* Return the default value of SYMBOL, but don't check for voidness.
1339 Return Qunbound if it is void. */
1342 default_value (Lisp_Object symbol
)
1344 struct Lisp_Symbol
*sym
;
1346 CHECK_SYMBOL (symbol
);
1347 sym
= XSYMBOL (symbol
);
1350 switch (sym
->redirect
)
1352 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1353 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1354 case SYMBOL_LOCALIZED
:
1356 /* If var is set up for a buffer that lacks a local value for it,
1357 the current value is nominally the default value.
1358 But the `realvalue' slot may be more up to date, since
1359 ordinary setq stores just that slot. So use that. */
1360 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1361 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1362 return do_symval_forwarding (blv
->fwd
);
1364 return XCDR (blv
->defcell
);
1366 case SYMBOL_FORWARDED
:
1368 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1370 /* For a built-in buffer-local variable, get the default value
1371 rather than letting do_symval_forwarding get the current value. */
1372 if (BUFFER_OBJFWDP (valcontents
))
1374 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1375 if (PER_BUFFER_IDX (offset
) != 0)
1376 return per_buffer_default (offset
);
1379 /* For other variables, get the current value. */
1380 return do_symval_forwarding (valcontents
);
1382 default: emacs_abort ();
1386 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1387 doc
: /* Return t if SYMBOL has a non-void default value.
1388 This is the value that is seen in buffers that do not have their own values
1389 for this variable. */)
1390 (Lisp_Object symbol
)
1392 register Lisp_Object value
;
1394 value
= default_value (symbol
);
1395 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1398 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1399 doc
: /* Return SYMBOL's default value.
1400 This is the value that is seen in buffers that do not have their own values
1401 for this variable. The default value is meaningful for variables with
1402 local bindings in certain buffers. */)
1403 (Lisp_Object symbol
)
1405 Lisp_Object value
= default_value (symbol
);
1406 if (!EQ (value
, Qunbound
))
1409 xsignal1 (Qvoid_variable
, symbol
);
1412 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1413 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1414 The default value is seen in buffers that do not have their own values
1415 for this variable. */)
1416 (Lisp_Object symbol
, Lisp_Object value
)
1418 struct Lisp_Symbol
*sym
;
1420 CHECK_SYMBOL (symbol
);
1421 if (SYMBOL_CONSTANT_P (symbol
))
1423 if (NILP (Fkeywordp (symbol
))
1424 || !EQ (value
, Fdefault_value (symbol
)))
1425 xsignal1 (Qsetting_constant
, symbol
);
1427 /* Allow setting keywords to their own value. */
1430 sym
= XSYMBOL (symbol
);
1433 switch (sym
->redirect
)
1435 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1436 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1437 case SYMBOL_LOCALIZED
:
1439 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1441 /* Store new value into the DEFAULT-VALUE slot. */
1442 XSETCDR (blv
->defcell
, value
);
1444 /* If the default binding is now loaded, set the REALVALUE slot too. */
1445 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1446 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1449 case SYMBOL_FORWARDED
:
1451 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1453 /* Handle variables like case-fold-search that have special slots
1455 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1456 if (BUFFER_OBJFWDP (valcontents
))
1458 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1459 int idx
= PER_BUFFER_IDX (offset
);
1461 set_per_buffer_default (offset
, value
);
1463 /* If this variable is not always local in all buffers,
1464 set it in the buffers that don't nominally have a local value. */
1470 if (!PER_BUFFER_VALUE_P (b
, idx
))
1471 set_per_buffer_value (b
, offset
, value
);
1476 return Fset (symbol
, value
);
1478 default: emacs_abort ();
1482 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1483 doc
: /* Set the default value of variable VAR to VALUE.
1484 VAR, the variable name, is literal (not evaluated);
1485 VALUE is an expression: it is evaluated and its value returned.
1486 The default value of a variable is seen in buffers
1487 that do not have their own values for the variable.
1489 More generally, you can use multiple variables and values, as in
1490 (setq-default VAR VALUE VAR VALUE...)
1491 This sets each VAR's default value to the corresponding VALUE.
1492 The VALUE for the Nth VAR can refer to the new default values
1494 usage: (setq-default [VAR VALUE]...) */)
1497 Lisp_Object args_left
, symbol
, val
;
1498 struct gcpro gcpro1
;
1500 args_left
= val
= args
;
1503 while (CONSP (args_left
))
1505 val
= eval_sub (Fcar (XCDR (args_left
)));
1506 symbol
= XCAR (args_left
);
1507 Fset_default (symbol
, val
);
1508 args_left
= Fcdr (XCDR (args_left
));
1515 /* Lisp functions for creating and removing buffer-local variables. */
1520 union Lisp_Fwd
*fwd
;
1523 static struct Lisp_Buffer_Local_Value
*
1524 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1525 union Lisp_Val_Fwd valcontents
)
1527 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1531 XSETSYMBOL (symbol
, sym
);
1532 tem
= Fcons (symbol
, (forwarded
1533 ? do_symval_forwarding (valcontents
.fwd
)
1534 : valcontents
.value
));
1536 /* Buffer_Local_Values cannot have as realval a buffer-local
1537 or keyboard-local forwarding. */
1538 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1539 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1540 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1541 set_blv_where (blv
, Qnil
);
1542 blv
->frame_local
= 0;
1543 blv
->local_if_set
= 0;
1544 set_blv_defcell (blv
, tem
);
1545 set_blv_valcell (blv
, tem
);
1546 set_blv_found (blv
, 0);
1550 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1551 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1552 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1553 At any time, the value for the current buffer is in effect,
1554 unless the variable has never been set in this buffer,
1555 in which case the default value is in effect.
1556 Note that binding the variable with `let', or setting it while
1557 a `let'-style binding made in this buffer is in effect,
1558 does not make the variable buffer-local. Return VARIABLE.
1560 This globally affects all uses of this variable, so it belongs together with
1561 the variable declaration, rather than with its uses (if you just want to make
1562 a variable local to the current buffer for one particular use, use
1563 `make-local-variable'). Buffer-local bindings are normally cleared
1564 while setting up a new major mode, unless they have a `permanent-local'
1567 The function `default-value' gets the default value and `set-default' sets it. */)
1568 (register Lisp_Object variable
)
1570 struct Lisp_Symbol
*sym
;
1571 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1572 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1573 bool forwarded
IF_LINT (= 0);
1575 CHECK_SYMBOL (variable
);
1576 sym
= XSYMBOL (variable
);
1579 switch (sym
->redirect
)
1581 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1582 case SYMBOL_PLAINVAL
:
1583 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1584 if (EQ (valcontents
.value
, Qunbound
))
1585 valcontents
.value
= Qnil
;
1587 case SYMBOL_LOCALIZED
:
1588 blv
= SYMBOL_BLV (sym
);
1589 if (blv
->frame_local
)
1590 error ("Symbol %s may not be buffer-local",
1591 SDATA (SYMBOL_NAME (variable
)));
1593 case SYMBOL_FORWARDED
:
1594 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1595 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1596 error ("Symbol %s may not be buffer-local",
1597 SDATA (SYMBOL_NAME (variable
)));
1598 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1601 default: emacs_abort ();
1605 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1609 blv
= make_blv (sym
, forwarded
, valcontents
);
1610 sym
->redirect
= SYMBOL_LOCALIZED
;
1611 SET_SYMBOL_BLV (sym
, blv
);
1614 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1615 if (let_shadows_global_binding_p (symbol
))
1616 message ("Making %s buffer-local while let-bound!",
1617 SDATA (SYMBOL_NAME (variable
)));
1621 blv
->local_if_set
= 1;
1625 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1626 1, 1, "vMake Local Variable: ",
1627 doc
: /* Make VARIABLE have a separate value in the current buffer.
1628 Other buffers will continue to share a common default value.
1629 \(The buffer-local value of VARIABLE starts out as the same value
1630 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1633 If the variable is already arranged to become local when set,
1634 this function causes a local value to exist for this buffer,
1635 just as setting the variable would do.
1637 This function returns VARIABLE, and therefore
1638 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1641 See also `make-variable-buffer-local'.
1643 Do not use `make-local-variable' to make a hook variable buffer-local.
1644 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1645 (Lisp_Object variable
)
1648 bool forwarded
IF_LINT (= 0);
1649 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1650 struct Lisp_Symbol
*sym
;
1651 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1653 CHECK_SYMBOL (variable
);
1654 sym
= XSYMBOL (variable
);
1657 switch (sym
->redirect
)
1659 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1660 case SYMBOL_PLAINVAL
:
1661 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1662 case SYMBOL_LOCALIZED
:
1663 blv
= SYMBOL_BLV (sym
);
1664 if (blv
->frame_local
)
1665 error ("Symbol %s may not be buffer-local",
1666 SDATA (SYMBOL_NAME (variable
)));
1668 case SYMBOL_FORWARDED
:
1669 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1670 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1671 error ("Symbol %s may not be buffer-local",
1672 SDATA (SYMBOL_NAME (variable
)));
1674 default: emacs_abort ();
1678 error ("Symbol %s may not be buffer-local",
1679 SDATA (SYMBOL_NAME (variable
)));
1681 if (blv
? blv
->local_if_set
1682 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1684 tem
= Fboundp (variable
);
1685 /* Make sure the symbol has a local value in this particular buffer,
1686 by setting it to the same value it already has. */
1687 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1692 blv
= make_blv (sym
, forwarded
, valcontents
);
1693 sym
->redirect
= SYMBOL_LOCALIZED
;
1694 SET_SYMBOL_BLV (sym
, blv
);
1697 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1698 if (let_shadows_global_binding_p (symbol
))
1699 message ("Making %s local to %s while let-bound!",
1700 SDATA (SYMBOL_NAME (variable
)),
1701 SDATA (BVAR (current_buffer
, name
)));
1705 /* Make sure this buffer has its own value of symbol. */
1706 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1707 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1710 if (let_shadows_buffer_binding_p (sym
))
1711 message ("Making %s buffer-local while locally let-bound!",
1712 SDATA (SYMBOL_NAME (variable
)));
1714 /* Swap out any local binding for some other buffer, and make
1715 sure the current value is permanently recorded, if it's the
1717 find_symbol_value (variable
);
1719 bset_local_var_alist
1721 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1722 BVAR (current_buffer
, local_var_alist
)));
1724 /* Make sure symbol does not think it is set up for this buffer;
1725 force it to look once again for this buffer's value. */
1726 if (current_buffer
== XBUFFER (blv
->where
))
1727 set_blv_where (blv
, Qnil
);
1728 set_blv_found (blv
, 0);
1731 /* If the symbol forwards into a C variable, then load the binding
1732 for this buffer now. If C code modifies the variable before we
1733 load the binding in, then that new value will clobber the default
1734 binding the next time we unload it. */
1736 swap_in_symval_forwarding (sym
, blv
);
1741 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1742 1, 1, "vKill Local Variable: ",
1743 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1744 From now on the default value will apply in this buffer. Return VARIABLE. */)
1745 (register Lisp_Object variable
)
1747 register Lisp_Object tem
;
1748 struct Lisp_Buffer_Local_Value
*blv
;
1749 struct Lisp_Symbol
*sym
;
1751 CHECK_SYMBOL (variable
);
1752 sym
= XSYMBOL (variable
);
1755 switch (sym
->redirect
)
1757 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1758 case SYMBOL_PLAINVAL
: return variable
;
1759 case SYMBOL_FORWARDED
:
1761 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1762 if (BUFFER_OBJFWDP (valcontents
))
1764 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1765 int idx
= PER_BUFFER_IDX (offset
);
1769 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1770 set_per_buffer_value (current_buffer
, offset
,
1771 per_buffer_default (offset
));
1776 case SYMBOL_LOCALIZED
:
1777 blv
= SYMBOL_BLV (sym
);
1778 if (blv
->frame_local
)
1781 default: emacs_abort ();
1784 /* Get rid of this buffer's alist element, if any. */
1785 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1786 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1788 bset_local_var_alist
1790 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1792 /* If the symbol is set up with the current buffer's binding
1793 loaded, recompute its value. We have to do it now, or else
1794 forwarded objects won't work right. */
1796 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1797 if (EQ (buf
, blv
->where
))
1799 set_blv_where (blv
, Qnil
);
1801 find_symbol_value (variable
);
1808 /* Lisp functions for creating and removing buffer-local variables. */
1810 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1811 when/if this is removed. */
1813 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1814 1, 1, "vMake Variable Frame Local: ",
1815 doc
: /* Enable VARIABLE to have frame-local bindings.
1816 This does not create any frame-local bindings for VARIABLE,
1817 it just makes them possible.
1819 A frame-local binding is actually a frame parameter value.
1820 If a frame F has a value for the frame parameter named VARIABLE,
1821 that also acts as a frame-local binding for VARIABLE in F--
1822 provided this function has been called to enable VARIABLE
1823 to have frame-local bindings at all.
1825 The only way to create a frame-local binding for VARIABLE in a frame
1826 is to set the VARIABLE frame parameter of that frame. See
1827 `modify-frame-parameters' for how to set frame parameters.
1829 Note that since Emacs 23.1, variables cannot be both buffer-local and
1830 frame-local any more (buffer-local bindings used to take precedence over
1831 frame-local bindings). */)
1832 (Lisp_Object variable
)
1835 union Lisp_Val_Fwd valcontents
;
1836 struct Lisp_Symbol
*sym
;
1837 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1839 CHECK_SYMBOL (variable
);
1840 sym
= XSYMBOL (variable
);
1843 switch (sym
->redirect
)
1845 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1846 case SYMBOL_PLAINVAL
:
1847 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1848 if (EQ (valcontents
.value
, Qunbound
))
1849 valcontents
.value
= Qnil
;
1851 case SYMBOL_LOCALIZED
:
1852 if (SYMBOL_BLV (sym
)->frame_local
)
1855 error ("Symbol %s may not be frame-local",
1856 SDATA (SYMBOL_NAME (variable
)));
1857 case SYMBOL_FORWARDED
:
1858 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1859 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1860 error ("Symbol %s may not be frame-local",
1861 SDATA (SYMBOL_NAME (variable
)));
1863 default: emacs_abort ();
1867 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1869 blv
= make_blv (sym
, forwarded
, valcontents
);
1870 blv
->frame_local
= 1;
1871 sym
->redirect
= SYMBOL_LOCALIZED
;
1872 SET_SYMBOL_BLV (sym
, blv
);
1875 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1876 if (let_shadows_global_binding_p (symbol
))
1877 message ("Making %s frame-local while let-bound!",
1878 SDATA (SYMBOL_NAME (variable
)));
1883 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1885 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1886 BUFFER defaults to the current buffer. */)
1887 (register Lisp_Object variable
, Lisp_Object buffer
)
1889 register struct buffer
*buf
;
1890 struct Lisp_Symbol
*sym
;
1893 buf
= current_buffer
;
1896 CHECK_BUFFER (buffer
);
1897 buf
= XBUFFER (buffer
);
1900 CHECK_SYMBOL (variable
);
1901 sym
= XSYMBOL (variable
);
1904 switch (sym
->redirect
)
1906 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1907 case SYMBOL_PLAINVAL
: return Qnil
;
1908 case SYMBOL_LOCALIZED
:
1910 Lisp_Object tail
, elt
, tmp
;
1911 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1912 XSETBUFFER (tmp
, buf
);
1913 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1915 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1916 return blv_found (blv
) ? Qt
: Qnil
;
1918 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1921 if (EQ (variable
, XCAR (elt
)))
1923 eassert (!blv
->frame_local
);
1929 case SYMBOL_FORWARDED
:
1931 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1932 if (BUFFER_OBJFWDP (valcontents
))
1934 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1935 int idx
= PER_BUFFER_IDX (offset
);
1936 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1941 default: emacs_abort ();
1945 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1947 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1948 BUFFER defaults to the current buffer.
1950 More precisely, return non-nil if either VARIABLE already has a local
1951 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1952 `make-variable-buffer-local'). */)
1953 (register Lisp_Object variable
, Lisp_Object buffer
)
1955 struct Lisp_Symbol
*sym
;
1957 CHECK_SYMBOL (variable
);
1958 sym
= XSYMBOL (variable
);
1961 switch (sym
->redirect
)
1963 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1964 case SYMBOL_PLAINVAL
: return Qnil
;
1965 case SYMBOL_LOCALIZED
:
1967 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1968 if (blv
->local_if_set
)
1970 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1971 return Flocal_variable_p (variable
, buffer
);
1973 case SYMBOL_FORWARDED
:
1974 /* All BUFFER_OBJFWD slots become local if they are set. */
1975 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1976 default: emacs_abort ();
1980 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1982 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1983 If the current binding is buffer-local, the value is the current buffer.
1984 If the current binding is frame-local, the value is the selected frame.
1985 If the current binding is global (the default), the value is nil. */)
1986 (register Lisp_Object variable
)
1988 struct Lisp_Symbol
*sym
;
1990 CHECK_SYMBOL (variable
);
1991 sym
= XSYMBOL (variable
);
1993 /* Make sure the current binding is actually swapped in. */
1994 find_symbol_value (variable
);
1997 switch (sym
->redirect
)
1999 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2000 case SYMBOL_PLAINVAL
: return Qnil
;
2001 case SYMBOL_FORWARDED
:
2003 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2004 if (KBOARD_OBJFWDP (valcontents
))
2005 return Fframe_terminal (selected_frame
);
2006 else if (!BUFFER_OBJFWDP (valcontents
))
2010 case SYMBOL_LOCALIZED
:
2011 /* For a local variable, record both the symbol and which
2012 buffer's or frame's value we are saving. */
2013 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2014 return Fcurrent_buffer ();
2015 else if (sym
->redirect
== SYMBOL_LOCALIZED
2016 && blv_found (SYMBOL_BLV (sym
)))
2017 return SYMBOL_BLV (sym
)->where
;
2020 default: emacs_abort ();
2024 /* This code is disabled now that we use the selected frame to return
2025 keyboard-local-values. */
2027 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2029 DEFUN ("terminal-local-value", Fterminal_local_value
,
2030 Sterminal_local_value
, 2, 2, 0,
2031 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2032 If SYMBOL is not a terminal-local variable, then return its normal
2033 value, like `symbol-value'.
2035 TERMINAL may be a terminal object, a frame, or nil (meaning the
2036 selected frame's terminal device). */)
2037 (Lisp_Object symbol
, Lisp_Object terminal
)
2040 struct terminal
*t
= get_terminal (terminal
, 1);
2041 push_kboard (t
->kboard
);
2042 result
= Fsymbol_value (symbol
);
2047 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2048 Sset_terminal_local_value
, 3, 3, 0,
2049 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2050 If VARIABLE is not a terminal-local variable, then set its normal
2051 binding, like `set'.
2053 TERMINAL may be a terminal object, a frame, or nil (meaning the
2054 selected frame's terminal device). */)
2055 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2058 struct terminal
*t
= get_terminal (terminal
, 1);
2059 push_kboard (d
->kboard
);
2060 result
= Fset (symbol
, value
);
2066 /* Find the function at the end of a chain of symbol function indirections. */
2068 /* If OBJECT is a symbol, find the end of its function chain and
2069 return the value found there. If OBJECT is not a symbol, just
2070 return it. If there is a cycle in the function chain, signal a
2071 cyclic-function-indirection error.
2073 This is like Findirect_function, except that it doesn't signal an
2074 error if the chain ends up unbound. */
2076 indirect_function (register Lisp_Object object
)
2078 Lisp_Object tortoise
, hare
;
2080 hare
= tortoise
= object
;
2084 if (!SYMBOLP (hare
) || NILP (hare
))
2086 hare
= SYMBOL_FUNCTION (hare
);
2087 if (!SYMBOLP (hare
) || NILP (hare
))
2089 hare
= SYMBOL_FUNCTION (hare
);
2091 tortoise
= SYMBOL_FUNCTION (tortoise
);
2093 if (EQ (hare
, tortoise
))
2094 xsignal1 (Qcyclic_function_indirection
, object
);
2100 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2101 doc
: /* Return the function at the end of OBJECT's function chain.
2102 If OBJECT is not a symbol, just return it. Otherwise, follow all
2103 function indirections to find the final function binding and return it.
2104 If the final symbol in the chain is unbound, signal a void-function error.
2105 Optional arg NOERROR non-nil means to return nil instead of signaling.
2106 Signal a cyclic-function-indirection error if there is a loop in the
2107 function chain of symbols. */)
2108 (register Lisp_Object object
, Lisp_Object noerror
)
2112 /* Optimize for no indirection. */
2114 if (SYMBOLP (result
) && !NILP (result
)
2115 && (result
= SYMBOL_FUNCTION (result
), SYMBOLP (result
)))
2116 result
= indirect_function (result
);
2121 xsignal1 (Qvoid_function
, object
);
2126 /* Extract and set vector and string elements. */
2128 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2129 doc
: /* Return the element of ARRAY at index IDX.
2130 ARRAY may be a vector, a string, a char-table, a bool-vector,
2131 or a byte-code object. IDX starts at 0. */)
2132 (register Lisp_Object array
, Lisp_Object idx
)
2134 register EMACS_INT idxval
;
2137 idxval
= XINT (idx
);
2138 if (STRINGP (array
))
2141 ptrdiff_t idxval_byte
;
2143 if (idxval
< 0 || idxval
>= SCHARS (array
))
2144 args_out_of_range (array
, idx
);
2145 if (! STRING_MULTIBYTE (array
))
2146 return make_number ((unsigned char) SREF (array
, idxval
));
2147 idxval_byte
= string_char_to_byte (array
, idxval
);
2149 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2150 return make_number (c
);
2152 else if (BOOL_VECTOR_P (array
))
2154 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2155 args_out_of_range (array
, idx
);
2156 return bool_vector_ref (array
, idxval
);
2158 else if (CHAR_TABLE_P (array
))
2160 CHECK_CHARACTER (idx
);
2161 return CHAR_TABLE_REF (array
, idxval
);
2166 if (VECTORP (array
))
2167 size
= ASIZE (array
);
2168 else if (COMPILEDP (array
))
2169 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2171 wrong_type_argument (Qarrayp
, array
);
2173 if (idxval
< 0 || idxval
>= size
)
2174 args_out_of_range (array
, idx
);
2175 return AREF (array
, idxval
);
2179 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2180 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2181 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2182 bool-vector. IDX starts at 0. */)
2183 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2185 register EMACS_INT idxval
;
2188 idxval
= XINT (idx
);
2189 CHECK_ARRAY (array
, Qarrayp
);
2190 CHECK_IMPURE (array
);
2192 if (VECTORP (array
))
2194 if (idxval
< 0 || idxval
>= ASIZE (array
))
2195 args_out_of_range (array
, idx
);
2196 ASET (array
, idxval
, newelt
);
2198 else if (BOOL_VECTOR_P (array
))
2200 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2201 args_out_of_range (array
, idx
);
2202 bool_vector_set (array
, idxval
, !NILP (newelt
));
2204 else if (CHAR_TABLE_P (array
))
2206 CHECK_CHARACTER (idx
);
2207 CHAR_TABLE_SET (array
, idxval
, newelt
);
2213 if (idxval
< 0 || idxval
>= SCHARS (array
))
2214 args_out_of_range (array
, idx
);
2215 CHECK_CHARACTER (newelt
);
2216 c
= XFASTINT (newelt
);
2218 if (STRING_MULTIBYTE (array
))
2220 ptrdiff_t idxval_byte
, nbytes
;
2221 int prev_bytes
, new_bytes
;
2222 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2224 nbytes
= SBYTES (array
);
2225 idxval_byte
= string_char_to_byte (array
, idxval
);
2226 p1
= SDATA (array
) + idxval_byte
;
2227 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2228 new_bytes
= CHAR_STRING (c
, p0
);
2229 if (prev_bytes
!= new_bytes
)
2231 /* We must relocate the string data. */
2232 ptrdiff_t nchars
= SCHARS (array
);
2234 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2236 memcpy (str
, SDATA (array
), nbytes
);
2237 allocate_string_data (XSTRING (array
), nchars
,
2238 nbytes
+ new_bytes
- prev_bytes
);
2239 memcpy (SDATA (array
), str
, idxval_byte
);
2240 p1
= SDATA (array
) + idxval_byte
;
2241 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2242 nbytes
- (idxval_byte
+ prev_bytes
));
2244 clear_string_char_byte_cache ();
2251 if (! SINGLE_BYTE_CHAR_P (c
))
2255 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2256 if (SREF (array
, i
) >= 0x80)
2257 args_out_of_range (array
, newelt
);
2258 /* ARRAY is an ASCII string. Convert it to a multibyte
2259 string, and try `aset' again. */
2260 STRING_SET_MULTIBYTE (array
);
2261 return Faset (array
, idx
, newelt
);
2263 SSET (array
, idxval
, c
);
2270 /* Arithmetic functions */
2273 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2275 double f1
= 0, f2
= 0;
2278 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2279 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2281 if (FLOATP (num1
) || FLOATP (num2
))
2284 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2285 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2291 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2295 case ARITH_NOTEQUAL
:
2296 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2301 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2305 case ARITH_LESS_OR_EQUAL
:
2306 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2311 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2315 case ARITH_GRTR_OR_EQUAL
:
2316 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2326 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2327 enum Arith_Comparison comparison
)
2330 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2332 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2338 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2339 doc
: /* Return t if args, all numbers or markers, are equal.
2340 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2341 (ptrdiff_t nargs
, Lisp_Object
*args
)
2343 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2346 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2347 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2348 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2349 (ptrdiff_t nargs
, Lisp_Object
*args
)
2351 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2354 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2355 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2356 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2357 (ptrdiff_t nargs
, Lisp_Object
*args
)
2359 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2362 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2363 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2364 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2365 (ptrdiff_t nargs
, Lisp_Object
*args
)
2367 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2370 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2371 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2372 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2373 (ptrdiff_t nargs
, Lisp_Object
*args
)
2375 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2378 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2379 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2380 (register Lisp_Object num1
, Lisp_Object num2
)
2382 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2385 /* Convert the cons-of-integers, integer, or float value C to an
2386 unsigned value with maximum value MAX. Signal an error if C does not
2387 have a valid format or is out of range. */
2389 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2392 uintmax_t val
IF_LINT (= 0);
2395 valid
= 0 <= XINT (c
);
2398 else if (FLOATP (c
))
2400 double d
= XFLOAT_DATA (c
);
2402 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2408 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2410 uintmax_t top
= XFASTINT (XCAR (c
));
2411 Lisp_Object rest
= XCDR (c
);
2412 if (top
<= UINTMAX_MAX
>> 24 >> 16
2414 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2415 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2417 uintmax_t mid
= XFASTINT (XCAR (rest
));
2418 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2421 else if (top
<= UINTMAX_MAX
>> 16)
2425 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2427 val
= top
<< 16 | XFASTINT (rest
);
2433 if (! (valid
&& val
<= max
))
2434 error ("Not an in-range integer, float, or cons of integers");
2438 /* Convert the cons-of-integers, integer, or float value C to a signed
2439 value with extrema MIN and MAX. Signal an error if C does not have
2440 a valid format or is out of range. */
2442 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2445 intmax_t val
IF_LINT (= 0);
2451 else if (FLOATP (c
))
2453 double d
= XFLOAT_DATA (c
);
2455 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2461 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2463 intmax_t top
= XINT (XCAR (c
));
2464 Lisp_Object rest
= XCDR (c
);
2465 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2467 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2468 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2470 intmax_t mid
= XFASTINT (XCAR (rest
));
2471 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2474 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2478 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2480 val
= top
<< 16 | XFASTINT (rest
);
2486 if (! (valid
&& min
<= val
&& val
<= max
))
2487 error ("Not an in-range integer, float, or cons of integers");
2491 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2492 doc
: /* Return the decimal representation of NUMBER as a string.
2493 Uses a minus sign if negative.
2494 NUMBER may be an integer or a floating point number. */)
2495 (Lisp_Object number
)
2497 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2500 CHECK_NUMBER_OR_FLOAT (number
);
2502 if (FLOATP (number
))
2503 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2505 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2507 return make_unibyte_string (buffer
, len
);
2510 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2511 doc
: /* Parse STRING as a decimal number and return the number.
2512 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2513 STRING cannot be parsed as an integer or floating point number.
2515 If BASE, interpret STRING as a number in that base. If BASE isn't
2516 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2517 If the base used is not 10, STRING is always parsed as an integer. */)
2518 (register Lisp_Object string
, Lisp_Object base
)
2524 CHECK_STRING (string
);
2530 CHECK_NUMBER (base
);
2531 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2532 xsignal1 (Qargs_out_of_range
, base
);
2536 p
= SSDATA (string
);
2537 while (*p
== ' ' || *p
== '\t')
2540 val
= string_to_number (p
, b
, 1);
2541 return NILP (val
) ? make_number (0) : val
;
2557 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2558 ptrdiff_t, Lisp_Object
*);
2560 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2563 ptrdiff_t argnum
, ok_args
;
2564 EMACS_INT accum
= 0;
2565 EMACS_INT next
, ok_accum
;
2586 for (argnum
= 0; argnum
< nargs
; argnum
++)
2594 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2596 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2599 return float_arith_driver (ok_accum
, ok_args
, code
,
2602 next
= XINT (args
[argnum
]);
2606 if (INT_ADD_OVERFLOW (accum
, next
))
2614 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2619 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2622 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2624 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2626 accum
= ab
& INTMASK
;
2637 xsignal0 (Qarith_error
);
2651 if (!argnum
|| next
> accum
)
2655 if (!argnum
|| next
< accum
)
2661 XSETINT (val
, accum
);
2666 #define isnan(x) ((x) != (x))
2669 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2670 ptrdiff_t nargs
, Lisp_Object
*args
)
2672 register Lisp_Object val
;
2675 for (; argnum
< nargs
; argnum
++)
2677 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2678 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2682 next
= XFLOAT_DATA (val
);
2686 args
[argnum
] = val
; /* runs into a compiler bug. */
2687 next
= XINT (args
[argnum
]);
2695 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2705 if (! IEEE_FLOATING_POINT
&& next
== 0)
2706 xsignal0 (Qarith_error
);
2713 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2715 if (!argnum
|| isnan (next
) || next
> accum
)
2719 if (!argnum
|| isnan (next
) || next
< accum
)
2725 return make_float (accum
);
2729 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2730 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2731 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2732 (ptrdiff_t nargs
, Lisp_Object
*args
)
2734 return arith_driver (Aadd
, nargs
, args
);
2737 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2738 doc
: /* Negate number or subtract numbers or markers and return the result.
2739 With one arg, negates it. With more than one arg,
2740 subtracts all but the first from the first.
2741 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2742 (ptrdiff_t nargs
, Lisp_Object
*args
)
2744 return arith_driver (Asub
, nargs
, args
);
2747 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2748 doc
: /* Return product of any number of arguments, which are numbers or markers.
2749 usage: (* &rest NUMBERS-OR-MARKERS) */)
2750 (ptrdiff_t nargs
, Lisp_Object
*args
)
2752 return arith_driver (Amult
, nargs
, args
);
2755 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2756 doc
: /* Return first argument divided by all the remaining arguments.
2757 The arguments must be numbers or markers.
2758 usage: (/ DIVIDEND &rest DIVISORS) */)
2759 (ptrdiff_t nargs
, Lisp_Object
*args
)
2762 for (argnum
= 2; argnum
< nargs
; argnum
++)
2763 if (FLOATP (args
[argnum
]))
2764 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2765 return arith_driver (Adiv
, nargs
, args
);
2768 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2769 doc
: /* Return remainder of X divided by Y.
2770 Both must be integers or markers. */)
2771 (register Lisp_Object x
, Lisp_Object y
)
2775 CHECK_NUMBER_COERCE_MARKER (x
);
2776 CHECK_NUMBER_COERCE_MARKER (y
);
2779 xsignal0 (Qarith_error
);
2781 XSETINT (val
, XINT (x
) % XINT (y
));
2785 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2786 doc
: /* Return X modulo Y.
2787 The result falls between zero (inclusive) and Y (exclusive).
2788 Both X and Y must be numbers or markers. */)
2789 (register Lisp_Object x
, Lisp_Object y
)
2794 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2795 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2797 if (FLOATP (x
) || FLOATP (y
))
2798 return fmod_float (x
, y
);
2804 xsignal0 (Qarith_error
);
2808 /* If the "remainder" comes out with the wrong sign, fix it. */
2809 if (i2
< 0 ? i1
> 0 : i1
< 0)
2816 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2817 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2818 The value is always a number; markers are converted to numbers.
2819 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2820 (ptrdiff_t nargs
, Lisp_Object
*args
)
2822 return arith_driver (Amax
, nargs
, args
);
2825 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2826 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2827 The value is always a number; markers are converted to numbers.
2828 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2829 (ptrdiff_t nargs
, Lisp_Object
*args
)
2831 return arith_driver (Amin
, nargs
, args
);
2834 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2835 doc
: /* Return bitwise-and of all the arguments.
2836 Arguments may be integers, or markers converted to integers.
2837 usage: (logand &rest INTS-OR-MARKERS) */)
2838 (ptrdiff_t nargs
, Lisp_Object
*args
)
2840 return arith_driver (Alogand
, nargs
, args
);
2843 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2844 doc
: /* Return bitwise-or of all the arguments.
2845 Arguments may be integers, or markers converted to integers.
2846 usage: (logior &rest INTS-OR-MARKERS) */)
2847 (ptrdiff_t nargs
, Lisp_Object
*args
)
2849 return arith_driver (Alogior
, nargs
, args
);
2852 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2853 doc
: /* Return bitwise-exclusive-or of all the arguments.
2854 Arguments may be integers, or markers converted to integers.
2855 usage: (logxor &rest INTS-OR-MARKERS) */)
2856 (ptrdiff_t nargs
, Lisp_Object
*args
)
2858 return arith_driver (Alogxor
, nargs
, args
);
2861 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2862 doc
: /* Return VALUE with its bits shifted left by COUNT.
2863 If COUNT is negative, shifting is actually to the right.
2864 In this case, the sign bit is duplicated. */)
2865 (register Lisp_Object value
, Lisp_Object count
)
2867 register Lisp_Object val
;
2869 CHECK_NUMBER (value
);
2870 CHECK_NUMBER (count
);
2872 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2874 else if (XINT (count
) > 0)
2875 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2876 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2877 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2879 XSETINT (val
, XINT (value
) >> -XINT (count
));
2883 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2884 doc
: /* Return VALUE with its bits shifted left by COUNT.
2885 If COUNT is negative, shifting is actually to the right.
2886 In this case, zeros are shifted in on the left. */)
2887 (register Lisp_Object value
, Lisp_Object count
)
2889 register Lisp_Object val
;
2891 CHECK_NUMBER (value
);
2892 CHECK_NUMBER (count
);
2894 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2896 else if (XINT (count
) > 0)
2897 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2898 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2901 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2905 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2906 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2907 Markers are converted to integers. */)
2908 (register Lisp_Object number
)
2910 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2912 if (FLOATP (number
))
2913 return (make_float (1.0 + XFLOAT_DATA (number
)));
2915 XSETINT (number
, XINT (number
) + 1);
2919 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2920 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2921 Markers are converted to integers. */)
2922 (register Lisp_Object number
)
2924 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2926 if (FLOATP (number
))
2927 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2929 XSETINT (number
, XINT (number
) - 1);
2933 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2934 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2935 (register Lisp_Object number
)
2937 CHECK_NUMBER (number
);
2938 XSETINT (number
, ~XINT (number
));
2942 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2943 doc
: /* Return the byteorder for the machine.
2944 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2945 lowercase l) for small endian machines. */)
2948 unsigned i
= 0x04030201;
2949 int order
= *(char *)&i
== 1 ? 108 : 66;
2951 return make_number (order
);
2954 /* Because we round up the bool vector allocate size to word_size
2955 units, we can safely read past the "end" of the vector in the
2956 operations below. These extra bits are always zero. */
2959 bool_vector_spare_mask (EMACS_INT nr_bits
)
2961 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2964 /* Info about unsigned long long, falling back on unsigned long
2965 if unsigned long long is not available. */
2967 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2968 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2969 # define ULL_MAX ULLONG_MAX
2971 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
2972 # define ULL_MAX ULONG_MAX
2973 # define count_one_bits_ll count_one_bits_l
2974 # define count_trailing_zeros_ll count_trailing_zeros_l
2977 /* Shift VAL right by the width of an unsigned long long.
2978 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
2981 shift_right_ull (bits_word w
)
2983 /* Pacify bogus GCC warning about shift count exceeding type width. */
2984 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
2988 /* Return the number of 1 bits in W. */
2991 count_one_bits_word (bits_word w
)
2993 if (BITS_WORD_MAX
<= UINT_MAX
)
2994 return count_one_bits (w
);
2995 else if (BITS_WORD_MAX
<= ULONG_MAX
)
2996 return count_one_bits_l (w
);
2999 int i
= 0, count
= 0;
3000 while (count
+= count_one_bits_ll (w
),
3001 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3002 w
= shift_right_ull (w
);
3007 enum bool_vector_op
{ bool_vector_exclusive_or
,
3009 bool_vector_intersection
,
3010 bool_vector_set_difference
,
3011 bool_vector_subsetp
};
3014 bool_vector_binop_driver (Lisp_Object a
,
3017 enum bool_vector_op op
)
3020 bits_word
*adata
, *bdata
, *destdata
;
3024 CHECK_BOOL_VECTOR (a
);
3025 CHECK_BOOL_VECTOR (b
);
3027 nr_bits
= bool_vector_size (a
);
3028 if (bool_vector_size (b
) != nr_bits
)
3029 wrong_length_argument (a
, b
, dest
);
3031 nr_words
= bool_vector_words (nr_bits
);
3032 adata
= bool_vector_data (a
);
3033 bdata
= bool_vector_data (b
);
3037 dest
= make_uninit_bool_vector (nr_bits
);
3038 destdata
= bool_vector_data (dest
);
3042 CHECK_BOOL_VECTOR (dest
);
3043 destdata
= bool_vector_data (dest
);
3044 if (bool_vector_size (dest
) != nr_bits
)
3045 wrong_length_argument (a
, b
, dest
);
3049 case bool_vector_exclusive_or
:
3050 for (; i
< nr_words
; i
++)
3051 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3055 case bool_vector_subsetp
:
3056 for (; i
< nr_words
; i
++)
3057 if (adata
[i
] &~ bdata
[i
])
3061 case bool_vector_union
:
3062 for (; i
< nr_words
; i
++)
3063 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3067 case bool_vector_intersection
:
3068 for (; i
< nr_words
; i
++)
3069 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3073 case bool_vector_set_difference
:
3074 for (; i
< nr_words
; i
++)
3075 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3086 case bool_vector_exclusive_or
:
3087 for (; i
< nr_words
; i
++)
3088 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3091 case bool_vector_union
:
3092 for (; i
< nr_words
; i
++)
3093 destdata
[i
] = adata
[i
] | bdata
[i
];
3096 case bool_vector_intersection
:
3097 for (; i
< nr_words
; i
++)
3098 destdata
[i
] = adata
[i
] & bdata
[i
];
3101 case bool_vector_set_difference
:
3102 for (; i
< nr_words
; i
++)
3103 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3113 /* PRECONDITION must be true. Return VALUE. This odd construction
3114 works around a bogus GCC diagnostic "shift count >= width of type". */
3117 pre_value (bool precondition
, int value
)
3119 eassume (precondition
);
3120 return precondition
? value
: 0;
3123 /* Compute the number of trailing zero bits in val. If val is zero,
3124 return the number of bits in val. */
3126 count_trailing_zero_bits (bits_word val
)
3128 if (BITS_WORD_MAX
== UINT_MAX
)
3129 return count_trailing_zeros (val
);
3130 if (BITS_WORD_MAX
== ULONG_MAX
)
3131 return count_trailing_zeros_l (val
);
3132 if (BITS_WORD_MAX
== ULL_MAX
)
3133 return count_trailing_zeros_ll (val
);
3135 /* The rest of this code is for the unlikely platform where bits_word differs
3136 in width from unsigned int, unsigned long, and unsigned long long. */
3137 val
|= ~ BITS_WORD_MAX
;
3138 if (BITS_WORD_MAX
<= UINT_MAX
)
3139 return count_trailing_zeros (val
);
3140 if (BITS_WORD_MAX
<= ULONG_MAX
)
3141 return count_trailing_zeros_l (val
);
3146 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3147 count
+= BITS_PER_ULL
)
3150 return count
+ count_trailing_zeros_ll (val
);
3151 val
= shift_right_ull (val
);
3154 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3155 && BITS_WORD_MAX
== (bits_word
) -1)
3156 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3157 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3158 return count
+ count_trailing_zeros_ll (val
);
3163 bits_word_to_host_endian (bits_word val
)
3165 #ifndef WORDS_BIGENDIAN
3168 if (BITS_WORD_MAX
>> 31 == 1)
3169 return bswap_32 (val
);
3170 # if HAVE_UNSIGNED_LONG_LONG
3171 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3172 return bswap_64 (val
);
3177 for (i
= 0; i
< sizeof val
; i
++)
3179 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3180 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3181 val
= val
>> 1 >> (CHAR_BIT
- 1);
3188 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3189 Sbool_vector_exclusive_or
, 2, 3, 0,
3190 doc
: /* Return A ^ B, bitwise exclusive or.
3191 If optional third argument C is given, store result into C.
3192 A, B, and C must be bool vectors of the same length.
3193 Return the destination vector if it changed or nil otherwise. */)
3194 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3196 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3199 DEFUN ("bool-vector-union", Fbool_vector_union
,
3200 Sbool_vector_union
, 2, 3, 0,
3201 doc
: /* Return A | B, bitwise or.
3202 If optional third argument C is given, store result into C.
3203 A, B, and C must be bool vectors of the same length.
3204 Return the destination vector if it changed or nil otherwise. */)
3205 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3207 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3210 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3211 Sbool_vector_intersection
, 2, 3, 0,
3212 doc
: /* Return A & B, bitwise and.
3213 If optional third argument C is given, store result into C.
3214 A, B, and C must be bool vectors of the same length.
3215 Return the destination vector if it changed or nil otherwise. */)
3216 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3218 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3221 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3222 Sbool_vector_set_difference
, 2, 3, 0,
3223 doc
: /* Return A &~ B, set difference.
3224 If optional third argument C is given, store result into C.
3225 A, B, and C must be bool vectors of the same length.
3226 Return the destination vector if it changed or nil otherwise. */)
3227 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3229 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3232 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3233 Sbool_vector_subsetp
, 2, 2, 0,
3234 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3235 A and B must be bool vectors of the same length. */)
3236 (Lisp_Object a
, Lisp_Object b
)
3238 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3241 DEFUN ("bool-vector-not", Fbool_vector_not
,
3242 Sbool_vector_not
, 1, 2, 0,
3243 doc
: /* Compute ~A, set complement.
3244 If optional second argument B is given, store result into B.
3245 A and B must be bool vectors of the same length.
3246 Return the destination vector. */)
3247 (Lisp_Object a
, Lisp_Object b
)
3250 bits_word
*bdata
, *adata
;
3253 CHECK_BOOL_VECTOR (a
);
3254 nr_bits
= bool_vector_size (a
);
3257 b
= make_uninit_bool_vector (nr_bits
);
3260 CHECK_BOOL_VECTOR (b
);
3261 if (bool_vector_size (b
) != nr_bits
)
3262 wrong_length_argument (a
, b
, Qnil
);
3265 bdata
= bool_vector_data (b
);
3266 adata
= bool_vector_data (a
);
3268 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3269 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3271 if (nr_bits
% BITS_PER_BITS_WORD
)
3273 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3275 mword
&= bool_vector_spare_mask (nr_bits
);
3276 bdata
[i
] = bits_word_to_host_endian (mword
);
3282 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3283 Sbool_vector_count_population
, 1, 1, 0,
3284 doc
: /* Count how many elements in A are t.
3285 A is a bool vector. To count A's nil elements, subtract the return
3286 value from A's length. */)
3292 ptrdiff_t i
, nwords
;
3294 CHECK_BOOL_VECTOR (a
);
3296 nr_bits
= bool_vector_size (a
);
3297 nwords
= bool_vector_words (nr_bits
);
3299 adata
= bool_vector_data (a
);
3301 for (i
= 0; i
< nwords
; i
++)
3302 count
+= count_one_bits_word (adata
[i
]);
3304 return make_number (count
);
3307 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3308 Sbool_vector_count_consecutive
, 3, 3, 0,
3309 doc
: /* Count how many consecutive elements in A equal B starting at I.
3310 A is a bool vector, B is t or nil, and I is an index into A. */)
3311 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3318 bits_word mword
; /* Machine word. */
3319 ptrdiff_t pos
, pos0
;
3322 CHECK_BOOL_VECTOR (a
);
3325 nr_bits
= bool_vector_size (a
);
3326 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3327 args_out_of_range (a
, i
);
3329 adata
= bool_vector_data (a
);
3330 nr_words
= bool_vector_words (nr_bits
);
3331 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3332 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3335 /* By XORing with twiddle, we transform the problem of "count
3336 consecutive equal values" into "count the zero bits". The latter
3337 operation usually has hardware support. */
3338 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3340 /* Scan the remainder of the mword at the current offset. */
3341 if (pos
< nr_words
&& offset
!= 0)
3343 mword
= bits_word_to_host_endian (adata
[pos
]);
3347 /* Do not count the pad bits. */
3348 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3350 count
= count_trailing_zero_bits (mword
);
3352 if (count
+ offset
< BITS_PER_BITS_WORD
)
3353 return make_number (count
);
3356 /* Scan whole words until we either reach the end of the vector or
3357 find an mword that doesn't completely match. twiddle is
3358 endian-independent. */
3360 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3362 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3366 /* If we stopped because of a mismatch, see how many bits match
3367 in the current mword. */
3368 mword
= bits_word_to_host_endian (adata
[pos
]);
3370 count
+= count_trailing_zero_bits (mword
);
3372 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3374 /* If we hit the end, we might have overshot our count. Reduce
3375 the total by the number of spare bits at the end of the
3377 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3380 return make_number (count
);
3387 Lisp_Object error_tail
, arith_tail
;
3391 DEFSYM (Qquote
, "quote");
3392 DEFSYM (Qlambda
, "lambda");
3393 DEFSYM (Qsubr
, "subr");
3394 DEFSYM (Qerror_conditions
, "error-conditions");
3395 DEFSYM (Qerror_message
, "error-message");
3396 DEFSYM (Qtop_level
, "top-level");
3398 DEFSYM (Qerror
, "error");
3399 DEFSYM (Quser_error
, "user-error");
3400 DEFSYM (Qquit
, "quit");
3401 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3402 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3403 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3404 DEFSYM (Qvoid_function
, "void-function");
3405 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3406 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3407 DEFSYM (Qvoid_variable
, "void-variable");
3408 DEFSYM (Qsetting_constant
, "setting-constant");
3409 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3411 DEFSYM (Qinvalid_function
, "invalid-function");
3412 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3413 DEFSYM (Qno_catch
, "no-catch");
3414 DEFSYM (Qend_of_file
, "end-of-file");
3415 DEFSYM (Qarith_error
, "arith-error");
3416 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3417 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3418 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3419 DEFSYM (Qtext_read_only
, "text-read-only");
3420 DEFSYM (Qmark_inactive
, "mark-inactive");
3422 DEFSYM (Qlistp
, "listp");
3423 DEFSYM (Qconsp
, "consp");
3424 DEFSYM (Qsymbolp
, "symbolp");
3425 DEFSYM (Qkeywordp
, "keywordp");
3426 DEFSYM (Qintegerp
, "integerp");
3427 DEFSYM (Qnatnump
, "natnump");
3428 DEFSYM (Qwholenump
, "wholenump");
3429 DEFSYM (Qstringp
, "stringp");
3430 DEFSYM (Qarrayp
, "arrayp");
3431 DEFSYM (Qsequencep
, "sequencep");
3432 DEFSYM (Qbufferp
, "bufferp");
3433 DEFSYM (Qvectorp
, "vectorp");
3434 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3435 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3436 DEFSYM (Qmarkerp
, "markerp");
3437 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3438 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3439 DEFSYM (Qboundp
, "boundp");
3440 DEFSYM (Qfboundp
, "fboundp");
3442 DEFSYM (Qfloatp
, "floatp");
3443 DEFSYM (Qnumberp
, "numberp");
3444 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3446 DEFSYM (Qchar_table_p
, "char-table-p");
3447 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3449 DEFSYM (Qsubrp
, "subrp");
3450 DEFSYM (Qunevalled
, "unevalled");
3451 DEFSYM (Qmany
, "many");
3453 DEFSYM (Qcdr
, "cdr");
3455 /* Handle automatic advice activation. */
3456 DEFSYM (Qad_advice_info
, "ad-advice-info");
3457 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3459 error_tail
= pure_cons (Qerror
, Qnil
);
3461 /* ERROR is used as a signaler for random errors for which nothing else is
3464 Fput (Qerror
, Qerror_conditions
,
3466 Fput (Qerror
, Qerror_message
,
3467 build_pure_c_string ("error"));
3469 #define PUT_ERROR(sym, tail, msg) \
3470 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3471 Fput (sym, Qerror_message, build_pure_c_string (msg))
3473 PUT_ERROR (Qquit
, Qnil
, "Quit");
3475 PUT_ERROR (Quser_error
, error_tail
, "");
3476 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3477 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3478 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3479 PUT_ERROR (Qvoid_function
, error_tail
,
3480 "Symbol's function definition is void");
3481 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3482 "Symbol's chain of function indirections contains a loop");
3483 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3484 "Symbol's chain of variable indirections contains a loop");
3485 DEFSYM (Qcircular_list
, "circular-list");
3486 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3487 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3488 PUT_ERROR (Qsetting_constant
, error_tail
,
3489 "Attempt to set a constant symbol");
3490 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3491 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3492 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3493 "Wrong number of arguments");
3494 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3495 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3497 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3498 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3499 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3501 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3502 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3503 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3504 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3505 "Text is read-only");
3507 DEFSYM (Qrange_error
, "range-error");
3508 DEFSYM (Qdomain_error
, "domain-error");
3509 DEFSYM (Qsingularity_error
, "singularity-error");
3510 DEFSYM (Qoverflow_error
, "overflow-error");
3511 DEFSYM (Qunderflow_error
, "underflow-error");
3513 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3515 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3517 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3518 "Arithmetic singularity error");
3520 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3521 "Arithmetic overflow error");
3522 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3523 "Arithmetic underflow error");
3527 staticpro (&Qunbound
);
3529 /* Types that type-of returns. */
3530 DEFSYM (Qinteger
, "integer");
3531 DEFSYM (Qsymbol
, "symbol");
3532 DEFSYM (Qstring
, "string");
3533 DEFSYM (Qcons
, "cons");
3534 DEFSYM (Qmarker
, "marker");
3535 DEFSYM (Qoverlay
, "overlay");
3536 DEFSYM (Qfloat
, "float");
3537 DEFSYM (Qwindow_configuration
, "window-configuration");
3538 DEFSYM (Qprocess
, "process");
3539 DEFSYM (Qwindow
, "window");
3540 DEFSYM (Qcompiled_function
, "compiled-function");
3541 DEFSYM (Qbuffer
, "buffer");
3542 DEFSYM (Qframe
, "frame");
3543 DEFSYM (Qvector
, "vector");
3544 DEFSYM (Qchar_table
, "char-table");
3545 DEFSYM (Qbool_vector
, "bool-vector");
3546 DEFSYM (Qhash_table
, "hash-table");
3547 DEFSYM (Qmisc
, "misc");
3549 DEFSYM (Qdefun
, "defun");
3551 DEFSYM (Qfont_spec
, "font-spec");
3552 DEFSYM (Qfont_entity
, "font-entity");
3553 DEFSYM (Qfont_object
, "font-object");
3555 DEFSYM (Qinteractive_form
, "interactive-form");
3556 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3558 set_symbol_function (Qwholenump
, SYMBOL_FUNCTION (Qnatnump
));
3560 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3561 doc
: /* The largest value that is representable in a Lisp integer. */);
3562 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3563 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3565 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3566 doc
: /* The smallest value that is representable in a Lisp integer. */);
3567 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3568 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;