1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 Free Software
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or (at
10 your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include <count-one-bits.h>
26 #include <count-trailing-zeros.h>
31 #include "character.h"
37 static void swap_in_symval_forwarding (struct Lisp_Symbol
*,
38 struct Lisp_Buffer_Local_Value
*);
41 BOOLFWDP (union Lisp_Fwd
*a
)
43 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
46 INTFWDP (union Lisp_Fwd
*a
)
48 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
51 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
53 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
56 OBJFWDP (union Lisp_Fwd
*a
)
58 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
61 static struct Lisp_Boolfwd
*
62 XBOOLFWD (union Lisp_Fwd
*a
)
64 eassert (BOOLFWDP (a
));
67 static struct Lisp_Kboard_Objfwd
*
68 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
70 eassert (KBOARD_OBJFWDP (a
));
71 return &a
->u_kboard_objfwd
;
73 static struct Lisp_Intfwd
*
74 XINTFWD (union Lisp_Fwd
*a
)
76 eassert (INTFWDP (a
));
79 static struct Lisp_Objfwd
*
80 XOBJFWD (union Lisp_Fwd
*a
)
82 eassert (OBJFWDP (a
));
87 CHECK_SUBR (Lisp_Object x
)
89 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
93 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
95 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
100 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
102 return XCDR (blv
->valcell
);
106 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
108 XSETCDR (blv
->valcell
, val
);
112 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
118 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
124 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
129 static _Noreturn
void
130 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
132 Lisp_Object size1
= make_number (bool_vector_size (a1
));
133 Lisp_Object size2
= make_number (bool_vector_size (a2
));
135 xsignal2 (Qwrong_length_argument
, size1
, size2
);
137 xsignal3 (Qwrong_length_argument
, size1
, size2
,
138 make_number (bool_vector_size (a3
)));
142 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
144 /* If VALUE is not even a valid Lisp object, we'd want to abort here
145 where we can get a backtrace showing where it came from. We used
146 to try and do that by checking the tagbits, but nowadays all
147 tagbits are potentially valid. */
148 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
151 xsignal2 (Qwrong_type_argument
, predicate
, value
);
155 pure_write_error (Lisp_Object obj
)
157 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
161 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
163 xsignal2 (Qargs_out_of_range
, a1
, a2
);
167 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
169 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
173 /* Data type predicates. */
175 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
176 doc
: /* Return t if the two args are the same Lisp object. */
178 (Lisp_Object obj1
, Lisp_Object obj2
)
185 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
186 doc
: /* Return t if OBJECT is nil, and return nil otherwise. */
195 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
196 doc
: /* Return a symbol representing the type of OBJECT.
197 The symbol returned names the object's basic type;
198 for example, (type-of 1) returns `integer'. */)
201 switch (XTYPE (object
))
216 switch (XMISCTYPE (object
))
218 case Lisp_Misc_Marker
:
220 case Lisp_Misc_Overlay
:
222 case Lisp_Misc_Float
:
224 case Lisp_Misc_Finalizer
:
227 case Lisp_Misc_User_Ptr
:
234 case Lisp_Vectorlike
:
235 if (WINDOW_CONFIGURATIONP (object
))
236 return Qwindow_configuration
;
237 if (PROCESSP (object
))
239 if (WINDOWP (object
))
243 if (COMPILEDP (object
))
244 return Qcompiled_function
;
245 if (BUFFERP (object
))
247 if (CHAR_TABLE_P (object
))
249 if (BOOL_VECTOR_P (object
))
253 if (HASH_TABLE_P (object
))
255 if (FONT_SPEC_P (object
))
257 if (FONT_ENTITY_P (object
))
259 if (FONT_OBJECT_P (object
))
271 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
272 doc
: /* Return t if OBJECT is a cons cell. */
281 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
282 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */
291 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
292 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
293 Otherwise, return nil. */
297 if (CONSP (object
) || NILP (object
))
302 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
303 doc
: /* Return t if OBJECT is not a list. Lists include nil. */
307 if (CONSP (object
) || NILP (object
))
312 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
313 doc
: /* Return t if OBJECT is a symbol. */
317 if (SYMBOLP (object
))
322 /* Define this in C to avoid unnecessarily consing up the symbol
324 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a keyword.
326 This means that it is a symbol with a print name beginning with `:'
327 interned in the initial obarray. */)
331 && SREF (SYMBOL_NAME (object
), 0) == ':'
332 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
337 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
338 doc
: /* Return t if OBJECT is a vector. */)
341 if (VECTORP (object
))
346 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
347 doc
: /* Return t if OBJECT is a string. */
351 if (STRINGP (object
))
356 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
358 doc
: /* Return t if OBJECT is a multibyte string.
359 Return nil if OBJECT is either a unibyte string, or not a string. */)
362 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
367 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a char-table. */)
371 if (CHAR_TABLE_P (object
))
376 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
377 Svector_or_char_table_p
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is a char-table or vector. */)
381 if (VECTORP (object
) || CHAR_TABLE_P (object
))
386 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is a bool-vector. */)
390 if (BOOL_VECTOR_P (object
))
395 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
396 doc
: /* Return t if OBJECT is an array (string or vector). */)
404 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is a sequence (list or array). */)
406 (register Lisp_Object object
)
408 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
413 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
414 doc
: /* Return t if OBJECT is an editor buffer. */)
417 if (BUFFERP (object
))
422 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
423 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
426 if (MARKERP (object
))
432 DEFUN ("user-ptrp", Fuser_ptrp
, Suser_ptrp
, 1, 1, 0,
433 doc
: /* Return t if OBJECT is a module user pointer. */)
436 if (USER_PTRP (object
))
442 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
443 doc
: /* Return t if OBJECT is a built-in function. */)
451 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
453 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
456 if (COMPILEDP (object
))
461 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
462 doc
: /* Return t if OBJECT is a character or a string. */
464 (register Lisp_Object object
)
466 if (CHARACTERP (object
) || STRINGP (object
))
471 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
472 doc
: /* Return t if OBJECT is an integer. */
476 if (INTEGERP (object
))
481 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
482 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
483 (register Lisp_Object object
)
485 if (MARKERP (object
) || INTEGERP (object
))
490 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
491 doc
: /* Return t if OBJECT is a nonnegative integer. */
495 if (NATNUMP (object
))
500 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a number (floating point or integer). */
505 if (NUMBERP (object
))
511 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
512 Snumber_or_marker_p
, 1, 1, 0,
513 doc
: /* Return t if OBJECT is a number or a marker. */)
516 if (NUMBERP (object
) || MARKERP (object
))
521 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
522 doc
: /* Return t if OBJECT is a floating point number. */
532 /* Extract and set components of lists. */
534 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
535 doc
: /* Return the car of LIST. If arg is nil, return nil.
536 Error if arg is not nil and not a cons cell. See also `car-safe'.
538 See Info node `(elisp)Cons Cells' for a discussion of related basic
539 Lisp concepts such as car, cdr, cons cell and list. */)
540 (register Lisp_Object list
)
545 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
546 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
549 return CAR_SAFE (object
);
552 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
553 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
554 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
556 See Info node `(elisp)Cons Cells' for a discussion of related basic
557 Lisp concepts such as cdr, car, cons cell and list. */)
558 (register Lisp_Object list
)
563 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
564 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
567 return CDR_SAFE (object
);
570 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
571 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
572 (register Lisp_Object cell
, Lisp_Object newcar
)
575 CHECK_IMPURE (cell
, XCONS (cell
));
576 XSETCAR (cell
, newcar
);
580 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
581 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
582 (register Lisp_Object cell
, Lisp_Object newcdr
)
585 CHECK_IMPURE (cell
, XCONS (cell
));
586 XSETCDR (cell
, newcdr
);
590 /* Extract and set components of symbols. */
592 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
593 doc
: /* Return t if SYMBOL's value is not void.
594 Note that if `lexical-binding' is in effect, this refers to the
595 global value outside of any lexical scope. */)
596 (register Lisp_Object symbol
)
598 Lisp_Object valcontents
;
599 struct Lisp_Symbol
*sym
;
600 CHECK_SYMBOL (symbol
);
601 sym
= XSYMBOL (symbol
);
604 switch (sym
->redirect
)
606 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
607 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
608 case SYMBOL_LOCALIZED
:
610 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
612 /* In set_internal, we un-forward vars when their value is
617 swap_in_symval_forwarding (sym
, blv
);
618 valcontents
= blv_value (blv
);
622 case SYMBOL_FORWARDED
:
623 /* In set_internal, we un-forward vars when their value is
626 default: emacs_abort ();
629 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
632 /* FIXME: It has been previously suggested to make this function an
633 alias for symbol-function, but upon discussion at Bug#23957,
634 there is a risk breaking backward compatibility, as some users of
635 fboundp may expect `t' in particular, rather than any true
636 value. An alias is still welcome so long as the compatibility
637 issues are addressed. */
638 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
639 doc
: /* Return t if SYMBOL's function definition is not void. */)
640 (register Lisp_Object symbol
)
642 CHECK_SYMBOL (symbol
);
643 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
646 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
647 doc
: /* Make SYMBOL's value be void.
649 (register Lisp_Object symbol
)
651 CHECK_SYMBOL (symbol
);
652 if (SYMBOL_CONSTANT_P (symbol
))
653 xsignal1 (Qsetting_constant
, symbol
);
654 Fset (symbol
, Qunbound
);
658 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
659 doc
: /* Make SYMBOL's function definition be nil.
661 (register Lisp_Object symbol
)
663 CHECK_SYMBOL (symbol
);
664 if (NILP (symbol
) || EQ (symbol
, Qt
))
665 xsignal1 (Qsetting_constant
, symbol
);
666 set_symbol_function (symbol
, Qnil
);
670 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
671 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
672 (register Lisp_Object symbol
)
674 CHECK_SYMBOL (symbol
);
675 return XSYMBOL (symbol
)->function
;
678 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
679 doc
: /* Return SYMBOL's property list. */)
680 (register Lisp_Object symbol
)
682 CHECK_SYMBOL (symbol
);
683 return XSYMBOL (symbol
)->plist
;
686 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
687 doc
: /* Return SYMBOL's name, a string. */)
688 (register Lisp_Object symbol
)
690 register Lisp_Object name
;
692 CHECK_SYMBOL (symbol
);
693 name
= SYMBOL_NAME (symbol
);
697 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
698 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
699 (register Lisp_Object symbol
, Lisp_Object definition
)
701 register Lisp_Object function
;
702 CHECK_SYMBOL (symbol
);
704 function
= XSYMBOL (symbol
)->function
;
706 if (!NILP (Vautoload_queue
) && !NILP (function
))
707 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
709 if (AUTOLOADP (function
))
710 Fput (symbol
, Qautoload
, XCDR (function
));
712 /* Convert to eassert or remove after GC bug is found. In the
713 meantime, check unconditionally, at a slight perf hit. */
714 if (! valid_lisp_object_p (definition
))
717 set_symbol_function (symbol
, definition
);
722 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
723 doc
: /* Set SYMBOL's function definition to DEFINITION.
724 Associates the function with the current load file, if any.
725 The optional third argument DOCSTRING specifies the documentation string
726 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
727 determined by DEFINITION.
729 Internally, this normally uses `fset', but if SYMBOL has a
730 `defalias-fset-function' property, the associated value is used instead.
732 The return value is undefined. */)
733 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
735 CHECK_SYMBOL (symbol
);
736 if (!NILP (Vpurify_flag
)
737 /* If `definition' is a keymap, immutable (and copying) is wrong. */
738 && !KEYMAPP (definition
))
739 definition
= Fpurecopy (definition
);
742 bool autoload
= AUTOLOADP (definition
);
743 if (NILP (Vpurify_flag
) || !autoload
)
744 { /* Only add autoload entries after dumping, because the ones before are
745 not useful and else we get loads of them from the loaddefs.el. */
747 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
748 /* Remember that the function was already an autoload. */
749 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
750 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
754 { /* Handle automatic advice activation. */
755 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
757 call2 (hook
, symbol
, definition
);
759 Ffset (symbol
, definition
);
762 if (!NILP (docstring
))
763 Fput (symbol
, Qfunction_documentation
, docstring
);
764 /* We used to return `definition', but now that `defun' and `defmacro' expand
765 to a call to `defalias', we return `symbol' for backward compatibility
770 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
771 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
772 (register Lisp_Object symbol
, Lisp_Object newplist
)
774 CHECK_SYMBOL (symbol
);
775 set_symbol_plist (symbol
, newplist
);
779 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
780 doc
: /* Return minimum and maximum number of args allowed for SUBR.
781 SUBR must be a built-in function.
782 The returned value is a pair (MIN . MAX). MIN is the minimum number
783 of args. MAX is the maximum number or the symbol `many', for a
784 function with `&rest' args, or `unevalled' for a special form. */)
787 short minargs
, maxargs
;
789 minargs
= XSUBR (subr
)->min_args
;
790 maxargs
= XSUBR (subr
)->max_args
;
791 return Fcons (make_number (minargs
),
792 maxargs
== MANY
? Qmany
793 : maxargs
== UNEVALLED
? Qunevalled
794 : make_number (maxargs
));
797 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
798 doc
: /* Return name of subroutine SUBR.
799 SUBR must be a built-in function. */)
804 name
= XSUBR (subr
)->symbol_name
;
805 return build_string (name
);
808 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
809 doc
: /* Return the interactive form of CMD or nil if none.
810 If CMD is not a command, the return value is nil.
811 Value, if non-nil, is a list (interactive SPEC). */)
814 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
819 /* Use an `interactive-form' property if present, analogous to the
820 function-documentation property. */
822 while (SYMBOLP (fun
))
824 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
828 fun
= Fsymbol_function (fun
);
833 const char *spec
= XSUBR (fun
)->intspec
;
835 return list2 (Qinteractive
,
836 (*spec
!= '(') ? build_string (spec
) :
837 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
839 else if (COMPILEDP (fun
))
841 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
842 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
844 else if (AUTOLOADP (fun
))
845 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
846 else if (CONSP (fun
))
848 Lisp_Object funcar
= XCAR (fun
);
849 if (EQ (funcar
, Qclosure
))
850 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
851 else if (EQ (funcar
, Qlambda
))
852 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
858 /***********************************************************************
859 Getting and Setting Values of Symbols
860 ***********************************************************************/
862 /* Return the symbol holding SYMBOL's value. Signal
863 `cyclic-variable-indirection' if SYMBOL's chain of variable
864 indirections contains a loop. */
867 indirect_variable (struct Lisp_Symbol
*symbol
)
869 struct Lisp_Symbol
*tortoise
, *hare
;
871 hare
= tortoise
= symbol
;
873 while (hare
->redirect
== SYMBOL_VARALIAS
)
875 hare
= SYMBOL_ALIAS (hare
);
876 if (hare
->redirect
!= SYMBOL_VARALIAS
)
879 hare
= SYMBOL_ALIAS (hare
);
880 tortoise
= SYMBOL_ALIAS (tortoise
);
882 if (hare
== tortoise
)
885 XSETSYMBOL (tem
, symbol
);
886 xsignal1 (Qcyclic_variable_indirection
, tem
);
894 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
895 doc
: /* Return the variable at the end of OBJECT's variable chain.
896 If OBJECT is a symbol, follow its variable indirections (if any), and
897 return the variable at the end of the chain of aliases. See Info node
898 `(elisp)Variable Aliases'.
900 If OBJECT is not a symbol, just return it. If there is a loop in the
901 chain of aliases, signal a `cyclic-variable-indirection' error. */)
904 if (SYMBOLP (object
))
906 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
907 XSETSYMBOL (object
, sym
);
913 /* Given the raw contents of a symbol value cell,
914 return the Lisp value of the symbol.
915 This does not handle buffer-local variables; use
916 swap_in_symval_forwarding for that. */
919 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
921 register Lisp_Object val
;
922 switch (XFWDTYPE (valcontents
))
925 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
929 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
932 return *XOBJFWD (valcontents
)->objvar
;
934 case Lisp_Fwd_Buffer_Obj
:
935 return per_buffer_value (current_buffer
,
936 XBUFFER_OBJFWD (valcontents
)->offset
);
938 case Lisp_Fwd_Kboard_Obj
:
939 /* We used to simply use current_kboard here, but from Lisp
940 code, its value is often unexpected. It seems nicer to
941 allow constructions like this to work as intuitively expected:
943 (with-selected-frame frame
944 (define-key local-function-map "\eOP" [f1]))
946 On the other hand, this affects the semantics of
947 last-command and real-last-command, and people may rely on
948 that. I took a quick look at the Lisp codebase, and I
949 don't think anything will break. --lorentey */
950 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
951 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
952 default: emacs_abort ();
956 /* Used to signal a user-friendly error when symbol WRONG is
957 not a member of CHOICE, which should be a list of symbols. */
960 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
962 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
963 Lisp_Object obj
, *args
;
964 AUTO_STRING (one_of
, "One of ");
965 AUTO_STRING (comma
, ", ");
966 AUTO_STRING (or, " or ");
967 AUTO_STRING (should_be_specified
, " should be specified");
970 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
974 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
976 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
977 args
[i
++] = (NILP (XCDR (obj
)) ? should_be_specified
978 : NILP (XCDR (XCDR (obj
))) ? or : comma
);
981 obj
= Fconcat (i
, args
);
983 xsignal2 (Qerror
, obj
, wrong
);
986 /* Used to signal a user-friendly error if WRONG is not a number or
987 integer/floating-point number outsize of inclusive MIN..MAX range. */
990 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
992 AUTO_STRING (value_should_be_from
, "Value should be from ");
993 AUTO_STRING (to
, " to ");
995 CALLN (Fconcat
, value_should_be_from
, Fnumber_to_string (min
),
996 to
, Fnumber_to_string (max
)),
1000 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1001 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1002 buffer-independent contents of the value cell: forwarded just one
1003 step past the buffer-localness.
1005 BUF non-zero means set the value in buffer BUF instead of the
1006 current buffer. This only plays a role for per-buffer variables. */
1009 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
1011 switch (XFWDTYPE (valcontents
))
1014 CHECK_NUMBER (newval
);
1015 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1019 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1023 *XOBJFWD (valcontents
)->objvar
= newval
;
1025 /* If this variable is a default for something stored
1026 in the buffer itself, such as default-fill-column,
1027 find the buffers that don't have local values for it
1029 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1030 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1032 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1033 - (char *) &buffer_defaults
);
1034 int idx
= PER_BUFFER_IDX (offset
);
1036 Lisp_Object tail
, buf
;
1041 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1043 struct buffer
*b
= XBUFFER (buf
);
1045 if (! PER_BUFFER_VALUE_P (b
, idx
))
1046 set_per_buffer_value (b
, offset
, newval
);
1051 case Lisp_Fwd_Buffer_Obj
:
1053 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1054 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1058 if (SYMBOLP (predicate
))
1062 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1064 if (NILP (Fmemq (newval
, prop
)))
1065 wrong_choice (prop
, newval
);
1067 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1069 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1071 if (!NUMBERP (newval
)
1072 || !NILP (arithcompare (newval
, min
, ARITH_LESS
))
1073 || !NILP (arithcompare (newval
, max
, ARITH_GRTR
)))
1074 wrong_range (min
, max
, newval
);
1076 else if (FUNCTIONP (predicate
))
1078 if (NILP (call1 (predicate
, newval
)))
1079 wrong_type_argument (predicate
, newval
);
1084 buf
= current_buffer
;
1085 set_per_buffer_value (buf
, offset
, newval
);
1089 case Lisp_Fwd_Kboard_Obj
:
1091 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1092 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1093 *(Lisp_Object
*) p
= newval
;
1098 emacs_abort (); /* goto def; */
1102 /* Set up SYMBOL to refer to its global binding. This makes it safe
1103 to alter the status of other bindings. BEWARE: this may be called
1104 during the mark phase of GC, where we assume that Lisp_Object slots
1105 of BLV are marked after this function has changed them. */
1108 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1110 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1112 /* Unload the previously loaded binding. */
1114 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1116 /* Select the global binding in the symbol. */
1117 set_blv_valcell (blv
, blv
->defcell
);
1119 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1121 /* Indicate that the global binding is set up now. */
1122 set_blv_where (blv
, Qnil
);
1123 set_blv_found (blv
, 0);
1126 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1127 VALCONTENTS is the contents of its value cell,
1128 which points to a struct Lisp_Buffer_Local_Value.
1130 Return the value forwarded one step past the buffer-local stage.
1131 This could be another forwarding pointer. */
1134 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1136 register Lisp_Object tem1
;
1138 eassert (blv
== SYMBOL_BLV (symbol
));
1143 || (blv
->frame_local
1144 ? !EQ (selected_frame
, tem1
)
1145 : current_buffer
!= XBUFFER (tem1
)))
1148 /* Unload the previously loaded binding. */
1149 tem1
= blv
->valcell
;
1151 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1152 /* Choose the new binding. */
1155 XSETSYMBOL (var
, symbol
);
1156 if (blv
->frame_local
)
1158 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1159 set_blv_where (blv
, selected_frame
);
1163 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1164 set_blv_where (blv
, Fcurrent_buffer ());
1167 if (!(blv
->found
= !NILP (tem1
)))
1168 tem1
= blv
->defcell
;
1170 /* Load the new binding. */
1171 set_blv_valcell (blv
, tem1
);
1173 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1177 /* Find the value of a symbol, returning Qunbound if it's not bound.
1178 This is helpful for code which just wants to get a variable's value
1179 if it has one, without signaling an error.
1180 Note that it must not be possible to quit
1181 within this function. Great care is required for this. */
1184 find_symbol_value (Lisp_Object symbol
)
1186 struct Lisp_Symbol
*sym
;
1188 CHECK_SYMBOL (symbol
);
1189 sym
= XSYMBOL (symbol
);
1192 switch (sym
->redirect
)
1194 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1195 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1196 case SYMBOL_LOCALIZED
:
1198 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1199 swap_in_symval_forwarding (sym
, blv
);
1200 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1203 case SYMBOL_FORWARDED
:
1204 return do_symval_forwarding (SYMBOL_FWD (sym
));
1205 default: emacs_abort ();
1209 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1210 doc
: /* Return SYMBOL's value. Error if that is void.
1211 Note that if `lexical-binding' is in effect, this returns the
1212 global value outside of any lexical scope. */)
1213 (Lisp_Object symbol
)
1217 val
= find_symbol_value (symbol
);
1218 if (!EQ (val
, Qunbound
))
1221 xsignal1 (Qvoid_variable
, symbol
);
1224 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1225 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1226 (register Lisp_Object symbol
, Lisp_Object newval
)
1228 set_internal (symbol
, newval
, Qnil
, 0);
1232 /* Store the value NEWVAL into SYMBOL.
1233 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1234 (nil stands for the current buffer/frame).
1236 If BINDFLAG is false, then if this symbol is supposed to become
1237 local in every buffer where it is set, then we make it local.
1238 If BINDFLAG is true, we don't do that. */
1241 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1244 bool voide
= EQ (newval
, Qunbound
);
1245 struct Lisp_Symbol
*sym
;
1248 /* If restoring in a dead buffer, do nothing. */
1249 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1252 CHECK_SYMBOL (symbol
);
1253 if (SYMBOL_CONSTANT_P (symbol
))
1255 if (NILP (Fkeywordp (symbol
))
1256 || !EQ (newval
, Fsymbol_value (symbol
)))
1257 xsignal1 (Qsetting_constant
, symbol
);
1259 /* Allow setting keywords to their own value. */
1263 maybe_set_redisplay (symbol
);
1264 sym
= XSYMBOL (symbol
);
1267 switch (sym
->redirect
)
1269 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1270 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1271 case SYMBOL_LOCALIZED
:
1273 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1276 if (blv
->frame_local
)
1277 where
= selected_frame
;
1279 XSETBUFFER (where
, current_buffer
);
1281 /* If the current buffer is not the buffer whose binding is
1282 loaded, or if there may be frame-local bindings and the frame
1283 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1284 the default binding is loaded, the loaded binding may be the
1286 if (!EQ (blv
->where
, where
)
1287 /* Also unload a global binding (if the var is local_if_set). */
1288 || (EQ (blv
->valcell
, blv
->defcell
)))
1290 /* The currently loaded binding is not necessarily valid.
1291 We need to unload it, and choose a new binding. */
1293 /* Write out `realvalue' to the old loaded binding. */
1295 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1297 /* Find the new binding. */
1298 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1299 tem1
= assq_no_quit (symbol
,
1301 ? XFRAME (where
)->param_alist
1302 : BVAR (XBUFFER (where
), local_var_alist
)));
1303 set_blv_where (blv
, where
);
1308 /* This buffer still sees the default value. */
1310 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1311 or if this is `let' rather than `set',
1312 make CURRENT-ALIST-ELEMENT point to itself,
1313 indicating that we're seeing the default value.
1314 Likewise if the variable has been let-bound
1315 in the current buffer. */
1316 if (bindflag
|| !blv
->local_if_set
1317 || let_shadows_buffer_binding_p (sym
))
1320 tem1
= blv
->defcell
;
1322 /* If it's a local_if_set, being set not bound,
1323 and we're not within a let that was made for this buffer,
1324 create a new buffer-local binding for the variable.
1325 That means, give this buffer a new assoc for a local value
1326 and load that binding. */
1329 /* local_if_set is only supported for buffer-local
1330 bindings, not for frame-local bindings. */
1331 eassert (!blv
->frame_local
);
1332 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1333 bset_local_var_alist
1335 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1339 /* Record which binding is now loaded. */
1340 set_blv_valcell (blv
, tem1
);
1343 /* Store the new value in the cons cell. */
1344 set_blv_value (blv
, newval
);
1349 /* If storing void (making the symbol void), forward only through
1350 buffer-local indicator, not through Lisp_Objfwd, etc. */
1353 store_symval_forwarding (blv
->fwd
, newval
,
1355 ? XBUFFER (where
) : current_buffer
);
1359 case SYMBOL_FORWARDED
:
1362 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1363 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1364 if (BUFFER_OBJFWDP (innercontents
))
1366 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1367 int idx
= PER_BUFFER_IDX (offset
);
1370 && !let_shadows_buffer_binding_p (sym
))
1371 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1375 { /* If storing void (making the symbol void), forward only through
1376 buffer-local indicator, not through Lisp_Objfwd, etc. */
1377 sym
->redirect
= SYMBOL_PLAINVAL
;
1378 SET_SYMBOL_VAL (sym
, newval
);
1381 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1384 default: emacs_abort ();
1389 /* Access or set a buffer-local symbol's default value. */
1391 /* Return the default value of SYMBOL, but don't check for voidness.
1392 Return Qunbound if it is void. */
1395 default_value (Lisp_Object symbol
)
1397 struct Lisp_Symbol
*sym
;
1399 CHECK_SYMBOL (symbol
);
1400 sym
= XSYMBOL (symbol
);
1403 switch (sym
->redirect
)
1405 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1406 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1407 case SYMBOL_LOCALIZED
:
1409 /* If var is set up for a buffer that lacks a local value for it,
1410 the current value is nominally the default value.
1411 But the `realvalue' slot may be more up to date, since
1412 ordinary setq stores just that slot. So use that. */
1413 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1414 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1415 return do_symval_forwarding (blv
->fwd
);
1417 return XCDR (blv
->defcell
);
1419 case SYMBOL_FORWARDED
:
1421 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1423 /* For a built-in buffer-local variable, get the default value
1424 rather than letting do_symval_forwarding get the current value. */
1425 if (BUFFER_OBJFWDP (valcontents
))
1427 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1428 if (PER_BUFFER_IDX (offset
) != 0)
1429 return per_buffer_default (offset
);
1432 /* For other variables, get the current value. */
1433 return do_symval_forwarding (valcontents
);
1435 default: emacs_abort ();
1439 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1440 doc
: /* Return t if SYMBOL has a non-void default value.
1441 This is the value that is seen in buffers that do not have their own values
1442 for this variable. */)
1443 (Lisp_Object symbol
)
1445 register Lisp_Object value
;
1447 value
= default_value (symbol
);
1448 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1451 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1452 doc
: /* Return SYMBOL's default value.
1453 This is the value that is seen in buffers that do not have their own values
1454 for this variable. The default value is meaningful for variables with
1455 local bindings in certain buffers. */)
1456 (Lisp_Object symbol
)
1458 Lisp_Object value
= default_value (symbol
);
1459 if (!EQ (value
, Qunbound
))
1462 xsignal1 (Qvoid_variable
, symbol
);
1465 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1466 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1467 The default value is seen in buffers that do not have their own values
1468 for this variable. */)
1469 (Lisp_Object symbol
, Lisp_Object value
)
1471 struct Lisp_Symbol
*sym
;
1473 CHECK_SYMBOL (symbol
);
1474 if (SYMBOL_CONSTANT_P (symbol
))
1476 if (NILP (Fkeywordp (symbol
))
1477 || !EQ (value
, Fdefault_value (symbol
)))
1478 xsignal1 (Qsetting_constant
, symbol
);
1480 /* Allow setting keywords to their own value. */
1483 sym
= XSYMBOL (symbol
);
1486 switch (sym
->redirect
)
1488 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1489 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1490 case SYMBOL_LOCALIZED
:
1492 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1494 /* Store new value into the DEFAULT-VALUE slot. */
1495 XSETCDR (blv
->defcell
, value
);
1497 /* If the default binding is now loaded, set the REALVALUE slot too. */
1498 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1499 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1502 case SYMBOL_FORWARDED
:
1504 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1506 /* Handle variables like case-fold-search that have special slots
1508 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1509 if (BUFFER_OBJFWDP (valcontents
))
1511 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1512 int idx
= PER_BUFFER_IDX (offset
);
1514 set_per_buffer_default (offset
, value
);
1516 /* If this variable is not always local in all buffers,
1517 set it in the buffers that don't nominally have a local value. */
1523 if (!PER_BUFFER_VALUE_P (b
, idx
))
1524 set_per_buffer_value (b
, offset
, value
);
1529 return Fset (symbol
, value
);
1531 default: emacs_abort ();
1535 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1536 doc
: /* Set the default value of variable VAR to VALUE.
1537 VAR, the variable name, is literal (not evaluated);
1538 VALUE is an expression: it is evaluated and its value returned.
1539 The default value of a variable is seen in buffers
1540 that do not have their own values for the variable.
1542 More generally, you can use multiple variables and values, as in
1543 (setq-default VAR VALUE VAR VALUE...)
1544 This sets each VAR's default value to the corresponding VALUE.
1545 The VALUE for the Nth VAR can refer to the new default values
1547 usage: (setq-default [VAR VALUE]...) */)
1550 Lisp_Object args_left
, symbol
, val
;
1552 args_left
= val
= args
;
1554 while (CONSP (args_left
))
1556 val
= eval_sub (Fcar (XCDR (args_left
)));
1557 symbol
= XCAR (args_left
);
1558 Fset_default (symbol
, val
);
1559 args_left
= Fcdr (XCDR (args_left
));
1565 /* Lisp functions for creating and removing buffer-local variables. */
1570 union Lisp_Fwd
*fwd
;
1573 static struct Lisp_Buffer_Local_Value
*
1574 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1575 union Lisp_Val_Fwd valcontents
)
1577 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1581 XSETSYMBOL (symbol
, sym
);
1582 tem
= Fcons (symbol
, (forwarded
1583 ? do_symval_forwarding (valcontents
.fwd
)
1584 : valcontents
.value
));
1586 /* Buffer_Local_Values cannot have as realval a buffer-local
1587 or keyboard-local forwarding. */
1588 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1589 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1590 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1591 set_blv_where (blv
, Qnil
);
1592 blv
->frame_local
= 0;
1593 blv
->local_if_set
= 0;
1594 set_blv_defcell (blv
, tem
);
1595 set_blv_valcell (blv
, tem
);
1596 set_blv_found (blv
, 0);
1600 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1601 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1602 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1603 At any time, the value for the current buffer is in effect,
1604 unless the variable has never been set in this buffer,
1605 in which case the default value is in effect.
1606 Note that binding the variable with `let', or setting it while
1607 a `let'-style binding made in this buffer is in effect,
1608 does not make the variable buffer-local. Return VARIABLE.
1610 This globally affects all uses of this variable, so it belongs together with
1611 the variable declaration, rather than with its uses (if you just want to make
1612 a variable local to the current buffer for one particular use, use
1613 `make-local-variable'). Buffer-local bindings are normally cleared
1614 while setting up a new major mode, unless they have a `permanent-local'
1617 The function `default-value' gets the default value and `set-default' sets it. */)
1618 (register Lisp_Object variable
)
1620 struct Lisp_Symbol
*sym
;
1621 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1622 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1623 bool forwarded
IF_LINT (= 0);
1625 CHECK_SYMBOL (variable
);
1626 sym
= XSYMBOL (variable
);
1629 switch (sym
->redirect
)
1631 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1632 case SYMBOL_PLAINVAL
:
1633 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1634 if (EQ (valcontents
.value
, Qunbound
))
1635 valcontents
.value
= Qnil
;
1637 case SYMBOL_LOCALIZED
:
1638 blv
= SYMBOL_BLV (sym
);
1639 if (blv
->frame_local
)
1640 error ("Symbol %s may not be buffer-local",
1641 SDATA (SYMBOL_NAME (variable
)));
1643 case SYMBOL_FORWARDED
:
1644 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1645 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1646 error ("Symbol %s may not be buffer-local",
1647 SDATA (SYMBOL_NAME (variable
)));
1648 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1651 default: emacs_abort ();
1655 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1659 blv
= make_blv (sym
, forwarded
, valcontents
);
1660 sym
->redirect
= SYMBOL_LOCALIZED
;
1661 SET_SYMBOL_BLV (sym
, blv
);
1664 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1665 if (let_shadows_global_binding_p (symbol
))
1667 AUTO_STRING (format
, "Making %s buffer-local while let-bound!");
1668 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1673 blv
->local_if_set
= 1;
1677 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1678 1, 1, "vMake Local Variable: ",
1679 doc
: /* Make VARIABLE have a separate value in the current buffer.
1680 Other buffers will continue to share a common default value.
1681 \(The buffer-local value of VARIABLE starts out as the same value
1682 VARIABLE previously had. If VARIABLE was void, it remains void.)
1685 If the variable is already arranged to become local when set,
1686 this function causes a local value to exist for this buffer,
1687 just as setting the variable would do.
1689 This function returns VARIABLE, and therefore
1690 (set (make-local-variable \\='VARIABLE) VALUE-EXP)
1693 See also `make-variable-buffer-local'.
1695 Do not use `make-local-variable' to make a hook variable buffer-local.
1696 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1697 (Lisp_Object variable
)
1700 bool forwarded
IF_LINT (= 0);
1701 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1702 struct Lisp_Symbol
*sym
;
1703 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1705 CHECK_SYMBOL (variable
);
1706 sym
= XSYMBOL (variable
);
1709 switch (sym
->redirect
)
1711 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1712 case SYMBOL_PLAINVAL
:
1713 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1714 case SYMBOL_LOCALIZED
:
1715 blv
= SYMBOL_BLV (sym
);
1716 if (blv
->frame_local
)
1717 error ("Symbol %s may not be buffer-local",
1718 SDATA (SYMBOL_NAME (variable
)));
1720 case SYMBOL_FORWARDED
:
1721 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1722 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1723 error ("Symbol %s may not be buffer-local",
1724 SDATA (SYMBOL_NAME (variable
)));
1726 default: emacs_abort ();
1730 error ("Symbol %s may not be buffer-local",
1731 SDATA (SYMBOL_NAME (variable
)));
1733 if (blv
? blv
->local_if_set
1734 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1736 tem
= Fboundp (variable
);
1737 /* Make sure the symbol has a local value in this particular buffer,
1738 by setting it to the same value it already has. */
1739 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1744 blv
= make_blv (sym
, forwarded
, valcontents
);
1745 sym
->redirect
= SYMBOL_LOCALIZED
;
1746 SET_SYMBOL_BLV (sym
, blv
);
1749 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1750 if (let_shadows_global_binding_p (symbol
))
1752 AUTO_STRING (format
, "Making %s local to %s while let-bound!");
1753 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
),
1754 BVAR (current_buffer
, name
));
1759 /* Make sure this buffer has its own value of symbol. */
1760 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1761 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1764 if (let_shadows_buffer_binding_p (sym
))
1766 AUTO_STRING (format
,
1767 "Making %s buffer-local while locally let-bound!");
1768 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1771 /* Swap out any local binding for some other buffer, and make
1772 sure the current value is permanently recorded, if it's the
1774 find_symbol_value (variable
);
1776 bset_local_var_alist
1778 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1779 BVAR (current_buffer
, local_var_alist
)));
1781 /* Make sure symbol does not think it is set up for this buffer;
1782 force it to look once again for this buffer's value. */
1783 if (current_buffer
== XBUFFER (blv
->where
))
1784 set_blv_where (blv
, Qnil
);
1785 set_blv_found (blv
, 0);
1788 /* If the symbol forwards into a C variable, then load the binding
1789 for this buffer now. If C code modifies the variable before we
1790 load the binding in, then that new value will clobber the default
1791 binding the next time we unload it. */
1793 swap_in_symval_forwarding (sym
, blv
);
1798 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1799 1, 1, "vKill Local Variable: ",
1800 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1801 From now on the default value will apply in this buffer. Return VARIABLE. */)
1802 (register Lisp_Object variable
)
1804 register Lisp_Object tem
;
1805 struct Lisp_Buffer_Local_Value
*blv
;
1806 struct Lisp_Symbol
*sym
;
1808 CHECK_SYMBOL (variable
);
1809 sym
= XSYMBOL (variable
);
1812 switch (sym
->redirect
)
1814 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1815 case SYMBOL_PLAINVAL
: return variable
;
1816 case SYMBOL_FORWARDED
:
1818 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1819 if (BUFFER_OBJFWDP (valcontents
))
1821 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1822 int idx
= PER_BUFFER_IDX (offset
);
1826 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1827 set_per_buffer_value (current_buffer
, offset
,
1828 per_buffer_default (offset
));
1833 case SYMBOL_LOCALIZED
:
1834 blv
= SYMBOL_BLV (sym
);
1835 if (blv
->frame_local
)
1838 default: emacs_abort ();
1841 /* Get rid of this buffer's alist element, if any. */
1842 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1843 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1845 bset_local_var_alist
1847 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1849 /* If the symbol is set up with the current buffer's binding
1850 loaded, recompute its value. We have to do it now, or else
1851 forwarded objects won't work right. */
1853 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1854 if (EQ (buf
, blv
->where
))
1856 set_blv_where (blv
, Qnil
);
1858 find_symbol_value (variable
);
1865 /* Lisp functions for creating and removing buffer-local variables. */
1867 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1868 when/if this is removed. */
1870 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1871 1, 1, "vMake Variable Frame Local: ",
1872 doc
: /* Enable VARIABLE to have frame-local bindings.
1873 This does not create any frame-local bindings for VARIABLE,
1874 it just makes them possible.
1876 A frame-local binding is actually a frame parameter value.
1877 If a frame F has a value for the frame parameter named VARIABLE,
1878 that also acts as a frame-local binding for VARIABLE in F--
1879 provided this function has been called to enable VARIABLE
1880 to have frame-local bindings at all.
1882 The only way to create a frame-local binding for VARIABLE in a frame
1883 is to set the VARIABLE frame parameter of that frame. See
1884 `modify-frame-parameters' for how to set frame parameters.
1886 Note that since Emacs 23.1, variables cannot be both buffer-local and
1887 frame-local any more (buffer-local bindings used to take precedence over
1888 frame-local bindings). */)
1889 (Lisp_Object variable
)
1892 union Lisp_Val_Fwd valcontents
;
1893 struct Lisp_Symbol
*sym
;
1894 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1896 CHECK_SYMBOL (variable
);
1897 sym
= XSYMBOL (variable
);
1900 switch (sym
->redirect
)
1902 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1903 case SYMBOL_PLAINVAL
:
1904 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1905 if (EQ (valcontents
.value
, Qunbound
))
1906 valcontents
.value
= Qnil
;
1908 case SYMBOL_LOCALIZED
:
1909 if (SYMBOL_BLV (sym
)->frame_local
)
1912 error ("Symbol %s may not be frame-local",
1913 SDATA (SYMBOL_NAME (variable
)));
1914 case SYMBOL_FORWARDED
:
1915 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1916 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1917 error ("Symbol %s may not be frame-local",
1918 SDATA (SYMBOL_NAME (variable
)));
1920 default: emacs_abort ();
1924 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1926 blv
= make_blv (sym
, forwarded
, valcontents
);
1927 blv
->frame_local
= 1;
1928 sym
->redirect
= SYMBOL_LOCALIZED
;
1929 SET_SYMBOL_BLV (sym
, blv
);
1932 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1933 if (let_shadows_global_binding_p (symbol
))
1935 AUTO_STRING (format
, "Making %s frame-local while let-bound!");
1936 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1942 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1944 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1945 BUFFER defaults to the current buffer. */)
1946 (Lisp_Object variable
, Lisp_Object buffer
)
1948 struct buffer
*buf
= decode_buffer (buffer
);
1949 struct Lisp_Symbol
*sym
;
1951 CHECK_SYMBOL (variable
);
1952 sym
= XSYMBOL (variable
);
1955 switch (sym
->redirect
)
1957 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1958 case SYMBOL_PLAINVAL
: return Qnil
;
1959 case SYMBOL_LOCALIZED
:
1961 Lisp_Object tail
, elt
, tmp
;
1962 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1963 XSETBUFFER (tmp
, buf
);
1964 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1966 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1967 return blv_found (blv
) ? Qt
: Qnil
;
1969 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1972 if (EQ (variable
, XCAR (elt
)))
1974 eassert (!blv
->frame_local
);
1980 case SYMBOL_FORWARDED
:
1982 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1983 if (BUFFER_OBJFWDP (valcontents
))
1985 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1986 int idx
= PER_BUFFER_IDX (offset
);
1987 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1992 default: emacs_abort ();
1996 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1998 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1999 BUFFER defaults to the current buffer.
2001 More precisely, return non-nil if either VARIABLE already has a local
2002 value in BUFFER, or if VARIABLE is automatically buffer-local (see
2003 `make-variable-buffer-local'). */)
2004 (register Lisp_Object variable
, Lisp_Object buffer
)
2006 struct Lisp_Symbol
*sym
;
2008 CHECK_SYMBOL (variable
);
2009 sym
= XSYMBOL (variable
);
2012 switch (sym
->redirect
)
2014 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2015 case SYMBOL_PLAINVAL
: return Qnil
;
2016 case SYMBOL_LOCALIZED
:
2018 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2019 if (blv
->local_if_set
)
2021 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2022 return Flocal_variable_p (variable
, buffer
);
2024 case SYMBOL_FORWARDED
:
2025 /* All BUFFER_OBJFWD slots become local if they are set. */
2026 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2027 default: emacs_abort ();
2031 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2033 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2034 If the current binding is buffer-local, the value is the current buffer.
2035 If the current binding is frame-local, the value is the selected frame.
2036 If the current binding is global (the default), the value is nil. */)
2037 (register Lisp_Object variable
)
2039 struct Lisp_Symbol
*sym
;
2041 CHECK_SYMBOL (variable
);
2042 sym
= XSYMBOL (variable
);
2044 /* Make sure the current binding is actually swapped in. */
2045 find_symbol_value (variable
);
2048 switch (sym
->redirect
)
2050 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2051 case SYMBOL_PLAINVAL
: return Qnil
;
2052 case SYMBOL_FORWARDED
:
2054 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2055 if (KBOARD_OBJFWDP (valcontents
))
2056 return Fframe_terminal (selected_frame
);
2057 else if (!BUFFER_OBJFWDP (valcontents
))
2061 case SYMBOL_LOCALIZED
:
2062 /* For a local variable, record both the symbol and which
2063 buffer's or frame's value we are saving. */
2064 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2065 return Fcurrent_buffer ();
2066 else if (sym
->redirect
== SYMBOL_LOCALIZED
2067 && blv_found (SYMBOL_BLV (sym
)))
2068 return SYMBOL_BLV (sym
)->where
;
2071 default: emacs_abort ();
2075 /* This code is disabled now that we use the selected frame to return
2076 keyboard-local-values. */
2078 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2080 DEFUN ("terminal-local-value", Fterminal_local_value
,
2081 Sterminal_local_value
, 2, 2, 0,
2082 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2083 If SYMBOL is not a terminal-local variable, then return its normal
2084 value, like `symbol-value'.
2086 TERMINAL may be a terminal object, a frame, or nil (meaning the
2087 selected frame's terminal device). */)
2088 (Lisp_Object symbol
, Lisp_Object terminal
)
2091 struct terminal
*t
= get_terminal (terminal
, 1);
2092 push_kboard (t
->kboard
);
2093 result
= Fsymbol_value (symbol
);
2098 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2099 Sset_terminal_local_value
, 3, 3, 0,
2100 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2101 If VARIABLE is not a terminal-local variable, then set its normal
2102 binding, like `set'.
2104 TERMINAL may be a terminal object, a frame, or nil (meaning the
2105 selected frame's terminal device). */)
2106 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2109 struct terminal
*t
= get_terminal (terminal
, 1);
2110 push_kboard (d
->kboard
);
2111 result
= Fset (symbol
, value
);
2117 /* Find the function at the end of a chain of symbol function indirections. */
2119 /* If OBJECT is a symbol, find the end of its function chain and
2120 return the value found there. If OBJECT is not a symbol, just
2121 return it. If there is a cycle in the function chain, signal a
2122 cyclic-function-indirection error.
2124 This is like Findirect_function, except that it doesn't signal an
2125 error if the chain ends up unbound. */
2127 indirect_function (register Lisp_Object object
)
2129 Lisp_Object tortoise
, hare
;
2131 hare
= tortoise
= object
;
2135 if (!SYMBOLP (hare
) || NILP (hare
))
2137 hare
= XSYMBOL (hare
)->function
;
2138 if (!SYMBOLP (hare
) || NILP (hare
))
2140 hare
= XSYMBOL (hare
)->function
;
2142 tortoise
= XSYMBOL (tortoise
)->function
;
2144 if (EQ (hare
, tortoise
))
2145 xsignal1 (Qcyclic_function_indirection
, object
);
2151 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2152 doc
: /* Return the function at the end of OBJECT's function chain.
2153 If OBJECT is not a symbol, just return it. Otherwise, follow all
2154 function indirections to find the final function binding and return it.
2155 Signal a cyclic-function-indirection error if there is a loop in the
2156 function chain of symbols. */)
2157 (register Lisp_Object object
, Lisp_Object noerror
)
2161 /* Optimize for no indirection. */
2163 if (SYMBOLP (result
) && !NILP (result
)
2164 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2165 result
= indirect_function (result
);
2172 /* Extract and set vector and string elements. */
2174 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2175 doc
: /* Return the element of ARRAY at index IDX.
2176 ARRAY may be a vector, a string, a char-table, a bool-vector,
2177 or a byte-code object. IDX starts at 0. */)
2178 (register Lisp_Object array
, Lisp_Object idx
)
2180 register EMACS_INT idxval
;
2183 idxval
= XINT (idx
);
2184 if (STRINGP (array
))
2187 ptrdiff_t idxval_byte
;
2189 if (idxval
< 0 || idxval
>= SCHARS (array
))
2190 args_out_of_range (array
, idx
);
2191 if (! STRING_MULTIBYTE (array
))
2192 return make_number ((unsigned char) SREF (array
, idxval
));
2193 idxval_byte
= string_char_to_byte (array
, idxval
);
2195 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2196 return make_number (c
);
2198 else if (BOOL_VECTOR_P (array
))
2200 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2201 args_out_of_range (array
, idx
);
2202 return bool_vector_ref (array
, idxval
);
2204 else if (CHAR_TABLE_P (array
))
2206 CHECK_CHARACTER (idx
);
2207 return CHAR_TABLE_REF (array
, idxval
);
2212 if (VECTORP (array
))
2213 size
= ASIZE (array
);
2214 else if (COMPILEDP (array
))
2215 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2217 wrong_type_argument (Qarrayp
, array
);
2219 if (idxval
< 0 || idxval
>= size
)
2220 args_out_of_range (array
, idx
);
2221 return AREF (array
, idxval
);
2225 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2226 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2227 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2228 bool-vector. IDX starts at 0. */)
2229 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2231 register EMACS_INT idxval
;
2234 idxval
= XINT (idx
);
2235 CHECK_ARRAY (array
, Qarrayp
);
2237 if (VECTORP (array
))
2239 CHECK_IMPURE (array
, XVECTOR (array
));
2240 if (idxval
< 0 || idxval
>= ASIZE (array
))
2241 args_out_of_range (array
, idx
);
2242 ASET (array
, idxval
, newelt
);
2244 else if (BOOL_VECTOR_P (array
))
2246 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2247 args_out_of_range (array
, idx
);
2248 bool_vector_set (array
, idxval
, !NILP (newelt
));
2250 else if (CHAR_TABLE_P (array
))
2252 CHECK_CHARACTER (idx
);
2253 CHAR_TABLE_SET (array
, idxval
, newelt
);
2259 CHECK_IMPURE (array
, XSTRING (array
));
2260 if (idxval
< 0 || idxval
>= SCHARS (array
))
2261 args_out_of_range (array
, idx
);
2262 CHECK_CHARACTER (newelt
);
2263 c
= XFASTINT (newelt
);
2265 if (STRING_MULTIBYTE (array
))
2267 ptrdiff_t idxval_byte
, nbytes
;
2268 int prev_bytes
, new_bytes
;
2269 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2271 nbytes
= SBYTES (array
);
2272 idxval_byte
= string_char_to_byte (array
, idxval
);
2273 p1
= SDATA (array
) + idxval_byte
;
2274 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2275 new_bytes
= CHAR_STRING (c
, p0
);
2276 if (prev_bytes
!= new_bytes
)
2278 /* We must relocate the string data. */
2279 ptrdiff_t nchars
= SCHARS (array
);
2281 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2283 memcpy (str
, SDATA (array
), nbytes
);
2284 allocate_string_data (XSTRING (array
), nchars
,
2285 nbytes
+ new_bytes
- prev_bytes
);
2286 memcpy (SDATA (array
), str
, idxval_byte
);
2287 p1
= SDATA (array
) + idxval_byte
;
2288 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2289 nbytes
- (idxval_byte
+ prev_bytes
));
2291 clear_string_char_byte_cache ();
2298 if (! SINGLE_BYTE_CHAR_P (c
))
2302 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2303 if (SREF (array
, i
) >= 0x80)
2304 args_out_of_range (array
, newelt
);
2305 /* ARRAY is an ASCII string. Convert it to a multibyte
2306 string, and try `aset' again. */
2307 STRING_SET_MULTIBYTE (array
);
2308 return Faset (array
, idx
, newelt
);
2310 SSET (array
, idxval
, c
);
2317 /* Arithmetic functions */
2320 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2322 double f1
= 0, f2
= 0;
2325 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2326 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2328 if (FLOATP (num1
) || FLOATP (num2
))
2331 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2332 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2338 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2342 case ARITH_NOTEQUAL
:
2343 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2348 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2352 case ARITH_LESS_OR_EQUAL
:
2353 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2358 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2362 case ARITH_GRTR_OR_EQUAL
:
2363 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2373 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2374 enum Arith_Comparison comparison
)
2377 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2379 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2385 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2386 doc
: /* Return t if args, all numbers or markers, are equal.
2387 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2388 (ptrdiff_t nargs
, Lisp_Object
*args
)
2390 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2393 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2394 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2395 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2396 (ptrdiff_t nargs
, Lisp_Object
*args
)
2398 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2401 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2402 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2403 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2404 (ptrdiff_t nargs
, Lisp_Object
*args
)
2406 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2409 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2410 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2411 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2412 (ptrdiff_t nargs
, Lisp_Object
*args
)
2414 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2417 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2418 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2419 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2420 (ptrdiff_t nargs
, Lisp_Object
*args
)
2422 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2425 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2426 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2427 (register Lisp_Object num1
, Lisp_Object num2
)
2429 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2432 /* Convert the integer I to a cons-of-integers, where I is not in
2435 #define INTBIG_TO_LISP(i, extremum) \
2436 (eassert (FIXNUM_OVERFLOW_P (i)), \
2437 (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \
2438 && FIXNUM_OVERFLOW_P ((i) >> 16)) \
2439 ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \
2440 : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \
2441 && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \
2442 ? Fcons (make_number ((i) >> 16 >> 24), \
2443 Fcons (make_number ((i) >> 16 & 0xffffff), \
2444 make_number ((i) & 0xffff))) \
2448 intbig_to_lisp (intmax_t i
)
2450 return INTBIG_TO_LISP (i
, INTMAX_MIN
);
2454 uintbig_to_lisp (uintmax_t i
)
2456 return INTBIG_TO_LISP (i
, UINTMAX_MAX
);
2459 /* Convert the cons-of-integers, integer, or float value C to an
2460 unsigned value with maximum value MAX. Signal an error if C does not
2461 have a valid format or is out of range. */
2463 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2466 uintmax_t val
IF_LINT (= 0);
2469 valid
= 0 <= XINT (c
);
2472 else if (FLOATP (c
))
2474 double d
= XFLOAT_DATA (c
);
2476 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2482 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2484 uintmax_t top
= XFASTINT (XCAR (c
));
2485 Lisp_Object rest
= XCDR (c
);
2486 if (top
<= UINTMAX_MAX
>> 24 >> 16
2488 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2489 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2491 uintmax_t mid
= XFASTINT (XCAR (rest
));
2492 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2495 else if (top
<= UINTMAX_MAX
>> 16)
2499 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2501 val
= top
<< 16 | XFASTINT (rest
);
2507 if (! (valid
&& val
<= max
))
2508 error ("Not an in-range integer, float, or cons of integers");
2512 /* Convert the cons-of-integers, integer, or float value C to a signed
2513 value with extrema MIN and MAX. Signal an error if C does not have
2514 a valid format or is out of range. */
2516 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2519 intmax_t val
IF_LINT (= 0);
2525 else if (FLOATP (c
))
2527 double d
= XFLOAT_DATA (c
);
2529 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2535 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2537 intmax_t top
= XINT (XCAR (c
));
2538 Lisp_Object rest
= XCDR (c
);
2539 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2541 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2542 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2544 intmax_t mid
= XFASTINT (XCAR (rest
));
2545 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2548 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2552 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2554 val
= top
<< 16 | XFASTINT (rest
);
2560 if (! (valid
&& min
<= val
&& val
<= max
))
2561 error ("Not an in-range integer, float, or cons of integers");
2565 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2566 doc
: /* Return the decimal representation of NUMBER as a string.
2567 Uses a minus sign if negative.
2568 NUMBER may be an integer or a floating point number. */)
2569 (Lisp_Object number
)
2571 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2574 CHECK_NUMBER_OR_FLOAT (number
);
2576 if (FLOATP (number
))
2577 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2579 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2581 return make_unibyte_string (buffer
, len
);
2584 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2585 doc
: /* Parse STRING as a decimal number and return the number.
2586 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2587 STRING cannot be parsed as an integer or floating point number.
2589 If BASE, interpret STRING as a number in that base. If BASE isn't
2590 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2591 If the base used is not 10, STRING is always parsed as an integer. */)
2592 (register Lisp_Object string
, Lisp_Object base
)
2598 CHECK_STRING (string
);
2604 CHECK_NUMBER (base
);
2605 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2606 xsignal1 (Qargs_out_of_range
, base
);
2610 p
= SSDATA (string
);
2611 while (*p
== ' ' || *p
== '\t')
2614 val
= string_to_number (p
, b
, 1);
2615 return NILP (val
) ? make_number (0) : val
;
2631 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2632 ptrdiff_t, Lisp_Object
*);
2634 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2637 ptrdiff_t argnum
, ok_args
;
2638 EMACS_INT accum
= 0;
2639 EMACS_INT next
, ok_accum
;
2661 for (argnum
= 0; argnum
< nargs
; argnum
++)
2669 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2671 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2674 return float_arith_driver (ok_accum
, ok_args
, code
,
2677 next
= XINT (args
[argnum
]);
2681 overflow
|= INT_ADD_WRAPV (accum
, next
, &accum
);
2685 accum
= nargs
== 1 ? - next
: next
;
2687 overflow
|= INT_SUBTRACT_WRAPV (accum
, next
, &accum
);
2690 overflow
|= INT_MULTIPLY_WRAPV (accum
, next
, &accum
);
2693 if (! (argnum
|| nargs
== 1))
2698 xsignal0 (Qarith_error
);
2699 if (INT_DIVIDE_OVERFLOW (accum
, next
))
2715 if (!argnum
|| next
> accum
)
2719 if (!argnum
|| next
< accum
)
2725 XSETINT (val
, accum
);
2730 #define isnan(x) ((x) != (x))
2733 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2734 ptrdiff_t nargs
, Lisp_Object
*args
)
2736 register Lisp_Object val
;
2739 for (; argnum
< nargs
; argnum
++)
2741 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2742 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2746 next
= XFLOAT_DATA (val
);
2750 args
[argnum
] = val
; /* runs into a compiler bug. */
2751 next
= XINT (args
[argnum
]);
2759 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2765 if (! (argnum
|| nargs
== 1))
2769 if (! IEEE_FLOATING_POINT
&& next
== 0)
2770 xsignal0 (Qarith_error
);
2777 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2779 if (!argnum
|| isnan (next
) || next
> accum
)
2783 if (!argnum
|| isnan (next
) || next
< accum
)
2789 return make_float (accum
);
2793 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2794 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2795 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2796 (ptrdiff_t nargs
, Lisp_Object
*args
)
2798 return arith_driver (Aadd
, nargs
, args
);
2801 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2802 doc
: /* Negate number or subtract numbers or markers and return the result.
2803 With one arg, negates it. With more than one arg,
2804 subtracts all but the first from the first.
2805 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2806 (ptrdiff_t nargs
, Lisp_Object
*args
)
2808 return arith_driver (Asub
, nargs
, args
);
2811 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2812 doc
: /* Return product of any number of arguments, which are numbers or markers.
2813 usage: (* &rest NUMBERS-OR-MARKERS) */)
2814 (ptrdiff_t nargs
, Lisp_Object
*args
)
2816 return arith_driver (Amult
, nargs
, args
);
2819 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2820 doc
: /* Divide number by divisors and return the result.
2821 With two or more arguments, return first argument divided by the rest.
2822 With one argument, return 1 divided by the argument.
2823 The arguments must be numbers or markers.
2824 usage: (/ NUMBER &rest DIVISORS) */)
2825 (ptrdiff_t nargs
, Lisp_Object
*args
)
2828 for (argnum
= 2; argnum
< nargs
; argnum
++)
2829 if (FLOATP (args
[argnum
]))
2830 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2831 return arith_driver (Adiv
, nargs
, args
);
2834 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2835 doc
: /* Return remainder of X divided by Y.
2836 Both must be integers or markers. */)
2837 (register Lisp_Object x
, Lisp_Object y
)
2841 CHECK_NUMBER_COERCE_MARKER (x
);
2842 CHECK_NUMBER_COERCE_MARKER (y
);
2845 xsignal0 (Qarith_error
);
2847 XSETINT (val
, XINT (x
) % XINT (y
));
2851 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2852 doc
: /* Return X modulo Y.
2853 The result falls between zero (inclusive) and Y (exclusive).
2854 Both X and Y must be numbers or markers. */)
2855 (register Lisp_Object x
, Lisp_Object y
)
2860 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2861 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2863 if (FLOATP (x
) || FLOATP (y
))
2864 return fmod_float (x
, y
);
2870 xsignal0 (Qarith_error
);
2874 /* If the "remainder" comes out with the wrong sign, fix it. */
2875 if (i2
< 0 ? i1
> 0 : i1
< 0)
2882 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2883 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2884 The value is always a number; markers are converted to numbers.
2885 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2886 (ptrdiff_t nargs
, Lisp_Object
*args
)
2888 return arith_driver (Amax
, nargs
, args
);
2891 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2892 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2893 The value is always a number; markers are converted to numbers.
2894 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2895 (ptrdiff_t nargs
, Lisp_Object
*args
)
2897 return arith_driver (Amin
, nargs
, args
);
2900 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2901 doc
: /* Return bitwise-and of all the arguments.
2902 Arguments may be integers, or markers converted to integers.
2903 usage: (logand &rest INTS-OR-MARKERS) */)
2904 (ptrdiff_t nargs
, Lisp_Object
*args
)
2906 return arith_driver (Alogand
, nargs
, args
);
2909 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2910 doc
: /* Return bitwise-or of all the arguments.
2911 Arguments may be integers, or markers converted to integers.
2912 usage: (logior &rest INTS-OR-MARKERS) */)
2913 (ptrdiff_t nargs
, Lisp_Object
*args
)
2915 return arith_driver (Alogior
, nargs
, args
);
2918 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2919 doc
: /* Return bitwise-exclusive-or of all the arguments.
2920 Arguments may be integers, or markers converted to integers.
2921 usage: (logxor &rest INTS-OR-MARKERS) */)
2922 (ptrdiff_t nargs
, Lisp_Object
*args
)
2924 return arith_driver (Alogxor
, nargs
, args
);
2927 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2928 doc
: /* Return VALUE with its bits shifted left by COUNT.
2929 If COUNT is negative, shifting is actually to the right.
2930 In this case, the sign bit is duplicated. */)
2931 (register Lisp_Object value
, Lisp_Object count
)
2933 register Lisp_Object val
;
2935 CHECK_NUMBER (value
);
2936 CHECK_NUMBER (count
);
2938 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2940 else if (XINT (count
) > 0)
2941 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2942 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2943 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2945 XSETINT (val
, XINT (value
) >> -XINT (count
));
2949 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2950 doc
: /* Return VALUE with its bits shifted left by COUNT.
2951 If COUNT is negative, shifting is actually to the right.
2952 In this case, zeros are shifted in on the left. */)
2953 (register Lisp_Object value
, Lisp_Object count
)
2955 register Lisp_Object val
;
2957 CHECK_NUMBER (value
);
2958 CHECK_NUMBER (count
);
2960 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2962 else if (XINT (count
) > 0)
2963 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2964 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2967 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2971 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2972 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2973 Markers are converted to integers. */)
2974 (register Lisp_Object number
)
2976 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2978 if (FLOATP (number
))
2979 return (make_float (1.0 + XFLOAT_DATA (number
)));
2981 XSETINT (number
, XINT (number
) + 1);
2985 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2986 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2987 Markers are converted to integers. */)
2988 (register Lisp_Object number
)
2990 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2992 if (FLOATP (number
))
2993 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2995 XSETINT (number
, XINT (number
) - 1);
2999 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3000 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3001 (register Lisp_Object number
)
3003 CHECK_NUMBER (number
);
3004 XSETINT (number
, ~XINT (number
));
3008 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3009 doc
: /* Return the byteorder for the machine.
3010 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3011 lowercase l) for small endian machines. */
3015 unsigned i
= 0x04030201;
3016 int order
= *(char *)&i
== 1 ? 108 : 66;
3018 return make_number (order
);
3021 /* Because we round up the bool vector allocate size to word_size
3022 units, we can safely read past the "end" of the vector in the
3023 operations below. These extra bits are always zero. */
3026 bool_vector_spare_mask (EMACS_INT nr_bits
)
3028 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
3031 /* Info about unsigned long long, falling back on unsigned long
3032 if unsigned long long is not available. */
3034 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
3035 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
3036 # define ULL_MAX ULLONG_MAX
3038 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
3039 # define ULL_MAX ULONG_MAX
3040 # define count_one_bits_ll count_one_bits_l
3041 # define count_trailing_zeros_ll count_trailing_zeros_l
3044 /* Shift VAL right by the width of an unsigned long long.
3045 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3048 shift_right_ull (bits_word w
)
3050 /* Pacify bogus GCC warning about shift count exceeding type width. */
3051 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3055 /* Return the number of 1 bits in W. */
3058 count_one_bits_word (bits_word w
)
3060 if (BITS_WORD_MAX
<= UINT_MAX
)
3061 return count_one_bits (w
);
3062 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3063 return count_one_bits_l (w
);
3066 int i
= 0, count
= 0;
3067 while (count
+= count_one_bits_ll (w
),
3068 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3069 w
= shift_right_ull (w
);
3074 enum bool_vector_op
{ bool_vector_exclusive_or
,
3076 bool_vector_intersection
,
3077 bool_vector_set_difference
,
3078 bool_vector_subsetp
};
3081 bool_vector_binop_driver (Lisp_Object a
,
3084 enum bool_vector_op op
)
3087 bits_word
*adata
, *bdata
, *destdata
;
3091 CHECK_BOOL_VECTOR (a
);
3092 CHECK_BOOL_VECTOR (b
);
3094 nr_bits
= bool_vector_size (a
);
3095 if (bool_vector_size (b
) != nr_bits
)
3096 wrong_length_argument (a
, b
, dest
);
3098 nr_words
= bool_vector_words (nr_bits
);
3099 adata
= bool_vector_data (a
);
3100 bdata
= bool_vector_data (b
);
3104 dest
= make_uninit_bool_vector (nr_bits
);
3105 destdata
= bool_vector_data (dest
);
3109 CHECK_BOOL_VECTOR (dest
);
3110 destdata
= bool_vector_data (dest
);
3111 if (bool_vector_size (dest
) != nr_bits
)
3112 wrong_length_argument (a
, b
, dest
);
3116 case bool_vector_exclusive_or
:
3117 for (; i
< nr_words
; i
++)
3118 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3122 case bool_vector_subsetp
:
3123 for (; i
< nr_words
; i
++)
3124 if (adata
[i
] &~ bdata
[i
])
3128 case bool_vector_union
:
3129 for (; i
< nr_words
; i
++)
3130 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3134 case bool_vector_intersection
:
3135 for (; i
< nr_words
; i
++)
3136 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3140 case bool_vector_set_difference
:
3141 for (; i
< nr_words
; i
++)
3142 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3153 case bool_vector_exclusive_or
:
3154 for (; i
< nr_words
; i
++)
3155 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3158 case bool_vector_union
:
3159 for (; i
< nr_words
; i
++)
3160 destdata
[i
] = adata
[i
] | bdata
[i
];
3163 case bool_vector_intersection
:
3164 for (; i
< nr_words
; i
++)
3165 destdata
[i
] = adata
[i
] & bdata
[i
];
3168 case bool_vector_set_difference
:
3169 for (; i
< nr_words
; i
++)
3170 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3180 /* PRECONDITION must be true. Return VALUE. This odd construction
3181 works around a bogus GCC diagnostic "shift count >= width of type". */
3184 pre_value (bool precondition
, int value
)
3186 eassume (precondition
);
3187 return precondition
? value
: 0;
3190 /* Compute the number of trailing zero bits in val. If val is zero,
3191 return the number of bits in val. */
3193 count_trailing_zero_bits (bits_word val
)
3195 if (BITS_WORD_MAX
== UINT_MAX
)
3196 return count_trailing_zeros (val
);
3197 if (BITS_WORD_MAX
== ULONG_MAX
)
3198 return count_trailing_zeros_l (val
);
3199 if (BITS_WORD_MAX
== ULL_MAX
)
3200 return count_trailing_zeros_ll (val
);
3202 /* The rest of this code is for the unlikely platform where bits_word differs
3203 in width from unsigned int, unsigned long, and unsigned long long. */
3204 val
|= ~ BITS_WORD_MAX
;
3205 if (BITS_WORD_MAX
<= UINT_MAX
)
3206 return count_trailing_zeros (val
);
3207 if (BITS_WORD_MAX
<= ULONG_MAX
)
3208 return count_trailing_zeros_l (val
);
3213 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3214 count
+= BITS_PER_ULL
)
3217 return count
+ count_trailing_zeros_ll (val
);
3218 val
= shift_right_ull (val
);
3221 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3222 && BITS_WORD_MAX
== (bits_word
) -1)
3223 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3224 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3225 return count
+ count_trailing_zeros_ll (val
);
3230 bits_word_to_host_endian (bits_word val
)
3232 #ifndef WORDS_BIGENDIAN
3235 if (BITS_WORD_MAX
>> 31 == 1)
3236 return bswap_32 (val
);
3237 # if HAVE_UNSIGNED_LONG_LONG
3238 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3239 return bswap_64 (val
);
3244 for (i
= 0; i
< sizeof val
; i
++)
3246 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3247 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3248 val
= val
>> 1 >> (CHAR_BIT
- 1);
3255 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3256 Sbool_vector_exclusive_or
, 2, 3, 0,
3257 doc
: /* Return A ^ B, bitwise exclusive or.
3258 If optional third argument C is given, store result into C.
3259 A, B, and C must be bool vectors of the same length.
3260 Return the destination vector if it changed or nil otherwise. */)
3261 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3263 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3266 DEFUN ("bool-vector-union", Fbool_vector_union
,
3267 Sbool_vector_union
, 2, 3, 0,
3268 doc
: /* Return A | B, bitwise or.
3269 If optional third argument C is given, store result into C.
3270 A, B, and C must be bool vectors of the same length.
3271 Return the destination vector if it changed or nil otherwise. */)
3272 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3274 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3277 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3278 Sbool_vector_intersection
, 2, 3, 0,
3279 doc
: /* Return A & B, bitwise and.
3280 If optional third argument C is given, store result into C.
3281 A, B, and C must be bool vectors of the same length.
3282 Return the destination vector if it changed or nil otherwise. */)
3283 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3285 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3288 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3289 Sbool_vector_set_difference
, 2, 3, 0,
3290 doc
: /* Return A &~ B, set difference.
3291 If optional third argument C is given, store result into C.
3292 A, B, and C must be bool vectors of the same length.
3293 Return the destination vector if it changed or nil otherwise. */)
3294 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3296 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3299 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3300 Sbool_vector_subsetp
, 2, 2, 0,
3301 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3302 A and B must be bool vectors of the same length. */)
3303 (Lisp_Object a
, Lisp_Object b
)
3305 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3308 DEFUN ("bool-vector-not", Fbool_vector_not
,
3309 Sbool_vector_not
, 1, 2, 0,
3310 doc
: /* Compute ~A, set complement.
3311 If optional second argument B is given, store result into B.
3312 A and B must be bool vectors of the same length.
3313 Return the destination vector. */)
3314 (Lisp_Object a
, Lisp_Object b
)
3317 bits_word
*bdata
, *adata
;
3320 CHECK_BOOL_VECTOR (a
);
3321 nr_bits
= bool_vector_size (a
);
3324 b
= make_uninit_bool_vector (nr_bits
);
3327 CHECK_BOOL_VECTOR (b
);
3328 if (bool_vector_size (b
) != nr_bits
)
3329 wrong_length_argument (a
, b
, Qnil
);
3332 bdata
= bool_vector_data (b
);
3333 adata
= bool_vector_data (a
);
3335 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3336 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3338 if (nr_bits
% BITS_PER_BITS_WORD
)
3340 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3342 mword
&= bool_vector_spare_mask (nr_bits
);
3343 bdata
[i
] = bits_word_to_host_endian (mword
);
3349 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3350 Sbool_vector_count_population
, 1, 1, 0,
3351 doc
: /* Count how many elements in A are t.
3352 A is a bool vector. To count A's nil elements, subtract the return
3353 value from A's length. */)
3359 ptrdiff_t i
, nwords
;
3361 CHECK_BOOL_VECTOR (a
);
3363 nr_bits
= bool_vector_size (a
);
3364 nwords
= bool_vector_words (nr_bits
);
3366 adata
= bool_vector_data (a
);
3368 for (i
= 0; i
< nwords
; i
++)
3369 count
+= count_one_bits_word (adata
[i
]);
3371 return make_number (count
);
3374 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3375 Sbool_vector_count_consecutive
, 3, 3, 0,
3376 doc
: /* Count how many consecutive elements in A equal B starting at I.
3377 A is a bool vector, B is t or nil, and I is an index into A. */)
3378 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3385 bits_word mword
; /* Machine word. */
3386 ptrdiff_t pos
, pos0
;
3389 CHECK_BOOL_VECTOR (a
);
3392 nr_bits
= bool_vector_size (a
);
3393 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3394 args_out_of_range (a
, i
);
3396 adata
= bool_vector_data (a
);
3397 nr_words
= bool_vector_words (nr_bits
);
3398 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3399 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3402 /* By XORing with twiddle, we transform the problem of "count
3403 consecutive equal values" into "count the zero bits". The latter
3404 operation usually has hardware support. */
3405 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3407 /* Scan the remainder of the mword at the current offset. */
3408 if (pos
< nr_words
&& offset
!= 0)
3410 mword
= bits_word_to_host_endian (adata
[pos
]);
3414 /* Do not count the pad bits. */
3415 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3417 count
= count_trailing_zero_bits (mword
);
3419 if (count
+ offset
< BITS_PER_BITS_WORD
)
3420 return make_number (count
);
3423 /* Scan whole words until we either reach the end of the vector or
3424 find an mword that doesn't completely match. twiddle is
3425 endian-independent. */
3427 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3429 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3433 /* If we stopped because of a mismatch, see how many bits match
3434 in the current mword. */
3435 mword
= bits_word_to_host_endian (adata
[pos
]);
3437 count
+= count_trailing_zero_bits (mword
);
3439 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3441 /* If we hit the end, we might have overshot our count. Reduce
3442 the total by the number of spare bits at the end of the
3444 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3447 return make_number (count
);
3454 Lisp_Object error_tail
, arith_tail
;
3456 DEFSYM (Qquote
, "quote");
3457 DEFSYM (Qlambda
, "lambda");
3458 DEFSYM (Qsubr
, "subr");
3459 DEFSYM (Qerror_conditions
, "error-conditions");
3460 DEFSYM (Qerror_message
, "error-message");
3461 DEFSYM (Qtop_level
, "top-level");
3463 DEFSYM (Qerror
, "error");
3464 DEFSYM (Quser_error
, "user-error");
3465 DEFSYM (Qquit
, "quit");
3466 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3467 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3468 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3469 DEFSYM (Qvoid_function
, "void-function");
3470 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3471 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3472 DEFSYM (Qvoid_variable
, "void-variable");
3473 DEFSYM (Qsetting_constant
, "setting-constant");
3474 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3476 DEFSYM (Qinvalid_function
, "invalid-function");
3477 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3478 DEFSYM (Qno_catch
, "no-catch");
3479 DEFSYM (Qend_of_file
, "end-of-file");
3480 DEFSYM (Qarith_error
, "arith-error");
3481 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3482 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3483 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3484 DEFSYM (Qtext_read_only
, "text-read-only");
3485 DEFSYM (Qmark_inactive
, "mark-inactive");
3487 DEFSYM (Qlistp
, "listp");
3488 DEFSYM (Qconsp
, "consp");
3489 DEFSYM (Qsymbolp
, "symbolp");
3490 DEFSYM (Qintegerp
, "integerp");
3491 DEFSYM (Qnatnump
, "natnump");
3492 DEFSYM (Qwholenump
, "wholenump");
3493 DEFSYM (Qstringp
, "stringp");
3494 DEFSYM (Qarrayp
, "arrayp");
3495 DEFSYM (Qsequencep
, "sequencep");
3496 DEFSYM (Qbufferp
, "bufferp");
3497 DEFSYM (Qvectorp
, "vectorp");
3498 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3499 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3500 DEFSYM (Qmarkerp
, "markerp");
3502 DEFSYM (Quser_ptrp
, "user-ptrp");
3504 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3505 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3506 DEFSYM (Qfboundp
, "fboundp");
3508 DEFSYM (Qfloatp
, "floatp");
3509 DEFSYM (Qnumberp
, "numberp");
3510 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3512 DEFSYM (Qchar_table_p
, "char-table-p");
3513 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3515 DEFSYM (Qsubrp
, "subrp");
3516 DEFSYM (Qunevalled
, "unevalled");
3517 DEFSYM (Qmany
, "many");
3519 DEFSYM (Qcdr
, "cdr");
3521 error_tail
= pure_cons (Qerror
, Qnil
);
3523 /* ERROR is used as a signaler for random errors for which nothing else is
3526 Fput (Qerror
, Qerror_conditions
,
3528 Fput (Qerror
, Qerror_message
,
3529 build_pure_c_string ("error"));
3531 #define PUT_ERROR(sym, tail, msg) \
3532 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3533 Fput (sym, Qerror_message, build_pure_c_string (msg))
3535 PUT_ERROR (Qquit
, Qnil
, "Quit");
3537 PUT_ERROR (Quser_error
, error_tail
, "");
3538 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3539 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3540 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3541 PUT_ERROR (Qvoid_function
, error_tail
,
3542 "Symbol's function definition is void");
3543 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3544 "Symbol's chain of function indirections contains a loop");
3545 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3546 "Symbol's chain of variable indirections contains a loop");
3547 DEFSYM (Qcircular_list
, "circular-list");
3548 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3549 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3550 PUT_ERROR (Qsetting_constant
, error_tail
,
3551 "Attempt to set a constant symbol");
3552 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3553 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3554 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3555 "Wrong number of arguments");
3556 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3557 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3559 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3560 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3561 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3563 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3564 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3565 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3566 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3567 "Text is read-only");
3569 DEFSYM (Qrange_error
, "range-error");
3570 DEFSYM (Qdomain_error
, "domain-error");
3571 DEFSYM (Qsingularity_error
, "singularity-error");
3572 DEFSYM (Qoverflow_error
, "overflow-error");
3573 DEFSYM (Qunderflow_error
, "underflow-error");
3575 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3577 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3579 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3580 "Arithmetic singularity error");
3582 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3583 "Arithmetic overflow error");
3584 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3585 "Arithmetic underflow error");
3587 /* Types that type-of returns. */
3588 DEFSYM (Qinteger
, "integer");
3589 DEFSYM (Qsymbol
, "symbol");
3590 DEFSYM (Qstring
, "string");
3591 DEFSYM (Qcons
, "cons");
3592 DEFSYM (Qmarker
, "marker");
3593 DEFSYM (Qoverlay
, "overlay");
3594 DEFSYM (Qfinalizer
, "finalizer");
3596 DEFSYM (Quser_ptr
, "user-ptr");
3598 DEFSYM (Qfloat
, "float");
3599 DEFSYM (Qwindow_configuration
, "window-configuration");
3600 DEFSYM (Qprocess
, "process");
3601 DEFSYM (Qwindow
, "window");
3602 DEFSYM (Qcompiled_function
, "compiled-function");
3603 DEFSYM (Qbuffer
, "buffer");
3604 DEFSYM (Qframe
, "frame");
3605 DEFSYM (Qvector
, "vector");
3606 DEFSYM (Qchar_table
, "char-table");
3607 DEFSYM (Qbool_vector
, "bool-vector");
3608 DEFSYM (Qhash_table
, "hash-table");
3610 DEFSYM (Qdefun
, "defun");
3612 DEFSYM (Qfont_spec
, "font-spec");
3613 DEFSYM (Qfont_entity
, "font-entity");
3614 DEFSYM (Qfont_object
, "font-object");
3616 DEFSYM (Qinteractive_form
, "interactive-form");
3617 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3619 defsubr (&Sindirect_variable
);
3620 defsubr (&Sinteractive_form
);
3623 defsubr (&Stype_of
);
3628 defsubr (&Sintegerp
);
3629 defsubr (&Sinteger_or_marker_p
);
3630 defsubr (&Snumberp
);
3631 defsubr (&Snumber_or_marker_p
);
3633 defsubr (&Snatnump
);
3634 defsubr (&Ssymbolp
);
3635 defsubr (&Skeywordp
);
3636 defsubr (&Sstringp
);
3637 defsubr (&Smultibyte_string_p
);
3638 defsubr (&Svectorp
);
3639 defsubr (&Schar_table_p
);
3640 defsubr (&Svector_or_char_table_p
);
3641 defsubr (&Sbool_vector_p
);
3643 defsubr (&Ssequencep
);
3644 defsubr (&Sbufferp
);
3645 defsubr (&Smarkerp
);
3647 defsubr (&Sbyte_code_function_p
);
3648 defsubr (&Schar_or_string_p
);
3651 defsubr (&Scar_safe
);
3652 defsubr (&Scdr_safe
);
3655 defsubr (&Ssymbol_function
);
3656 defsubr (&Sindirect_function
);
3657 defsubr (&Ssymbol_plist
);
3658 defsubr (&Ssymbol_name
);
3659 defsubr (&Smakunbound
);
3660 defsubr (&Sfmakunbound
);
3662 defsubr (&Sfboundp
);
3664 defsubr (&Sdefalias
);
3665 defsubr (&Ssetplist
);
3666 defsubr (&Ssymbol_value
);
3668 defsubr (&Sdefault_boundp
);
3669 defsubr (&Sdefault_value
);
3670 defsubr (&Sset_default
);
3671 defsubr (&Ssetq_default
);
3672 defsubr (&Smake_variable_buffer_local
);
3673 defsubr (&Smake_local_variable
);
3674 defsubr (&Skill_local_variable
);
3675 defsubr (&Smake_variable_frame_local
);
3676 defsubr (&Slocal_variable_p
);
3677 defsubr (&Slocal_variable_if_set_p
);
3678 defsubr (&Svariable_binding_locus
);
3679 #if 0 /* XXX Remove this. --lorentey */
3680 defsubr (&Sterminal_local_value
);
3681 defsubr (&Sset_terminal_local_value
);
3685 defsubr (&Snumber_to_string
);
3686 defsubr (&Sstring_to_number
);
3687 defsubr (&Seqlsign
);
3709 defsubr (&Sbyteorder
);
3710 defsubr (&Ssubr_arity
);
3711 defsubr (&Ssubr_name
);
3713 defsubr (&Suser_ptrp
);
3716 defsubr (&Sbool_vector_exclusive_or
);
3717 defsubr (&Sbool_vector_union
);
3718 defsubr (&Sbool_vector_intersection
);
3719 defsubr (&Sbool_vector_set_difference
);
3720 defsubr (&Sbool_vector_not
);
3721 defsubr (&Sbool_vector_subsetp
);
3722 defsubr (&Sbool_vector_count_consecutive
);
3723 defsubr (&Sbool_vector_count_population
);
3725 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3727 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3728 doc
: /* The largest value that is representable in a Lisp integer. */);
3729 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3730 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3732 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3733 doc
: /* The smallest value that is representable in a Lisp integer. */);
3734 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3735 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;