1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 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/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
37 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
38 static Lisp_Object Qsubr
;
39 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
40 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
41 static Lisp_Object Qwrong_type_argument
;
42 Lisp_Object Qvoid_variable
, Qvoid_function
;
43 static Lisp_Object Qcyclic_function_indirection
;
44 static Lisp_Object Qcyclic_variable_indirection
;
45 Lisp_Object Qcircular_list
;
46 static Lisp_Object Qsetting_constant
;
47 Lisp_Object Qinvalid_read_syntax
;
48 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
49 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
50 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
51 Lisp_Object Qtext_read_only
;
53 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
54 static Lisp_Object Qnatnump
;
55 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
56 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
57 Lisp_Object Qbool_vector_p
;
58 Lisp_Object Qbuffer_or_string_p
;
59 static Lisp_Object Qkeywordp
, Qboundp
;
61 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
64 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
66 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
67 Lisp_Object Qrange_error
, Qoverflow_error
;
70 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
72 Lisp_Object Qinteger
, Qsymbol
;
73 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
75 static Lisp_Object Qoverlay
, Qwindow_configuration
;
76 static Lisp_Object Qprocess
, Qmarker
;
77 static Lisp_Object Qcompiled_function
, Qframe
;
79 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
80 static Lisp_Object Qsubrp
;
81 static Lisp_Object Qmany
, Qunevalled
;
82 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
83 static Lisp_Object Qdefun
;
85 Lisp_Object Qinteractive_form
;
86 static Lisp_Object Qdefalias_fset_function
;
88 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
91 BOOLFWDP (union Lisp_Fwd
*a
)
93 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
96 INTFWDP (union Lisp_Fwd
*a
)
98 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
101 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
103 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
106 OBJFWDP (union Lisp_Fwd
*a
)
108 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
111 static struct Lisp_Boolfwd
*
112 XBOOLFWD (union Lisp_Fwd
*a
)
114 eassert (BOOLFWDP (a
));
115 return &a
->u_boolfwd
;
117 static struct Lisp_Kboard_Objfwd
*
118 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
120 eassert (KBOARD_OBJFWDP (a
));
121 return &a
->u_kboard_objfwd
;
123 static struct Lisp_Intfwd
*
124 XINTFWD (union Lisp_Fwd
*a
)
126 eassert (INTFWDP (a
));
129 static struct Lisp_Objfwd
*
130 XOBJFWD (union Lisp_Fwd
*a
)
132 eassert (OBJFWDP (a
));
137 CHECK_SUBR (Lisp_Object x
)
139 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
143 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
145 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
150 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
152 return XCDR (blv
->valcell
);
156 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
158 XSETCDR (blv
->valcell
, val
);
162 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
168 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
174 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
180 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
182 /* If VALUE is not even a valid Lisp object, we'd want to abort here
183 where we can get a backtrace showing where it came from. We used
184 to try and do that by checking the tagbits, but nowadays all
185 tagbits are potentially valid. */
186 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
189 xsignal2 (Qwrong_type_argument
, predicate
, value
);
193 pure_write_error (Lisp_Object obj
)
195 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
199 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
201 xsignal2 (Qargs_out_of_range
, a1
, a2
);
205 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
207 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
211 /* Data type predicates. */
213 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
214 doc
: /* Return t if the two args are the same Lisp object. */)
215 (Lisp_Object obj1
, Lisp_Object obj2
)
222 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
223 doc
: /* Return t if OBJECT is nil. */)
231 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
232 doc
: /* Return a symbol representing the type of OBJECT.
233 The symbol returned names the object's basic type;
234 for example, (type-of 1) returns `integer'. */)
237 switch (XTYPE (object
))
252 switch (XMISCTYPE (object
))
254 case Lisp_Misc_Marker
:
256 case Lisp_Misc_Overlay
:
258 case Lisp_Misc_Float
:
263 case Lisp_Vectorlike
:
264 if (WINDOW_CONFIGURATIONP (object
))
265 return Qwindow_configuration
;
266 if (PROCESSP (object
))
268 if (WINDOWP (object
))
272 if (COMPILEDP (object
))
273 return Qcompiled_function
;
274 if (BUFFERP (object
))
276 if (CHAR_TABLE_P (object
))
278 if (BOOL_VECTOR_P (object
))
282 if (HASH_TABLE_P (object
))
284 if (FONT_SPEC_P (object
))
286 if (FONT_ENTITY_P (object
))
288 if (FONT_OBJECT_P (object
))
300 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
301 doc
: /* Return t if OBJECT is a cons cell. */)
309 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
310 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
318 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
319 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
320 Otherwise, return nil. */)
323 if (CONSP (object
) || NILP (object
))
328 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
329 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
332 if (CONSP (object
) || NILP (object
))
337 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
338 doc
: /* Return t if OBJECT is a symbol. */)
341 if (SYMBOLP (object
))
346 /* Define this in C to avoid unnecessarily consing up the symbol
348 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
349 doc
: /* Return t if OBJECT is a keyword.
350 This means that it is a symbol with a print name beginning with `:'
351 interned in the initial obarray. */)
355 && SREF (SYMBOL_NAME (object
), 0) == ':'
356 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
361 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
362 doc
: /* Return t if OBJECT is a vector. */)
365 if (VECTORP (object
))
370 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
371 doc
: /* Return t if OBJECT is a string. */)
374 if (STRINGP (object
))
379 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
381 doc
: /* Return t if OBJECT is a multibyte string.
382 Return nil if OBJECT is either a unibyte string, or not a string. */)
385 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
390 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
391 doc
: /* Return t if OBJECT is a char-table. */)
394 if (CHAR_TABLE_P (object
))
399 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
400 Svector_or_char_table_p
, 1, 1, 0,
401 doc
: /* Return t if OBJECT is a char-table or vector. */)
404 if (VECTORP (object
) || CHAR_TABLE_P (object
))
409 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
410 doc
: /* Return t if OBJECT is a bool-vector. */)
413 if (BOOL_VECTOR_P (object
))
418 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is an array (string or vector). */)
427 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
428 doc
: /* Return t if OBJECT is a sequence (list or array). */)
429 (register Lisp_Object object
)
431 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
436 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
437 doc
: /* Return t if OBJECT is an editor buffer. */)
440 if (BUFFERP (object
))
445 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
446 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
449 if (MARKERP (object
))
454 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
455 doc
: /* Return t if OBJECT is a built-in function. */)
463 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
465 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
468 if (COMPILEDP (object
))
473 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
474 doc
: /* Return t if OBJECT is a character or a string. */)
475 (register Lisp_Object object
)
477 if (CHARACTERP (object
) || STRINGP (object
))
482 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
483 doc
: /* Return t if OBJECT is an integer. */)
486 if (INTEGERP (object
))
491 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
492 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
493 (register Lisp_Object object
)
495 if (MARKERP (object
) || INTEGERP (object
))
500 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a nonnegative integer. */)
504 if (NATNUMP (object
))
509 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
510 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
513 if (NUMBERP (object
))
519 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
520 Snumber_or_marker_p
, 1, 1, 0,
521 doc
: /* Return t if OBJECT is a number or a marker. */)
524 if (NUMBERP (object
) || MARKERP (object
))
529 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
530 doc
: /* Return t if OBJECT is a floating point number. */)
539 /* Extract and set components of lists. */
541 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
542 doc
: /* Return the car of LIST. If arg is nil, return nil.
543 Error if arg is not nil and not a cons cell. See also `car-safe'.
545 See Info node `(elisp)Cons Cells' for a discussion of related basic
546 Lisp concepts such as car, cdr, cons cell and list. */)
547 (register Lisp_Object list
)
552 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
553 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
556 return CAR_SAFE (object
);
559 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
560 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
561 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
563 See Info node `(elisp)Cons Cells' for a discussion of related basic
564 Lisp concepts such as cdr, car, cons cell and list. */)
565 (register Lisp_Object list
)
570 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
571 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
574 return CDR_SAFE (object
);
577 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
578 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
579 (register Lisp_Object cell
, Lisp_Object newcar
)
583 XSETCAR (cell
, newcar
);
587 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
588 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
589 (register Lisp_Object cell
, Lisp_Object newcdr
)
593 XSETCDR (cell
, newcdr
);
597 /* Extract and set components of symbols. */
599 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
600 doc
: /* Return t if SYMBOL's value is not void.
601 Note that if `lexical-binding' is in effect, this refers to the
602 global value outside of any lexical scope. */)
603 (register Lisp_Object symbol
)
605 Lisp_Object valcontents
;
606 struct Lisp_Symbol
*sym
;
607 CHECK_SYMBOL (symbol
);
608 sym
= XSYMBOL (symbol
);
611 switch (sym
->redirect
)
613 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
614 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
615 case SYMBOL_LOCALIZED
:
617 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
619 /* In set_internal, we un-forward vars when their value is
624 swap_in_symval_forwarding (sym
, blv
);
625 valcontents
= blv_value (blv
);
629 case SYMBOL_FORWARDED
:
630 /* In set_internal, we un-forward vars when their value is
633 default: emacs_abort ();
636 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
639 /* FIXME: Make it an alias for function-symbol! */
640 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
641 doc
: /* Return t if SYMBOL's function definition is not void. */)
642 (register Lisp_Object symbol
)
644 CHECK_SYMBOL (symbol
);
645 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
648 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
649 doc
: /* Make SYMBOL's value be void.
651 (register Lisp_Object symbol
)
653 CHECK_SYMBOL (symbol
);
654 if (SYMBOL_CONSTANT_P (symbol
))
655 xsignal1 (Qsetting_constant
, symbol
);
656 Fset (symbol
, Qunbound
);
660 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
661 doc
: /* Make SYMBOL's function definition be nil.
663 (register Lisp_Object symbol
)
665 CHECK_SYMBOL (symbol
);
666 if (NILP (symbol
) || EQ (symbol
, Qt
))
667 xsignal1 (Qsetting_constant
, symbol
);
668 set_symbol_function (symbol
, Qnil
);
672 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
673 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
674 (register Lisp_Object symbol
)
676 CHECK_SYMBOL (symbol
);
677 return XSYMBOL (symbol
)->function
;
680 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
681 doc
: /* Return SYMBOL's property list. */)
682 (register Lisp_Object symbol
)
684 CHECK_SYMBOL (symbol
);
685 return XSYMBOL (symbol
)->plist
;
688 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
689 doc
: /* Return SYMBOL's name, a string. */)
690 (register Lisp_Object symbol
)
692 register Lisp_Object name
;
694 CHECK_SYMBOL (symbol
);
695 name
= SYMBOL_NAME (symbol
);
699 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
700 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
701 (register Lisp_Object symbol
, Lisp_Object definition
)
703 register Lisp_Object function
;
704 CHECK_SYMBOL (symbol
);
706 function
= XSYMBOL (symbol
)->function
;
708 if (!NILP (Vautoload_queue
) && !NILP (function
))
709 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
711 if (AUTOLOADP (function
))
712 Fput (symbol
, Qautoload
, XCDR (function
));
714 set_symbol_function (symbol
, definition
);
719 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
720 doc
: /* Set SYMBOL's function definition to DEFINITION.
721 Associates the function with the current load file, if any.
722 The optional third argument DOCSTRING specifies the documentation string
723 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
724 determined by DEFINITION.
725 The return value is undefined. */)
726 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
728 CHECK_SYMBOL (symbol
);
729 if (!NILP (Vpurify_flag
)
730 /* If `definition' is a keymap, immutable (and copying) is wrong. */
731 && !KEYMAPP (definition
))
732 definition
= Fpurecopy (definition
);
735 bool autoload
= AUTOLOADP (definition
);
736 if (NILP (Vpurify_flag
) || !autoload
)
737 { /* Only add autoload entries after dumping, because the ones before are
738 not useful and else we get loads of them from the loaddefs.el. */
740 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
741 /* Remember that the function was already an autoload. */
742 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
743 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
747 { /* Handle automatic advice activation. */
748 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
750 call2 (hook
, symbol
, definition
);
752 Ffset (symbol
, definition
);
755 if (!NILP (docstring
))
756 Fput (symbol
, Qfunction_documentation
, docstring
);
757 /* We used to return `definition', but now that `defun' and `defmacro' expand
758 to a call to `defalias', we return `symbol' for backward compatibility
763 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
764 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
765 (register Lisp_Object symbol
, Lisp_Object newplist
)
767 CHECK_SYMBOL (symbol
);
768 set_symbol_plist (symbol
, newplist
);
772 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
773 doc
: /* Return minimum and maximum number of args allowed for SUBR.
774 SUBR must be a built-in function.
775 The returned value is a pair (MIN . MAX). MIN is the minimum number
776 of args. MAX is the maximum number or the symbol `many', for a
777 function with `&rest' args, or `unevalled' for a special form. */)
780 short minargs
, maxargs
;
782 minargs
= XSUBR (subr
)->min_args
;
783 maxargs
= XSUBR (subr
)->max_args
;
784 return Fcons (make_number (minargs
),
785 maxargs
== MANY
? Qmany
786 : maxargs
== UNEVALLED
? Qunevalled
787 : make_number (maxargs
));
790 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
791 doc
: /* Return name of subroutine SUBR.
792 SUBR must be a built-in function. */)
797 name
= XSUBR (subr
)->symbol_name
;
798 return build_string (name
);
801 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
802 doc
: /* Return the interactive form of CMD or nil if none.
803 If CMD is not a command, the return value is nil.
804 Value, if non-nil, is a list \(interactive SPEC). */)
807 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
812 /* Use an `interactive-form' property if present, analogous to the
813 function-documentation property. */
815 while (SYMBOLP (fun
))
817 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
821 fun
= Fsymbol_function (fun
);
826 const char *spec
= XSUBR (fun
)->intspec
;
828 return list2 (Qinteractive
,
829 (*spec
!= '(') ? build_string (spec
) :
830 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
832 else if (COMPILEDP (fun
))
834 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
835 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
837 else if (AUTOLOADP (fun
))
838 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
839 else if (CONSP (fun
))
841 Lisp_Object funcar
= XCAR (fun
);
842 if (EQ (funcar
, Qclosure
))
843 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
844 else if (EQ (funcar
, Qlambda
))
845 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
851 /***********************************************************************
852 Getting and Setting Values of Symbols
853 ***********************************************************************/
855 /* Return the symbol holding SYMBOL's value. Signal
856 `cyclic-variable-indirection' if SYMBOL's chain of variable
857 indirections contains a loop. */
860 indirect_variable (struct Lisp_Symbol
*symbol
)
862 struct Lisp_Symbol
*tortoise
, *hare
;
864 hare
= tortoise
= symbol
;
866 while (hare
->redirect
== SYMBOL_VARALIAS
)
868 hare
= SYMBOL_ALIAS (hare
);
869 if (hare
->redirect
!= SYMBOL_VARALIAS
)
872 hare
= SYMBOL_ALIAS (hare
);
873 tortoise
= SYMBOL_ALIAS (tortoise
);
875 if (hare
== tortoise
)
878 XSETSYMBOL (tem
, symbol
);
879 xsignal1 (Qcyclic_variable_indirection
, tem
);
887 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
888 doc
: /* Return the variable at the end of OBJECT's variable chain.
889 If OBJECT is a symbol, follow its variable indirections (if any), and
890 return the variable at the end of the chain of aliases. See Info node
891 `(elisp)Variable Aliases'.
893 If OBJECT is not a symbol, just return it. If there is a loop in the
894 chain of aliases, signal a `cyclic-variable-indirection' error. */)
897 if (SYMBOLP (object
))
899 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
900 XSETSYMBOL (object
, sym
);
906 /* Given the raw contents of a symbol value cell,
907 return the Lisp value of the symbol.
908 This does not handle buffer-local variables; use
909 swap_in_symval_forwarding for that. */
912 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
914 register Lisp_Object val
;
915 switch (XFWDTYPE (valcontents
))
918 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
922 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
925 return *XOBJFWD (valcontents
)->objvar
;
927 case Lisp_Fwd_Buffer_Obj
:
928 return per_buffer_value (current_buffer
,
929 XBUFFER_OBJFWD (valcontents
)->offset
);
931 case Lisp_Fwd_Kboard_Obj
:
932 /* We used to simply use current_kboard here, but from Lisp
933 code, its value is often unexpected. It seems nicer to
934 allow constructions like this to work as intuitively expected:
936 (with-selected-frame frame
937 (define-key local-function-map "\eOP" [f1]))
939 On the other hand, this affects the semantics of
940 last-command and real-last-command, and people may rely on
941 that. I took a quick look at the Lisp codebase, and I
942 don't think anything will break. --lorentey */
943 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
944 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
945 default: emacs_abort ();
949 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
950 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
951 buffer-independent contents of the value cell: forwarded just one
952 step past the buffer-localness.
954 BUF non-zero means set the value in buffer BUF instead of the
955 current buffer. This only plays a role for per-buffer variables. */
958 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
960 switch (XFWDTYPE (valcontents
))
963 CHECK_NUMBER (newval
);
964 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
968 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
972 *XOBJFWD (valcontents
)->objvar
= newval
;
974 /* If this variable is a default for something stored
975 in the buffer itself, such as default-fill-column,
976 find the buffers that don't have local values for it
978 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
979 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
981 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
982 - (char *) &buffer_defaults
);
983 int idx
= PER_BUFFER_IDX (offset
);
985 Lisp_Object tail
, buf
;
990 FOR_EACH_LIVE_BUFFER (tail
, buf
)
992 struct buffer
*b
= XBUFFER (buf
);
994 if (! PER_BUFFER_VALUE_P (b
, idx
))
995 set_per_buffer_value (b
, offset
, newval
);
1000 case Lisp_Fwd_Buffer_Obj
:
1002 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1003 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1005 if (!NILP (predicate
) && !NILP (newval
)
1006 && NILP (call1 (predicate
, newval
)))
1007 wrong_type_argument (predicate
, newval
);
1010 buf
= current_buffer
;
1011 set_per_buffer_value (buf
, offset
, newval
);
1015 case Lisp_Fwd_Kboard_Obj
:
1017 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1018 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1019 *(Lisp_Object
*) p
= newval
;
1024 emacs_abort (); /* goto def; */
1028 /* Set up SYMBOL to refer to its global binding. This makes it safe
1029 to alter the status of other bindings. BEWARE: this may be called
1030 during the mark phase of GC, where we assume that Lisp_Object slots
1031 of BLV are marked after this function has changed them. */
1034 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1036 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1038 /* Unload the previously loaded binding. */
1040 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1042 /* Select the global binding in the symbol. */
1043 set_blv_valcell (blv
, blv
->defcell
);
1045 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1047 /* Indicate that the global binding is set up now. */
1048 set_blv_where (blv
, Qnil
);
1049 set_blv_found (blv
, 0);
1052 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1053 VALCONTENTS is the contents of its value cell,
1054 which points to a struct Lisp_Buffer_Local_Value.
1056 Return the value forwarded one step past the buffer-local stage.
1057 This could be another forwarding pointer. */
1060 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1062 register Lisp_Object tem1
;
1064 eassert (blv
== SYMBOL_BLV (symbol
));
1069 || (blv
->frame_local
1070 ? !EQ (selected_frame
, tem1
)
1071 : current_buffer
!= XBUFFER (tem1
)))
1074 /* Unload the previously loaded binding. */
1075 tem1
= blv
->valcell
;
1077 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1078 /* Choose the new binding. */
1081 XSETSYMBOL (var
, symbol
);
1082 if (blv
->frame_local
)
1084 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1085 set_blv_where (blv
, selected_frame
);
1089 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1090 set_blv_where (blv
, Fcurrent_buffer ());
1093 if (!(blv
->found
= !NILP (tem1
)))
1094 tem1
= blv
->defcell
;
1096 /* Load the new binding. */
1097 set_blv_valcell (blv
, tem1
);
1099 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1103 /* Find the value of a symbol, returning Qunbound if it's not bound.
1104 This is helpful for code which just wants to get a variable's value
1105 if it has one, without signaling an error.
1106 Note that it must not be possible to quit
1107 within this function. Great care is required for this. */
1110 find_symbol_value (Lisp_Object symbol
)
1112 struct Lisp_Symbol
*sym
;
1114 CHECK_SYMBOL (symbol
);
1115 sym
= XSYMBOL (symbol
);
1118 switch (sym
->redirect
)
1120 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1121 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1122 case SYMBOL_LOCALIZED
:
1124 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1125 swap_in_symval_forwarding (sym
, blv
);
1126 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1129 case SYMBOL_FORWARDED
:
1130 return do_symval_forwarding (SYMBOL_FWD (sym
));
1131 default: emacs_abort ();
1135 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1136 doc
: /* Return SYMBOL's value. Error if that is void.
1137 Note that if `lexical-binding' is in effect, this returns the
1138 global value outside of any lexical scope. */)
1139 (Lisp_Object symbol
)
1143 val
= find_symbol_value (symbol
);
1144 if (!EQ (val
, Qunbound
))
1147 xsignal1 (Qvoid_variable
, symbol
);
1150 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1151 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1152 (register Lisp_Object symbol
, Lisp_Object newval
)
1154 set_internal (symbol
, newval
, Qnil
, 0);
1158 /* Store the value NEWVAL into SYMBOL.
1159 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1160 (nil stands for the current buffer/frame).
1162 If BINDFLAG is false, then if this symbol is supposed to become
1163 local in every buffer where it is set, then we make it local.
1164 If BINDFLAG is true, we don't do that. */
1167 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1170 bool voide
= EQ (newval
, Qunbound
);
1171 struct Lisp_Symbol
*sym
;
1174 /* If restoring in a dead buffer, do nothing. */
1175 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1178 CHECK_SYMBOL (symbol
);
1179 if (SYMBOL_CONSTANT_P (symbol
))
1181 if (NILP (Fkeywordp (symbol
))
1182 || !EQ (newval
, Fsymbol_value (symbol
)))
1183 xsignal1 (Qsetting_constant
, symbol
);
1185 /* Allow setting keywords to their own value. */
1189 sym
= XSYMBOL (symbol
);
1192 switch (sym
->redirect
)
1194 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1195 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1196 case SYMBOL_LOCALIZED
:
1198 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1201 if (blv
->frame_local
)
1202 where
= selected_frame
;
1204 XSETBUFFER (where
, current_buffer
);
1206 /* If the current buffer is not the buffer whose binding is
1207 loaded, or if there may be frame-local bindings and the frame
1208 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1209 the default binding is loaded, the loaded binding may be the
1211 if (!EQ (blv
->where
, where
)
1212 /* Also unload a global binding (if the var is local_if_set). */
1213 || (EQ (blv
->valcell
, blv
->defcell
)))
1215 /* The currently loaded binding is not necessarily valid.
1216 We need to unload it, and choose a new binding. */
1218 /* Write out `realvalue' to the old loaded binding. */
1220 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1222 /* Find the new binding. */
1223 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1224 tem1
= Fassq (symbol
,
1226 ? XFRAME (where
)->param_alist
1227 : BVAR (XBUFFER (where
), local_var_alist
)));
1228 set_blv_where (blv
, where
);
1233 /* This buffer still sees the default value. */
1235 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1236 or if this is `let' rather than `set',
1237 make CURRENT-ALIST-ELEMENT point to itself,
1238 indicating that we're seeing the default value.
1239 Likewise if the variable has been let-bound
1240 in the current buffer. */
1241 if (bindflag
|| !blv
->local_if_set
1242 || let_shadows_buffer_binding_p (sym
))
1245 tem1
= blv
->defcell
;
1247 /* If it's a local_if_set, being set not bound,
1248 and we're not within a let that was made for this buffer,
1249 create a new buffer-local binding for the variable.
1250 That means, give this buffer a new assoc for a local value
1251 and load that binding. */
1254 /* local_if_set is only supported for buffer-local
1255 bindings, not for frame-local bindings. */
1256 eassert (!blv
->frame_local
);
1257 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1258 bset_local_var_alist
1260 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1264 /* Record which binding is now loaded. */
1265 set_blv_valcell (blv
, tem1
);
1268 /* Store the new value in the cons cell. */
1269 set_blv_value (blv
, newval
);
1274 /* If storing void (making the symbol void), forward only through
1275 buffer-local indicator, not through Lisp_Objfwd, etc. */
1278 store_symval_forwarding (blv
->fwd
, newval
,
1280 ? XBUFFER (where
) : current_buffer
);
1284 case SYMBOL_FORWARDED
:
1287 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1288 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1289 if (BUFFER_OBJFWDP (innercontents
))
1291 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1292 int idx
= PER_BUFFER_IDX (offset
);
1295 && !let_shadows_buffer_binding_p (sym
))
1296 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1300 { /* If storing void (making the symbol void), forward only through
1301 buffer-local indicator, not through Lisp_Objfwd, etc. */
1302 sym
->redirect
= SYMBOL_PLAINVAL
;
1303 SET_SYMBOL_VAL (sym
, newval
);
1306 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1309 default: emacs_abort ();
1314 /* Access or set a buffer-local symbol's default value. */
1316 /* Return the default value of SYMBOL, but don't check for voidness.
1317 Return Qunbound if it is void. */
1320 default_value (Lisp_Object symbol
)
1322 struct Lisp_Symbol
*sym
;
1324 CHECK_SYMBOL (symbol
);
1325 sym
= XSYMBOL (symbol
);
1328 switch (sym
->redirect
)
1330 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1331 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1332 case SYMBOL_LOCALIZED
:
1334 /* If var is set up for a buffer that lacks a local value for it,
1335 the current value is nominally the default value.
1336 But the `realvalue' slot may be more up to date, since
1337 ordinary setq stores just that slot. So use that. */
1338 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1339 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1340 return do_symval_forwarding (blv
->fwd
);
1342 return XCDR (blv
->defcell
);
1344 case SYMBOL_FORWARDED
:
1346 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1348 /* For a built-in buffer-local variable, get the default value
1349 rather than letting do_symval_forwarding get the current value. */
1350 if (BUFFER_OBJFWDP (valcontents
))
1352 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1353 if (PER_BUFFER_IDX (offset
) != 0)
1354 return per_buffer_default (offset
);
1357 /* For other variables, get the current value. */
1358 return do_symval_forwarding (valcontents
);
1360 default: emacs_abort ();
1364 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1365 doc
: /* Return t if SYMBOL has a non-void default value.
1366 This is the value that is seen in buffers that do not have their own values
1367 for this variable. */)
1368 (Lisp_Object symbol
)
1370 register Lisp_Object value
;
1372 value
= default_value (symbol
);
1373 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1376 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1377 doc
: /* Return SYMBOL's default value.
1378 This is the value that is seen in buffers that do not have their own values
1379 for this variable. The default value is meaningful for variables with
1380 local bindings in certain buffers. */)
1381 (Lisp_Object symbol
)
1383 Lisp_Object value
= default_value (symbol
);
1384 if (!EQ (value
, Qunbound
))
1387 xsignal1 (Qvoid_variable
, symbol
);
1390 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1391 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1392 The default value is seen in buffers that do not have their own values
1393 for this variable. */)
1394 (Lisp_Object symbol
, Lisp_Object value
)
1396 struct Lisp_Symbol
*sym
;
1398 CHECK_SYMBOL (symbol
);
1399 if (SYMBOL_CONSTANT_P (symbol
))
1401 if (NILP (Fkeywordp (symbol
))
1402 || !EQ (value
, Fdefault_value (symbol
)))
1403 xsignal1 (Qsetting_constant
, symbol
);
1405 /* Allow setting keywords to their own value. */
1408 sym
= XSYMBOL (symbol
);
1411 switch (sym
->redirect
)
1413 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1414 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1415 case SYMBOL_LOCALIZED
:
1417 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1419 /* Store new value into the DEFAULT-VALUE slot. */
1420 XSETCDR (blv
->defcell
, value
);
1422 /* If the default binding is now loaded, set the REALVALUE slot too. */
1423 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1424 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1427 case SYMBOL_FORWARDED
:
1429 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1431 /* Handle variables like case-fold-search that have special slots
1433 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1434 if (BUFFER_OBJFWDP (valcontents
))
1436 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1437 int idx
= PER_BUFFER_IDX (offset
);
1439 set_per_buffer_default (offset
, value
);
1441 /* If this variable is not always local in all buffers,
1442 set it in the buffers that don't nominally have a local value. */
1448 if (!PER_BUFFER_VALUE_P (b
, idx
))
1449 set_per_buffer_value (b
, offset
, value
);
1454 return Fset (symbol
, value
);
1456 default: emacs_abort ();
1460 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1461 doc
: /* Set the default value of variable VAR to VALUE.
1462 VAR, the variable name, is literal (not evaluated);
1463 VALUE is an expression: it is evaluated and its value returned.
1464 The default value of a variable is seen in buffers
1465 that do not have their own values for the variable.
1467 More generally, you can use multiple variables and values, as in
1468 (setq-default VAR VALUE VAR VALUE...)
1469 This sets each VAR's default value to the corresponding VALUE.
1470 The VALUE for the Nth VAR can refer to the new default values
1472 usage: (setq-default [VAR VALUE]...) */)
1475 Lisp_Object args_left
, symbol
, val
;
1476 struct gcpro gcpro1
;
1478 args_left
= val
= args
;
1481 while (CONSP (args_left
))
1483 val
= eval_sub (Fcar (XCDR (args_left
)));
1484 symbol
= XCAR (args_left
);
1485 Fset_default (symbol
, val
);
1486 args_left
= Fcdr (XCDR (args_left
));
1493 /* Lisp functions for creating and removing buffer-local variables. */
1498 union Lisp_Fwd
*fwd
;
1501 static struct Lisp_Buffer_Local_Value
*
1502 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1503 union Lisp_Val_Fwd valcontents
)
1505 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1509 XSETSYMBOL (symbol
, sym
);
1510 tem
= Fcons (symbol
, (forwarded
1511 ? do_symval_forwarding (valcontents
.fwd
)
1512 : valcontents
.value
));
1514 /* Buffer_Local_Values cannot have as realval a buffer-local
1515 or keyboard-local forwarding. */
1516 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1517 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1518 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1519 set_blv_where (blv
, Qnil
);
1520 blv
->frame_local
= 0;
1521 blv
->local_if_set
= 0;
1522 set_blv_defcell (blv
, tem
);
1523 set_blv_valcell (blv
, tem
);
1524 set_blv_found (blv
, 0);
1528 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1529 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1530 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1531 At any time, the value for the current buffer is in effect,
1532 unless the variable has never been set in this buffer,
1533 in which case the default value is in effect.
1534 Note that binding the variable with `let', or setting it while
1535 a `let'-style binding made in this buffer is in effect,
1536 does not make the variable buffer-local. Return VARIABLE.
1538 In most cases it is better to use `make-local-variable',
1539 which makes a variable local in just one buffer.
1541 The function `default-value' gets the default value and `set-default' sets it. */)
1542 (register Lisp_Object variable
)
1544 struct Lisp_Symbol
*sym
;
1545 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1546 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1547 bool forwarded
IF_LINT (= 0);
1549 CHECK_SYMBOL (variable
);
1550 sym
= XSYMBOL (variable
);
1553 switch (sym
->redirect
)
1555 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1556 case SYMBOL_PLAINVAL
:
1557 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1558 if (EQ (valcontents
.value
, Qunbound
))
1559 valcontents
.value
= Qnil
;
1561 case SYMBOL_LOCALIZED
:
1562 blv
= SYMBOL_BLV (sym
);
1563 if (blv
->frame_local
)
1564 error ("Symbol %s may not be buffer-local",
1565 SDATA (SYMBOL_NAME (variable
)));
1567 case SYMBOL_FORWARDED
:
1568 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1569 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1570 error ("Symbol %s may not be buffer-local",
1571 SDATA (SYMBOL_NAME (variable
)));
1572 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1575 default: emacs_abort ();
1579 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1583 blv
= make_blv (sym
, forwarded
, valcontents
);
1584 sym
->redirect
= SYMBOL_LOCALIZED
;
1585 SET_SYMBOL_BLV (sym
, blv
);
1588 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1589 if (let_shadows_global_binding_p (symbol
))
1590 message ("Making %s buffer-local while let-bound!",
1591 SDATA (SYMBOL_NAME (variable
)));
1595 blv
->local_if_set
= 1;
1599 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1600 1, 1, "vMake Local Variable: ",
1601 doc
: /* Make VARIABLE have a separate value in the current buffer.
1602 Other buffers will continue to share a common default value.
1603 \(The buffer-local value of VARIABLE starts out as the same value
1604 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1607 If the variable is already arranged to become local when set,
1608 this function causes a local value to exist for this buffer,
1609 just as setting the variable would do.
1611 This function returns VARIABLE, and therefore
1612 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1615 See also `make-variable-buffer-local'.
1617 Do not use `make-local-variable' to make a hook variable buffer-local.
1618 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1619 (Lisp_Object variable
)
1622 bool forwarded
IF_LINT (= 0);
1623 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1624 struct Lisp_Symbol
*sym
;
1625 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1627 CHECK_SYMBOL (variable
);
1628 sym
= XSYMBOL (variable
);
1631 switch (sym
->redirect
)
1633 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1634 case SYMBOL_PLAINVAL
:
1635 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1636 case SYMBOL_LOCALIZED
:
1637 blv
= SYMBOL_BLV (sym
);
1638 if (blv
->frame_local
)
1639 error ("Symbol %s may not be buffer-local",
1640 SDATA (SYMBOL_NAME (variable
)));
1642 case SYMBOL_FORWARDED
:
1643 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1644 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1645 error ("Symbol %s may not be buffer-local",
1646 SDATA (SYMBOL_NAME (variable
)));
1648 default: emacs_abort ();
1652 error ("Symbol %s may not be buffer-local",
1653 SDATA (SYMBOL_NAME (variable
)));
1655 if (blv
? blv
->local_if_set
1656 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1658 tem
= Fboundp (variable
);
1659 /* Make sure the symbol has a local value in this particular buffer,
1660 by setting it to the same value it already has. */
1661 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1666 blv
= make_blv (sym
, forwarded
, valcontents
);
1667 sym
->redirect
= SYMBOL_LOCALIZED
;
1668 SET_SYMBOL_BLV (sym
, blv
);
1671 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1672 if (let_shadows_global_binding_p (symbol
))
1673 message ("Making %s local to %s while let-bound!",
1674 SDATA (SYMBOL_NAME (variable
)),
1675 SDATA (BVAR (current_buffer
, name
)));
1679 /* Make sure this buffer has its own value of symbol. */
1680 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1681 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1684 if (let_shadows_buffer_binding_p (sym
))
1685 message ("Making %s buffer-local while locally let-bound!",
1686 SDATA (SYMBOL_NAME (variable
)));
1688 /* Swap out any local binding for some other buffer, and make
1689 sure the current value is permanently recorded, if it's the
1691 find_symbol_value (variable
);
1693 bset_local_var_alist
1695 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1696 BVAR (current_buffer
, local_var_alist
)));
1698 /* Make sure symbol does not think it is set up for this buffer;
1699 force it to look once again for this buffer's value. */
1700 if (current_buffer
== XBUFFER (blv
->where
))
1701 set_blv_where (blv
, Qnil
);
1702 set_blv_found (blv
, 0);
1705 /* If the symbol forwards into a C variable, then load the binding
1706 for this buffer now. If C code modifies the variable before we
1707 load the binding in, then that new value will clobber the default
1708 binding the next time we unload it. */
1710 swap_in_symval_forwarding (sym
, blv
);
1715 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1716 1, 1, "vKill Local Variable: ",
1717 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1718 From now on the default value will apply in this buffer. Return VARIABLE. */)
1719 (register Lisp_Object variable
)
1721 register Lisp_Object tem
;
1722 struct Lisp_Buffer_Local_Value
*blv
;
1723 struct Lisp_Symbol
*sym
;
1725 CHECK_SYMBOL (variable
);
1726 sym
= XSYMBOL (variable
);
1729 switch (sym
->redirect
)
1731 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1732 case SYMBOL_PLAINVAL
: return variable
;
1733 case SYMBOL_FORWARDED
:
1735 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1736 if (BUFFER_OBJFWDP (valcontents
))
1738 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1739 int idx
= PER_BUFFER_IDX (offset
);
1743 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1744 set_per_buffer_value (current_buffer
, offset
,
1745 per_buffer_default (offset
));
1750 case SYMBOL_LOCALIZED
:
1751 blv
= SYMBOL_BLV (sym
);
1752 if (blv
->frame_local
)
1755 default: emacs_abort ();
1758 /* Get rid of this buffer's alist element, if any. */
1759 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1760 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1762 bset_local_var_alist
1764 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1766 /* If the symbol is set up with the current buffer's binding
1767 loaded, recompute its value. We have to do it now, or else
1768 forwarded objects won't work right. */
1770 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1771 if (EQ (buf
, blv
->where
))
1773 set_blv_where (blv
, Qnil
);
1775 find_symbol_value (variable
);
1782 /* Lisp functions for creating and removing buffer-local variables. */
1784 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1785 when/if this is removed. */
1787 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1788 1, 1, "vMake Variable Frame Local: ",
1789 doc
: /* Enable VARIABLE to have frame-local bindings.
1790 This does not create any frame-local bindings for VARIABLE,
1791 it just makes them possible.
1793 A frame-local binding is actually a frame parameter value.
1794 If a frame F has a value for the frame parameter named VARIABLE,
1795 that also acts as a frame-local binding for VARIABLE in F--
1796 provided this function has been called to enable VARIABLE
1797 to have frame-local bindings at all.
1799 The only way to create a frame-local binding for VARIABLE in a frame
1800 is to set the VARIABLE frame parameter of that frame. See
1801 `modify-frame-parameters' for how to set frame parameters.
1803 Note that since Emacs 23.1, variables cannot be both buffer-local and
1804 frame-local any more (buffer-local bindings used to take precedence over
1805 frame-local bindings). */)
1806 (Lisp_Object variable
)
1809 union Lisp_Val_Fwd valcontents
;
1810 struct Lisp_Symbol
*sym
;
1811 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1813 CHECK_SYMBOL (variable
);
1814 sym
= XSYMBOL (variable
);
1817 switch (sym
->redirect
)
1819 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1820 case SYMBOL_PLAINVAL
:
1821 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1822 if (EQ (valcontents
.value
, Qunbound
))
1823 valcontents
.value
= Qnil
;
1825 case SYMBOL_LOCALIZED
:
1826 if (SYMBOL_BLV (sym
)->frame_local
)
1829 error ("Symbol %s may not be frame-local",
1830 SDATA (SYMBOL_NAME (variable
)));
1831 case SYMBOL_FORWARDED
:
1832 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1833 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1834 error ("Symbol %s may not be frame-local",
1835 SDATA (SYMBOL_NAME (variable
)));
1837 default: emacs_abort ();
1841 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1843 blv
= make_blv (sym
, forwarded
, valcontents
);
1844 blv
->frame_local
= 1;
1845 sym
->redirect
= SYMBOL_LOCALIZED
;
1846 SET_SYMBOL_BLV (sym
, blv
);
1849 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1850 if (let_shadows_global_binding_p (symbol
))
1851 message ("Making %s frame-local while let-bound!",
1852 SDATA (SYMBOL_NAME (variable
)));
1857 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1859 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1860 BUFFER defaults to the current buffer. */)
1861 (register Lisp_Object variable
, Lisp_Object buffer
)
1863 register struct buffer
*buf
;
1864 struct Lisp_Symbol
*sym
;
1867 buf
= current_buffer
;
1870 CHECK_BUFFER (buffer
);
1871 buf
= XBUFFER (buffer
);
1874 CHECK_SYMBOL (variable
);
1875 sym
= XSYMBOL (variable
);
1878 switch (sym
->redirect
)
1880 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1881 case SYMBOL_PLAINVAL
: return Qnil
;
1882 case SYMBOL_LOCALIZED
:
1884 Lisp_Object tail
, elt
, tmp
;
1885 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1886 XSETBUFFER (tmp
, buf
);
1887 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1889 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1890 return blv_found (blv
) ? Qt
: Qnil
;
1892 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1895 if (EQ (variable
, XCAR (elt
)))
1897 eassert (!blv
->frame_local
);
1903 case SYMBOL_FORWARDED
:
1905 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1906 if (BUFFER_OBJFWDP (valcontents
))
1908 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1909 int idx
= PER_BUFFER_IDX (offset
);
1910 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1915 default: emacs_abort ();
1919 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1921 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1922 BUFFER defaults to the current buffer.
1924 More precisely, return non-nil if either VARIABLE already has a local
1925 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1926 `make-variable-buffer-local'). */)
1927 (register Lisp_Object variable
, Lisp_Object buffer
)
1929 struct Lisp_Symbol
*sym
;
1931 CHECK_SYMBOL (variable
);
1932 sym
= XSYMBOL (variable
);
1935 switch (sym
->redirect
)
1937 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1938 case SYMBOL_PLAINVAL
: return Qnil
;
1939 case SYMBOL_LOCALIZED
:
1941 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1942 if (blv
->local_if_set
)
1944 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1945 return Flocal_variable_p (variable
, buffer
);
1947 case SYMBOL_FORWARDED
:
1948 /* All BUFFER_OBJFWD slots become local if they are set. */
1949 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1950 default: emacs_abort ();
1954 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1956 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1957 If the current binding is buffer-local, the value is the current buffer.
1958 If the current binding is frame-local, the value is the selected frame.
1959 If the current binding is global (the default), the value is nil. */)
1960 (register Lisp_Object variable
)
1962 struct Lisp_Symbol
*sym
;
1964 CHECK_SYMBOL (variable
);
1965 sym
= XSYMBOL (variable
);
1967 /* Make sure the current binding is actually swapped in. */
1968 find_symbol_value (variable
);
1971 switch (sym
->redirect
)
1973 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1974 case SYMBOL_PLAINVAL
: return Qnil
;
1975 case SYMBOL_FORWARDED
:
1977 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1978 if (KBOARD_OBJFWDP (valcontents
))
1979 return Fframe_terminal (selected_frame
);
1980 else if (!BUFFER_OBJFWDP (valcontents
))
1984 case SYMBOL_LOCALIZED
:
1985 /* For a local variable, record both the symbol and which
1986 buffer's or frame's value we are saving. */
1987 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1988 return Fcurrent_buffer ();
1989 else if (sym
->redirect
== SYMBOL_LOCALIZED
1990 && blv_found (SYMBOL_BLV (sym
)))
1991 return SYMBOL_BLV (sym
)->where
;
1994 default: emacs_abort ();
1998 /* This code is disabled now that we use the selected frame to return
1999 keyboard-local-values. */
2001 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2003 DEFUN ("terminal-local-value", Fterminal_local_value
,
2004 Sterminal_local_value
, 2, 2, 0,
2005 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2006 If SYMBOL is not a terminal-local variable, then return its normal
2007 value, like `symbol-value'.
2009 TERMINAL may be a terminal object, a frame, or nil (meaning the
2010 selected frame's terminal device). */)
2011 (Lisp_Object symbol
, Lisp_Object terminal
)
2014 struct terminal
*t
= get_terminal (terminal
, 1);
2015 push_kboard (t
->kboard
);
2016 result
= Fsymbol_value (symbol
);
2021 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2022 Sset_terminal_local_value
, 3, 3, 0,
2023 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2024 If VARIABLE is not a terminal-local variable, then set its normal
2025 binding, like `set'.
2027 TERMINAL may be a terminal object, a frame, or nil (meaning the
2028 selected frame's terminal device). */)
2029 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2032 struct terminal
*t
= get_terminal (terminal
, 1);
2033 push_kboard (d
->kboard
);
2034 result
= Fset (symbol
, value
);
2040 /* Find the function at the end of a chain of symbol function indirections. */
2042 /* If OBJECT is a symbol, find the end of its function chain and
2043 return the value found there. If OBJECT is not a symbol, just
2044 return it. If there is a cycle in the function chain, signal a
2045 cyclic-function-indirection error.
2047 This is like Findirect_function, except that it doesn't signal an
2048 error if the chain ends up unbound. */
2050 indirect_function (register Lisp_Object object
)
2052 Lisp_Object tortoise
, hare
;
2054 hare
= tortoise
= object
;
2058 if (!SYMBOLP (hare
) || NILP (hare
))
2060 hare
= XSYMBOL (hare
)->function
;
2061 if (!SYMBOLP (hare
) || NILP (hare
))
2063 hare
= XSYMBOL (hare
)->function
;
2065 tortoise
= XSYMBOL (tortoise
)->function
;
2067 if (EQ (hare
, tortoise
))
2068 xsignal1 (Qcyclic_function_indirection
, object
);
2074 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2075 doc
: /* Return the function at the end of OBJECT's function chain.
2076 If OBJECT is not a symbol, just return it. Otherwise, follow all
2077 function indirections to find the final function binding and return it.
2078 If the final symbol in the chain is unbound, signal a void-function error.
2079 Optional arg NOERROR non-nil means to return nil instead of signaling.
2080 Signal a cyclic-function-indirection error if there is a loop in the
2081 function chain of symbols. */)
2082 (register Lisp_Object object
, Lisp_Object noerror
)
2086 /* Optimize for no indirection. */
2088 if (SYMBOLP (result
) && !NILP (result
)
2089 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2090 result
= indirect_function (result
);
2095 xsignal1 (Qvoid_function
, object
);
2100 /* Extract and set vector and string elements. */
2102 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2103 doc
: /* Return the element of ARRAY at index IDX.
2104 ARRAY may be a vector, a string, a char-table, a bool-vector,
2105 or a byte-code object. IDX starts at 0. */)
2106 (register Lisp_Object array
, Lisp_Object idx
)
2108 register EMACS_INT idxval
;
2111 idxval
= XINT (idx
);
2112 if (STRINGP (array
))
2115 ptrdiff_t idxval_byte
;
2117 if (idxval
< 0 || idxval
>= SCHARS (array
))
2118 args_out_of_range (array
, idx
);
2119 if (! STRING_MULTIBYTE (array
))
2120 return make_number ((unsigned char) SREF (array
, idxval
));
2121 idxval_byte
= string_char_to_byte (array
, idxval
);
2123 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2124 return make_number (c
);
2126 else if (BOOL_VECTOR_P (array
))
2130 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2131 args_out_of_range (array
, idx
);
2133 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2134 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2136 else if (CHAR_TABLE_P (array
))
2138 CHECK_CHARACTER (idx
);
2139 return CHAR_TABLE_REF (array
, idxval
);
2144 if (VECTORP (array
))
2145 size
= ASIZE (array
);
2146 else if (COMPILEDP (array
))
2147 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2149 wrong_type_argument (Qarrayp
, array
);
2151 if (idxval
< 0 || idxval
>= size
)
2152 args_out_of_range (array
, idx
);
2153 return AREF (array
, idxval
);
2157 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2158 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2159 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2160 bool-vector. IDX starts at 0. */)
2161 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2163 register EMACS_INT idxval
;
2166 idxval
= XINT (idx
);
2167 CHECK_ARRAY (array
, Qarrayp
);
2168 CHECK_IMPURE (array
);
2170 if (VECTORP (array
))
2172 if (idxval
< 0 || idxval
>= ASIZE (array
))
2173 args_out_of_range (array
, idx
);
2174 ASET (array
, idxval
, newelt
);
2176 else if (BOOL_VECTOR_P (array
))
2180 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2181 args_out_of_range (array
, idx
);
2183 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2185 if (! NILP (newelt
))
2186 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2188 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2189 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2191 else if (CHAR_TABLE_P (array
))
2193 CHECK_CHARACTER (idx
);
2194 CHAR_TABLE_SET (array
, idxval
, newelt
);
2200 if (idxval
< 0 || idxval
>= SCHARS (array
))
2201 args_out_of_range (array
, idx
);
2202 CHECK_CHARACTER (newelt
);
2203 c
= XFASTINT (newelt
);
2205 if (STRING_MULTIBYTE (array
))
2207 ptrdiff_t idxval_byte
, nbytes
;
2208 int prev_bytes
, new_bytes
;
2209 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2211 nbytes
= SBYTES (array
);
2212 idxval_byte
= string_char_to_byte (array
, idxval
);
2213 p1
= SDATA (array
) + idxval_byte
;
2214 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2215 new_bytes
= CHAR_STRING (c
, p0
);
2216 if (prev_bytes
!= new_bytes
)
2218 /* We must relocate the string data. */
2219 ptrdiff_t nchars
= SCHARS (array
);
2221 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2223 memcpy (str
, SDATA (array
), nbytes
);
2224 allocate_string_data (XSTRING (array
), nchars
,
2225 nbytes
+ new_bytes
- prev_bytes
);
2226 memcpy (SDATA (array
), str
, idxval_byte
);
2227 p1
= SDATA (array
) + idxval_byte
;
2228 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2229 nbytes
- (idxval_byte
+ prev_bytes
));
2231 clear_string_char_byte_cache ();
2238 if (! SINGLE_BYTE_CHAR_P (c
))
2242 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2243 if (SREF (array
, i
) >= 0x80)
2244 args_out_of_range (array
, newelt
);
2245 /* ARRAY is an ASCII string. Convert it to a multibyte
2246 string, and try `aset' again. */
2247 STRING_SET_MULTIBYTE (array
);
2248 return Faset (array
, idx
, newelt
);
2250 SSET (array
, idxval
, c
);
2257 /* Arithmetic functions */
2260 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2262 double f1
= 0, f2
= 0;
2265 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2266 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2268 if (FLOATP (num1
) || FLOATP (num2
))
2271 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2272 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2278 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2282 case ARITH_NOTEQUAL
:
2283 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2288 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2292 case ARITH_LESS_OR_EQUAL
:
2293 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2298 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2302 case ARITH_GRTR_OR_EQUAL
:
2303 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2313 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2314 enum Arith_Comparison comparison
)
2316 for (ptrdiff_t argnum
= 1; argnum
< nargs
; ++argnum
)
2318 if (EQ (Qnil
, arithcompare (args
[argnum
-1], args
[argnum
], comparison
)))
2324 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2325 doc
: /* Return t if args, all numbers or markers, are equal.
2326 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2327 (ptrdiff_t nargs
, Lisp_Object
*args
)
2329 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2332 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2333 doc
: /* Return t if each arg is less than the next arg. All must be numbers or markers.
2334 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2335 (ptrdiff_t nargs
, Lisp_Object
*args
)
2337 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2340 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2341 doc
: /* Return t if each arg is greater than the next arg. All must be numbers or markers.
2342 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2343 (ptrdiff_t nargs
, Lisp_Object
*args
)
2345 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2348 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2349 doc
: /* Return t if each arg is less than or equal to the next arg.
2350 All must be numbers or markers.
2351 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2352 (ptrdiff_t nargs
, Lisp_Object
*args
)
2354 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2357 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2358 doc
: /* Return t if each arg is greater than or equal to the next arg.
2359 All must be numbers or markers.
2360 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2361 (ptrdiff_t nargs
, Lisp_Object
*args
)
2363 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2366 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2367 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2368 (register Lisp_Object num1
, Lisp_Object num2
)
2370 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2373 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2374 doc
: /* Return t if NUMBER is zero. */)
2375 (register Lisp_Object number
)
2377 CHECK_NUMBER_OR_FLOAT (number
);
2379 if (FLOATP (number
))
2381 if (XFLOAT_DATA (number
) == 0.0)
2391 /* Convert the cons-of-integers, integer, or float value C to an
2392 unsigned value with maximum value MAX. Signal an error if C does not
2393 have a valid format or is out of range. */
2395 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2398 uintmax_t val
IF_LINT (= 0);
2401 valid
= 0 <= XINT (c
);
2404 else if (FLOATP (c
))
2406 double d
= XFLOAT_DATA (c
);
2408 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2414 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2416 uintmax_t top
= XFASTINT (XCAR (c
));
2417 Lisp_Object rest
= XCDR (c
);
2418 if (top
<= UINTMAX_MAX
>> 24 >> 16
2420 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2421 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2423 uintmax_t mid
= XFASTINT (XCAR (rest
));
2424 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2427 else if (top
<= UINTMAX_MAX
>> 16)
2431 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2433 val
= top
<< 16 | XFASTINT (rest
);
2439 if (! (valid
&& val
<= max
))
2440 error ("Not an in-range integer, float, or cons of integers");
2444 /* Convert the cons-of-integers, integer, or float value C to a signed
2445 value with extrema MIN and MAX. Signal an error if C does not have
2446 a valid format or is out of range. */
2448 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2451 intmax_t val
IF_LINT (= 0);
2457 else if (FLOATP (c
))
2459 double d
= XFLOAT_DATA (c
);
2461 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2467 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2469 intmax_t top
= XINT (XCAR (c
));
2470 Lisp_Object rest
= XCDR (c
);
2471 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2473 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2474 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2476 intmax_t mid
= XFASTINT (XCAR (rest
));
2477 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2480 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2484 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2486 val
= top
<< 16 | XFASTINT (rest
);
2492 if (! (valid
&& min
<= val
&& val
<= max
))
2493 error ("Not an in-range integer, float, or cons of integers");
2497 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2498 doc
: /* Return the decimal representation of NUMBER as a string.
2499 Uses a minus sign if negative.
2500 NUMBER may be an integer or a floating point number. */)
2501 (Lisp_Object number
)
2503 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2506 CHECK_NUMBER_OR_FLOAT (number
);
2508 if (FLOATP (number
))
2509 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2511 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2513 return make_unibyte_string (buffer
, len
);
2516 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2517 doc
: /* Parse STRING as a decimal number and return the number.
2518 This parses both integers and floating point numbers.
2519 It ignores leading spaces and tabs, and all trailing chars.
2521 If BASE, interpret STRING as a number in that base. If BASE isn't
2522 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2523 If the base used is not 10, STRING is always parsed as integer. */)
2524 (register Lisp_Object string
, Lisp_Object base
)
2530 CHECK_STRING (string
);
2536 CHECK_NUMBER (base
);
2537 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2538 xsignal1 (Qargs_out_of_range
, base
);
2542 p
= SSDATA (string
);
2543 while (*p
== ' ' || *p
== '\t')
2546 val
= string_to_number (p
, b
, 1);
2547 return NILP (val
) ? make_number (0) : val
;
2563 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2564 ptrdiff_t, Lisp_Object
*);
2566 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2569 ptrdiff_t argnum
, ok_args
;
2570 EMACS_INT accum
= 0;
2571 EMACS_INT next
, ok_accum
;
2592 for (argnum
= 0; argnum
< nargs
; argnum
++)
2600 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2602 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2605 return float_arith_driver (ok_accum
, ok_args
, code
,
2608 next
= XINT (args
[argnum
]);
2612 if (INT_ADD_OVERFLOW (accum
, next
))
2620 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2625 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2628 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2630 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2632 accum
= ab
& INTMASK
;
2643 xsignal0 (Qarith_error
);
2657 if (!argnum
|| next
> accum
)
2661 if (!argnum
|| next
< accum
)
2667 XSETINT (val
, accum
);
2672 #define isnan(x) ((x) != (x))
2675 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2676 ptrdiff_t nargs
, Lisp_Object
*args
)
2678 register Lisp_Object val
;
2681 for (; argnum
< nargs
; argnum
++)
2683 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2684 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2688 next
= XFLOAT_DATA (val
);
2692 args
[argnum
] = val
; /* runs into a compiler bug. */
2693 next
= XINT (args
[argnum
]);
2701 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2711 if (! IEEE_FLOATING_POINT
&& next
== 0)
2712 xsignal0 (Qarith_error
);
2719 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2721 if (!argnum
|| isnan (next
) || next
> accum
)
2725 if (!argnum
|| isnan (next
) || next
< accum
)
2731 return make_float (accum
);
2735 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2736 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2737 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2738 (ptrdiff_t nargs
, Lisp_Object
*args
)
2740 return arith_driver (Aadd
, nargs
, args
);
2743 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2744 doc
: /* Negate number or subtract numbers or markers and return the result.
2745 With one arg, negates it. With more than one arg,
2746 subtracts all but the first from the first.
2747 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2748 (ptrdiff_t nargs
, Lisp_Object
*args
)
2750 return arith_driver (Asub
, nargs
, args
);
2753 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2754 doc
: /* Return product of any number of arguments, which are numbers or markers.
2755 usage: (* &rest NUMBERS-OR-MARKERS) */)
2756 (ptrdiff_t nargs
, Lisp_Object
*args
)
2758 return arith_driver (Amult
, nargs
, args
);
2761 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2762 doc
: /* Return first argument divided by all the remaining arguments.
2763 The arguments must be numbers or markers.
2764 usage: (/ DIVIDEND &rest DIVISORS) */)
2765 (ptrdiff_t nargs
, Lisp_Object
*args
)
2768 for (argnum
= 2; argnum
< nargs
; argnum
++)
2769 if (FLOATP (args
[argnum
]))
2770 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2771 return arith_driver (Adiv
, nargs
, args
);
2774 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2775 doc
: /* Return remainder of X divided by Y.
2776 Both must be integers or markers. */)
2777 (register Lisp_Object x
, Lisp_Object y
)
2781 CHECK_NUMBER_COERCE_MARKER (x
);
2782 CHECK_NUMBER_COERCE_MARKER (y
);
2785 xsignal0 (Qarith_error
);
2787 XSETINT (val
, XINT (x
) % XINT (y
));
2791 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2792 doc
: /* Return X modulo Y.
2793 The result falls between zero (inclusive) and Y (exclusive).
2794 Both X and Y must be numbers or markers. */)
2795 (register Lisp_Object x
, Lisp_Object y
)
2800 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2801 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2803 if (FLOATP (x
) || FLOATP (y
))
2804 return fmod_float (x
, y
);
2810 xsignal0 (Qarith_error
);
2814 /* If the "remainder" comes out with the wrong sign, fix it. */
2815 if (i2
< 0 ? i1
> 0 : i1
< 0)
2822 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2823 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2824 The value is always a number; markers are converted to numbers.
2825 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2826 (ptrdiff_t nargs
, Lisp_Object
*args
)
2828 return arith_driver (Amax
, nargs
, args
);
2831 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2832 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2833 The value is always a number; markers are converted to numbers.
2834 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2835 (ptrdiff_t nargs
, Lisp_Object
*args
)
2837 return arith_driver (Amin
, nargs
, args
);
2840 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2841 doc
: /* Return bitwise-and of all the arguments.
2842 Arguments may be integers, or markers converted to integers.
2843 usage: (logand &rest INTS-OR-MARKERS) */)
2844 (ptrdiff_t nargs
, Lisp_Object
*args
)
2846 return arith_driver (Alogand
, nargs
, args
);
2849 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2850 doc
: /* Return bitwise-or of all the arguments.
2851 Arguments may be integers, or markers converted to integers.
2852 usage: (logior &rest INTS-OR-MARKERS) */)
2853 (ptrdiff_t nargs
, Lisp_Object
*args
)
2855 return arith_driver (Alogior
, nargs
, args
);
2858 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2859 doc
: /* Return bitwise-exclusive-or of all the arguments.
2860 Arguments may be integers, or markers converted to integers.
2861 usage: (logxor &rest INTS-OR-MARKERS) */)
2862 (ptrdiff_t nargs
, Lisp_Object
*args
)
2864 return arith_driver (Alogxor
, nargs
, args
);
2867 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2868 doc
: /* Return VALUE with its bits shifted left by COUNT.
2869 If COUNT is negative, shifting is actually to the right.
2870 In this case, the sign bit is duplicated. */)
2871 (register Lisp_Object value
, Lisp_Object count
)
2873 register Lisp_Object val
;
2875 CHECK_NUMBER (value
);
2876 CHECK_NUMBER (count
);
2878 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2880 else if (XINT (count
) > 0)
2881 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2882 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2883 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2885 XSETINT (val
, XINT (value
) >> -XINT (count
));
2889 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2890 doc
: /* Return VALUE with its bits shifted left by COUNT.
2891 If COUNT is negative, shifting is actually to the right.
2892 In this case, zeros are shifted in on the left. */)
2893 (register Lisp_Object value
, Lisp_Object count
)
2895 register Lisp_Object val
;
2897 CHECK_NUMBER (value
);
2898 CHECK_NUMBER (count
);
2900 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2902 else if (XINT (count
) > 0)
2903 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2904 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2907 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2911 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2912 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2913 Markers are converted to integers. */)
2914 (register Lisp_Object number
)
2916 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2918 if (FLOATP (number
))
2919 return (make_float (1.0 + XFLOAT_DATA (number
)));
2921 XSETINT (number
, XINT (number
) + 1);
2925 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2926 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2927 Markers are converted to integers. */)
2928 (register Lisp_Object number
)
2930 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2932 if (FLOATP (number
))
2933 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2935 XSETINT (number
, XINT (number
) - 1);
2939 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2940 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2941 (register Lisp_Object number
)
2943 CHECK_NUMBER (number
);
2944 XSETINT (number
, ~XINT (number
));
2948 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2949 doc
: /* Return the byteorder for the machine.
2950 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2951 lowercase l) for small endian machines. */)
2954 unsigned i
= 0x04030201;
2955 int order
= *(char *)&i
== 1 ? 108 : 66;
2957 return make_number (order
);
2960 /* Because we round up the bool vector allocate size to word_size
2961 units, we can safely read past the "end" of the vector in the
2962 operations below. These extra bits are always zero. Also, we
2963 always allocate bool vectors with at least one size_t of storage so
2964 that we don't have to special-case empty bit vectors. */
2967 bool_vector_spare_mask (ptrdiff_t nr_bits
)
2969 eassert (nr_bits
> 0);
2970 return (((size_t) 1) << (nr_bits
% BITS_PER_SIZE_T
)) - 1;
2973 #if _MSC_VER >= 1500 && (defined _M_IX86 || defined _M_X64)
2974 # define USE_MSC_POPCOUNT
2975 # define POPCOUNT_STATIC_INLINE static inline
2976 #elif __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)
2977 # define USE_GCC_POPCOUNT
2978 # if 199901L <= __STDC_VERSION__ || !__STRICT_ANSI__
2979 # define POPCOUNT_STATIC_INLINE static inline
2982 # define NEED_GENERIC_POPCOUNT
2984 #ifndef POPCOUNT_STATIC_INLINE
2985 # define POPCOUNT_STATIC_INLINE static
2988 #ifdef USE_MSC_POPCOUNT
2989 # define NEED_GENERIC_POPCOUNT
2992 #ifdef NEED_GENERIC_POPCOUNT
2993 POPCOUNT_STATIC_INLINE
unsigned int
2994 popcount_size_t_generic (size_t val
)
2997 unsigned int count
= 0;
2999 for (j
= 0; j
< BITS_PER_SIZE_T
; ++j
)
3000 count
+= !!((((size_t) 1) << j
) & val
);
3006 #ifdef USE_MSC_POPCOUNT
3007 POPCOUNT_STATIC_INLINE
unsigned int
3008 popcount_size_t_msc (size_t val
)
3012 #pragma intrinsic __cpuid
3013 /* While gcc falls back to its own generic code if the machine on
3014 which it's running doesn't support popcount, we need to perform the
3015 detection and fallback ourselves when compiling with Microsoft's
3019 popcount_unknown_support
,
3020 popcount_use_generic
,
3021 popcount_use_intrinsic
3024 if (popcount_state
== popcount_unknown_support
)
3027 __cpuid (cpu_info
, 1);
3028 if (cpu_info
[2] & (1<<23)) /* See MSDN. */
3029 popcount_state
= popcount_use_intrinsic
;
3031 popcount_state
= popcount_use_generic
;
3034 if (popcount_state
== popcount_use_intrinsic
)
3036 # if BITS_PER_SIZE_T == 64
3037 # pragma intrinsic __popcnt64
3038 count
= __popcnt64 (val
);
3040 # pragma intrinsic __popcnt
3041 count
= __popcnt (val
);
3045 count
= popcount_size_t_generic (val
);
3049 #endif /* USE_MSC_POPCOUNT */
3051 #ifdef USE_GCC_POPCOUNT
3052 POPCOUNT_STATIC_INLINE
unsigned int
3053 popcount_size_t_gcc (size_t val
)
3055 # if BITS_PER_SIZE_T == 64
3056 return __builtin_popcountll (val
);
3058 return __builtin_popcount (val
);
3061 #endif /* USE_GCC_POPCOUNT */
3063 POPCOUNT_STATIC_INLINE
unsigned int
3064 popcount_size_t (size_t val
)
3066 #if defined USE_MSC_POPCOUNT
3067 return popcount_size_t_msc (val
);
3068 #elif defined USE_GCC_POPCOUNT
3069 return popcount_size_t_gcc (val
);
3071 return popcount_size_t_generic (val
);
3075 enum bool_vector_op
{ bool_vector_exclusive_or
,
3077 bool_vector_intersection
,
3078 bool_vector_set_difference
,
3079 bool_vector_subsetp
};
3082 bool_vector_binop_driver (Lisp_Object op1
,
3085 enum bool_vector_op op
)
3088 size_t *adata
, *bdata
, *cdata
;
3094 CHECK_BOOL_VECTOR (op1
);
3095 CHECK_BOOL_VECTOR (op2
);
3097 nr_bits
= min (XBOOL_VECTOR (op1
)->size
,
3098 XBOOL_VECTOR (op2
)->size
);
3102 dest
= Fmake_bool_vector (make_number (nr_bits
), Qnil
);
3107 CHECK_BOOL_VECTOR (dest
);
3108 nr_bits
= min (nr_bits
, XBOOL_VECTOR (dest
)->size
);
3111 eassert (nr_bits
>= 0);
3112 nr_words
= ROUNDUP (nr_bits
, BITS_PER_SIZE_T
) / BITS_PER_SIZE_T
;
3114 adata
= (size_t *) XBOOL_VECTOR (dest
)->data
;
3115 bdata
= (size_t *) XBOOL_VECTOR (op1
)->data
;
3116 cdata
= (size_t *) XBOOL_VECTOR (op2
)->data
;
3120 if (op
== bool_vector_exclusive_or
)
3121 mword
= bdata
[i
] ^ cdata
[i
];
3122 else if (op
== bool_vector_union
|| op
== bool_vector_subsetp
)
3123 mword
= bdata
[i
] | cdata
[i
];
3124 else if (op
== bool_vector_intersection
)
3125 mword
= bdata
[i
] & cdata
[i
];
3126 else if (op
== bool_vector_set_difference
)
3127 mword
= bdata
[i
] &~ cdata
[i
];
3131 changed
|= adata
[i
] ^ mword
;
3133 if (op
!= bool_vector_subsetp
)
3138 while (i
< nr_words
);
3140 return changed
? dest
: Qnil
;
3143 /* Compute the number of trailing zero bits in val. If val is zero,
3144 return the number of bits in val. */
3146 count_trailing_zero_bits (size_t val
)
3149 return CHAR_BIT
* sizeof (val
);
3151 #if defined USE_GCC_POPCOUNT && BITS_PER_SIZE_T == 64
3152 return __builtin_ctzll (val
);
3153 #elif defined USE_GCC_POPCOUNT && BITS_PER_SIZE_T == 32
3154 return __builtin_ctz (val
);
3155 #elif _MSC_VER && BITS_PER_SIZE_T == 64
3156 # pragma intrinsic _BitScanForward64
3158 /* No support test needed: support since 386. */
3159 unsigned long result
;
3160 _BitScanForward64 (&result
, val
);
3161 return (unsigned int) result
;
3163 #elif _MSC_VER && BITS_PER_SIZE_T == 32
3164 # pragma intrinsic _BitScanForward
3166 /* No support test needed: support since 386. */
3167 unsigned long result
;
3168 _BitScanForward (&result
, val
);
3169 return (unsigned int) result
;
3175 for (val
= ~val
; val
& 1; val
>>= 1)
3184 size_t_to_host_endian (size_t val
)
3186 #ifdef WORDS_BIGENDIAN
3187 # if BITS_PER_SIZE_T == 64
3188 return swap64 (val
);
3190 return swap32 (val
);
3197 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3198 Sbool_vector_exclusive_or
, 2, 3, 0,
3199 doc
: /* Compute C = A ^ B, bitwise exclusive or.
3200 A, B, and C must be bool vectors. If C is nil, allocate a new bool
3201 vector in which to store the result. Return the destination vector if
3202 it changed or nil otherwise. */
3204 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3206 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3209 DEFUN ("bool-vector-union", Fbool_vector_union
,
3210 Sbool_vector_union
, 2, 3, 0,
3211 doc
: /* Compute C = A | B, bitwise or.
3212 A, B, and C must be bool vectors. If C is nil, allocate a new bool
3213 vector in which to store the result. Return the destination vector if
3214 it changed or nil otherwise. */)
3215 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3217 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3220 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3221 Sbool_vector_intersection
, 2, 3, 0,
3222 doc
: /* Compute C = A & B, bitwise and.
3223 A, B, and C must be bool vectors. If C is nil, allocate a new bool
3224 vector in which to store the result. Return the destination vector if
3225 it changed or nil otherwise. */)
3226 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3228 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3231 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3232 Sbool_vector_set_difference
, 2, 3, 0,
3233 doc
: /* Compute C = A &~ B, set difference.
3234 A, B, and C must be bool vectors. If C is nil, allocate a new bool
3235 vector in which to store the result. Return the destination vector if
3236 it changed or nil otherwise. */)
3237 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3239 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3242 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3243 Sbool_vector_subsetp
, 2, 2, 0,
3245 (Lisp_Object a
, Lisp_Object b
)
3247 /* Like bool_vector_union, but doesn't modify b. */
3248 return bool_vector_binop_driver (b
, a
, b
, bool_vector_subsetp
);
3251 DEFUN ("bool-vector-not", Fbool_vector_not
,
3252 Sbool_vector_not
, 1, 2, 0,
3253 doc
: /* Compute B = ~A.
3254 B must be a bool vector. A must be a bool vector or nil.
3255 If A is nil, allocate a new bool vector in which to store the result.
3256 Return the destination vector. */)
3257 (Lisp_Object a
, Lisp_Object b
)
3260 size_t *bdata
, *adata
;
3264 CHECK_BOOL_VECTOR (a
);
3265 nr_bits
= XBOOL_VECTOR (a
)->size
;
3268 b
= Fmake_bool_vector (make_number (nr_bits
), Qnil
);
3271 CHECK_BOOL_VECTOR (b
);
3272 nr_bits
= min (nr_bits
, XBOOL_VECTOR (b
)->size
);
3275 bdata
= (size_t *) XBOOL_VECTOR (b
)->data
;
3276 adata
= (size_t *) XBOOL_VECTOR (a
)->data
;
3278 eassert (nr_bits
>= 0);
3280 for (i
= 0; i
< nr_bits
/ BITS_PER_SIZE_T
; i
++)
3281 bdata
[i
] = ~adata
[i
];
3283 if (nr_bits
% BITS_PER_SIZE_T
)
3285 mword
= size_t_to_host_endian (adata
[i
]);
3287 mword
&= bool_vector_spare_mask (nr_bits
);
3288 bdata
[i
] = size_t_to_host_endian (mword
);
3294 DEFUN ("bool-vector-count-matches", Fbool_vector_count_matches
,
3295 Sbool_vector_count_matches
, 2, 2, 0,
3296 doc
: /* Count how many elements in A equal B.
3297 A must be a bool vector. B is a generalized bool. */)
3298 (Lisp_Object a
, Lisp_Object b
)
3306 CHECK_BOOL_VECTOR (a
);
3308 nr_bits
= XBOOL_VECTOR (a
)->size
;
3310 match
= NILP (b
) ? (size_t) -1 : 0;
3311 adata
= (size_t *) XBOOL_VECTOR (a
)->data
;
3313 eassert (nr_bits
>= 0);
3315 for (i
= 0; i
< nr_bits
/ BITS_PER_SIZE_T
; ++i
)
3316 count
+= popcount_size_t (adata
[i
] ^ match
);
3318 /* Mask out trailing parts of final mword. */
3319 if (nr_bits
% BITS_PER_SIZE_T
)
3321 size_t mword
= adata
[i
] ^ match
;
3322 mword
= size_t_to_host_endian (mword
);
3323 count
+= popcount_size_t (mword
& bool_vector_spare_mask (nr_bits
));
3326 return make_number (count
);
3329 DEFUN ("bool-vector-count-matches-at",
3330 Fbool_vector_count_matches_at
,
3331 Sbool_vector_count_matches_at
, 3, 3, 0,
3332 doc
: /* Count how many consecutive elements in A equal B at i.
3333 A must be a bool vector. B is a generalized boolean. i is an
3334 index into the vector. */)
3335 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3342 size_t mword
; /* Machine word. */
3346 CHECK_BOOL_VECTOR (a
);
3349 nr_bits
= XBOOL_VECTOR (a
)->size
;
3350 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3351 args_out_of_range (a
, i
);
3353 adata
= (size_t *) XBOOL_VECTOR (a
)->data
;
3355 assume (nr_bits
>= 0);
3356 nr_words
= ROUNDUP (nr_bits
, BITS_PER_SIZE_T
) / BITS_PER_SIZE_T
;
3358 pos
= XFASTINT (i
) / BITS_PER_SIZE_T
;
3359 offset
= XFASTINT (i
) % BITS_PER_SIZE_T
;
3362 /* By XORing with twiddle, we transform the problem of "count
3363 consecutive equal values" into "count the zero bits". The latter
3364 operation usually has hardware support. */
3365 twiddle
= NILP (b
) ? 0 : (size_t) -1;
3367 /* Scan the remainder of the mword at the current offset. */
3368 if (pos
< nr_words
&& offset
!= 0)
3370 mword
= size_t_to_host_endian (adata
[pos
]);
3373 count
= count_trailing_zero_bits (mword
);
3374 count
= min (count
, BITS_PER_SIZE_T
- offset
);
3376 if (count
+ offset
< BITS_PER_SIZE_T
)
3377 return make_number (count
);
3380 /* Scan whole words until we either reach the end of the vector or
3381 find an mword that doesn't completely match. twiddle is
3382 endian-independent. */
3383 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3385 count
+= BITS_PER_SIZE_T
;
3391 /* If we stopped because of a mismatch, see how many bits match
3392 in the current mword. */
3393 mword
= size_t_to_host_endian (adata
[pos
]);
3395 count
+= count_trailing_zero_bits (mword
);
3397 else if (nr_bits
% BITS_PER_SIZE_T
!= 0)
3399 /* If we hit the end, we might have overshot our count. Reduce
3400 the total by the number of spare bits at the end of the
3402 count
-= BITS_PER_SIZE_T
- nr_bits
% BITS_PER_SIZE_T
;
3405 return make_number (count
);
3412 Lisp_Object error_tail
, arith_tail
;
3414 DEFSYM (Qquote
, "quote");
3415 DEFSYM (Qlambda
, "lambda");
3416 DEFSYM (Qsubr
, "subr");
3417 DEFSYM (Qerror_conditions
, "error-conditions");
3418 DEFSYM (Qerror_message
, "error-message");
3419 DEFSYM (Qtop_level
, "top-level");
3421 DEFSYM (Qerror
, "error");
3422 DEFSYM (Quser_error
, "user-error");
3423 DEFSYM (Qquit
, "quit");
3424 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3425 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3426 DEFSYM (Qvoid_function
, "void-function");
3427 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3428 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3429 DEFSYM (Qvoid_variable
, "void-variable");
3430 DEFSYM (Qsetting_constant
, "setting-constant");
3431 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3433 DEFSYM (Qinvalid_function
, "invalid-function");
3434 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3435 DEFSYM (Qno_catch
, "no-catch");
3436 DEFSYM (Qend_of_file
, "end-of-file");
3437 DEFSYM (Qarith_error
, "arith-error");
3438 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3439 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3440 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3441 DEFSYM (Qtext_read_only
, "text-read-only");
3442 DEFSYM (Qmark_inactive
, "mark-inactive");
3444 DEFSYM (Qlistp
, "listp");
3445 DEFSYM (Qconsp
, "consp");
3446 DEFSYM (Qsymbolp
, "symbolp");
3447 DEFSYM (Qkeywordp
, "keywordp");
3448 DEFSYM (Qintegerp
, "integerp");
3449 DEFSYM (Qnatnump
, "natnump");
3450 DEFSYM (Qwholenump
, "wholenump");
3451 DEFSYM (Qstringp
, "stringp");
3452 DEFSYM (Qarrayp
, "arrayp");
3453 DEFSYM (Qsequencep
, "sequencep");
3454 DEFSYM (Qbufferp
, "bufferp");
3455 DEFSYM (Qvectorp
, "vectorp");
3456 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3457 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3458 DEFSYM (Qmarkerp
, "markerp");
3459 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3460 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3461 DEFSYM (Qboundp
, "boundp");
3462 DEFSYM (Qfboundp
, "fboundp");
3464 DEFSYM (Qfloatp
, "floatp");
3465 DEFSYM (Qnumberp
, "numberp");
3466 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3468 DEFSYM (Qchar_table_p
, "char-table-p");
3469 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3471 DEFSYM (Qsubrp
, "subrp");
3472 DEFSYM (Qunevalled
, "unevalled");
3473 DEFSYM (Qmany
, "many");
3475 DEFSYM (Qcdr
, "cdr");
3477 /* Handle automatic advice activation. */
3478 DEFSYM (Qad_advice_info
, "ad-advice-info");
3479 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3481 error_tail
= pure_cons (Qerror
, Qnil
);
3483 /* ERROR is used as a signaler for random errors for which nothing else is
3486 Fput (Qerror
, Qerror_conditions
,
3488 Fput (Qerror
, Qerror_message
,
3489 build_pure_c_string ("error"));
3491 #define PUT_ERROR(sym, tail, msg) \
3492 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3493 Fput (sym, Qerror_message, build_pure_c_string (msg))
3495 PUT_ERROR (Qquit
, Qnil
, "Quit");
3497 PUT_ERROR (Quser_error
, error_tail
, "");
3498 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3499 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3500 PUT_ERROR (Qvoid_function
, error_tail
,
3501 "Symbol's function definition is void");
3502 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3503 "Symbol's chain of function indirections contains a loop");
3504 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3505 "Symbol's chain of variable indirections contains a loop");
3506 DEFSYM (Qcircular_list
, "circular-list");
3507 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3508 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3509 PUT_ERROR (Qsetting_constant
, error_tail
,
3510 "Attempt to set a constant symbol");
3511 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3512 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3513 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3514 "Wrong number of arguments");
3515 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3516 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3518 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3519 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3520 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3522 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3523 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3524 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3525 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3526 "Text is read-only");
3528 DEFSYM (Qrange_error
, "range-error");
3529 DEFSYM (Qdomain_error
, "domain-error");
3530 DEFSYM (Qsingularity_error
, "singularity-error");
3531 DEFSYM (Qoverflow_error
, "overflow-error");
3532 DEFSYM (Qunderflow_error
, "underflow-error");
3534 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3536 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3538 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3539 "Arithmetic singularity error");
3541 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3542 "Arithmetic overflow error");
3543 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3544 "Arithmetic underflow error");
3548 staticpro (&Qunbound
);
3550 /* Types that type-of returns. */
3551 DEFSYM (Qinteger
, "integer");
3552 DEFSYM (Qsymbol
, "symbol");
3553 DEFSYM (Qstring
, "string");
3554 DEFSYM (Qcons
, "cons");
3555 DEFSYM (Qmarker
, "marker");
3556 DEFSYM (Qoverlay
, "overlay");
3557 DEFSYM (Qfloat
, "float");
3558 DEFSYM (Qwindow_configuration
, "window-configuration");
3559 DEFSYM (Qprocess
, "process");
3560 DEFSYM (Qwindow
, "window");
3561 DEFSYM (Qcompiled_function
, "compiled-function");
3562 DEFSYM (Qbuffer
, "buffer");
3563 DEFSYM (Qframe
, "frame");
3564 DEFSYM (Qvector
, "vector");
3565 DEFSYM (Qchar_table
, "char-table");
3566 DEFSYM (Qbool_vector
, "bool-vector");
3567 DEFSYM (Qhash_table
, "hash-table");
3568 DEFSYM (Qmisc
, "misc");
3570 DEFSYM (Qdefun
, "defun");
3572 DEFSYM (Qfont_spec
, "font-spec");
3573 DEFSYM (Qfont_entity
, "font-entity");
3574 DEFSYM (Qfont_object
, "font-object");
3576 DEFSYM (Qinteractive_form
, "interactive-form");
3577 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3579 defsubr (&Sindirect_variable
);
3580 defsubr (&Sinteractive_form
);
3583 defsubr (&Stype_of
);
3588 defsubr (&Sintegerp
);
3589 defsubr (&Sinteger_or_marker_p
);
3590 defsubr (&Snumberp
);
3591 defsubr (&Snumber_or_marker_p
);
3593 defsubr (&Snatnump
);
3594 defsubr (&Ssymbolp
);
3595 defsubr (&Skeywordp
);
3596 defsubr (&Sstringp
);
3597 defsubr (&Smultibyte_string_p
);
3598 defsubr (&Svectorp
);
3599 defsubr (&Schar_table_p
);
3600 defsubr (&Svector_or_char_table_p
);
3601 defsubr (&Sbool_vector_p
);
3603 defsubr (&Ssequencep
);
3604 defsubr (&Sbufferp
);
3605 defsubr (&Smarkerp
);
3607 defsubr (&Sbyte_code_function_p
);
3608 defsubr (&Schar_or_string_p
);
3611 defsubr (&Scar_safe
);
3612 defsubr (&Scdr_safe
);
3615 defsubr (&Ssymbol_function
);
3616 defsubr (&Sindirect_function
);
3617 defsubr (&Ssymbol_plist
);
3618 defsubr (&Ssymbol_name
);
3619 defsubr (&Smakunbound
);
3620 defsubr (&Sfmakunbound
);
3622 defsubr (&Sfboundp
);
3624 defsubr (&Sdefalias
);
3625 defsubr (&Ssetplist
);
3626 defsubr (&Ssymbol_value
);
3628 defsubr (&Sdefault_boundp
);
3629 defsubr (&Sdefault_value
);
3630 defsubr (&Sset_default
);
3631 defsubr (&Ssetq_default
);
3632 defsubr (&Smake_variable_buffer_local
);
3633 defsubr (&Smake_local_variable
);
3634 defsubr (&Skill_local_variable
);
3635 defsubr (&Smake_variable_frame_local
);
3636 defsubr (&Slocal_variable_p
);
3637 defsubr (&Slocal_variable_if_set_p
);
3638 defsubr (&Svariable_binding_locus
);
3639 #if 0 /* XXX Remove this. --lorentey */
3640 defsubr (&Sterminal_local_value
);
3641 defsubr (&Sset_terminal_local_value
);
3645 defsubr (&Snumber_to_string
);
3646 defsubr (&Sstring_to_number
);
3647 defsubr (&Seqlsign
);
3670 defsubr (&Sbyteorder
);
3671 defsubr (&Ssubr_arity
);
3672 defsubr (&Ssubr_name
);
3674 defsubr (&Sbool_vector_exclusive_or
);
3675 defsubr (&Sbool_vector_union
);
3676 defsubr (&Sbool_vector_intersection
);
3677 defsubr (&Sbool_vector_set_difference
);
3678 defsubr (&Sbool_vector_not
);
3679 defsubr (&Sbool_vector_subsetp
);
3680 defsubr (&Sbool_vector_count_matches
);
3681 defsubr (&Sbool_vector_count_matches_at
);
3683 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3685 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3686 doc
: /* The largest value that is representable in a Lisp integer. */);
3687 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3688 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3690 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3691 doc
: /* The smallest value that is representable in a Lisp integer. */);
3692 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3693 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;