1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include <count-one-bits.h>
26 #include <count-trailing-zeros.h>
31 #include "character.h"
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
:
230 case Lisp_Vectorlike
:
231 if (WINDOW_CONFIGURATIONP (object
))
232 return Qwindow_configuration
;
233 if (PROCESSP (object
))
235 if (WINDOWP (object
))
239 if (COMPILEDP (object
))
240 return Qcompiled_function
;
241 if (BUFFERP (object
))
243 if (CHAR_TABLE_P (object
))
245 if (BOOL_VECTOR_P (object
))
249 if (HASH_TABLE_P (object
))
251 if (FONT_SPEC_P (object
))
253 if (FONT_ENTITY_P (object
))
255 if (FONT_OBJECT_P (object
))
267 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
268 doc
: /* Return t if OBJECT is a cons cell. */
277 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
278 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */
287 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
288 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
289 Otherwise, return nil. */
293 if (CONSP (object
) || NILP (object
))
298 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
299 doc
: /* Return t if OBJECT is not a list. Lists include nil. */
303 if (CONSP (object
) || NILP (object
))
308 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
309 doc
: /* Return t if OBJECT is a symbol. */
313 if (SYMBOLP (object
))
318 /* Define this in C to avoid unnecessarily consing up the symbol
320 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a keyword.
322 This means that it is a symbol with a print name beginning with `:'
323 interned in the initial obarray. */)
327 && SREF (SYMBOL_NAME (object
), 0) == ':'
328 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
333 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is a vector. */)
337 if (VECTORP (object
))
342 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
343 doc
: /* Return t if OBJECT is a string. */
347 if (STRINGP (object
))
352 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
354 doc
: /* Return t if OBJECT is a multibyte string.
355 Return nil if OBJECT is either a unibyte string, or not a string. */)
358 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
363 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
364 doc
: /* Return t if OBJECT is a char-table. */)
367 if (CHAR_TABLE_P (object
))
372 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
373 Svector_or_char_table_p
, 1, 1, 0,
374 doc
: /* Return t if OBJECT is a char-table or vector. */)
377 if (VECTORP (object
) || CHAR_TABLE_P (object
))
382 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is a bool-vector. */)
386 if (BOOL_VECTOR_P (object
))
391 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
392 doc
: /* Return t if OBJECT is an array (string or vector). */)
400 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
401 doc
: /* Return t if OBJECT is a sequence (list or array). */)
402 (register Lisp_Object object
)
404 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
409 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
410 doc
: /* Return t if OBJECT is an editor buffer. */)
413 if (BUFFERP (object
))
418 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
422 if (MARKERP (object
))
427 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
428 doc
: /* Return t if OBJECT is a built-in function. */)
436 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
438 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
441 if (COMPILEDP (object
))
446 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
447 doc
: /* Return t if OBJECT is a character or a string. */
449 (register Lisp_Object object
)
451 if (CHARACTERP (object
) || STRINGP (object
))
456 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
457 doc
: /* Return t if OBJECT is an integer. */
461 if (INTEGERP (object
))
466 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
467 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
468 (register Lisp_Object object
)
470 if (MARKERP (object
) || INTEGERP (object
))
475 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
476 doc
: /* Return t if OBJECT is a nonnegative integer. */
480 if (NATNUMP (object
))
485 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
486 doc
: /* Return t if OBJECT is a number (floating point or integer). */
490 if (NUMBERP (object
))
496 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
497 Snumber_or_marker_p
, 1, 1, 0,
498 doc
: /* Return t if OBJECT is a number or a marker. */)
501 if (NUMBERP (object
) || MARKERP (object
))
506 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
507 doc
: /* Return t if OBJECT is a floating point number. */
517 /* Extract and set components of lists. */
519 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
520 doc
: /* Return the car of LIST. If arg is nil, return nil.
521 Error if arg is not nil and not a cons cell. See also `car-safe'.
523 See Info node `(elisp)Cons Cells' for a discussion of related basic
524 Lisp concepts such as car, cdr, cons cell and list. */)
525 (register Lisp_Object list
)
530 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
531 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
534 return CAR_SAFE (object
);
537 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
538 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
539 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
541 See Info node `(elisp)Cons Cells' for a discussion of related basic
542 Lisp concepts such as cdr, car, cons cell and list. */)
543 (register Lisp_Object list
)
548 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
549 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
552 return CDR_SAFE (object
);
555 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
556 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
557 (register Lisp_Object cell
, Lisp_Object newcar
)
560 CHECK_IMPURE (cell
, XCONS (cell
));
561 XSETCAR (cell
, newcar
);
565 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
566 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
567 (register Lisp_Object cell
, Lisp_Object newcdr
)
570 CHECK_IMPURE (cell
, XCONS (cell
));
571 XSETCDR (cell
, newcdr
);
575 /* Extract and set components of symbols. */
577 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
578 doc
: /* Return t if SYMBOL's value is not void.
579 Note that if `lexical-binding' is in effect, this refers to the
580 global value outside of any lexical scope. */)
581 (register Lisp_Object symbol
)
583 Lisp_Object valcontents
;
584 struct Lisp_Symbol
*sym
;
585 CHECK_SYMBOL (symbol
);
586 sym
= XSYMBOL (symbol
);
589 switch (sym
->redirect
)
591 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
592 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
593 case SYMBOL_LOCALIZED
:
595 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
597 /* In set_internal, we un-forward vars when their value is
602 swap_in_symval_forwarding (sym
, blv
);
603 valcontents
= blv_value (blv
);
607 case SYMBOL_FORWARDED
:
608 /* In set_internal, we un-forward vars when their value is
611 default: emacs_abort ();
614 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
617 /* FIXME: Make it an alias for function-symbol! */
618 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
619 doc
: /* Return t if SYMBOL's function definition is not void. */)
620 (register Lisp_Object symbol
)
622 CHECK_SYMBOL (symbol
);
623 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
626 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
627 doc
: /* Make SYMBOL's value be void.
629 (register Lisp_Object symbol
)
631 CHECK_SYMBOL (symbol
);
632 if (SYMBOL_CONSTANT_P (symbol
))
633 xsignal1 (Qsetting_constant
, symbol
);
634 Fset (symbol
, Qunbound
);
638 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
639 doc
: /* Make SYMBOL's function definition be nil.
641 (register Lisp_Object symbol
)
643 CHECK_SYMBOL (symbol
);
644 if (NILP (symbol
) || EQ (symbol
, Qt
))
645 xsignal1 (Qsetting_constant
, symbol
);
646 set_symbol_function (symbol
, Qnil
);
650 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
651 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
652 (register Lisp_Object symbol
)
654 CHECK_SYMBOL (symbol
);
655 return XSYMBOL (symbol
)->function
;
658 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
659 doc
: /* Return SYMBOL's property list. */)
660 (register Lisp_Object symbol
)
662 CHECK_SYMBOL (symbol
);
663 return XSYMBOL (symbol
)->plist
;
666 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
667 doc
: /* Return SYMBOL's name, a string. */)
668 (register Lisp_Object symbol
)
670 register Lisp_Object name
;
672 CHECK_SYMBOL (symbol
);
673 name
= SYMBOL_NAME (symbol
);
677 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
678 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
679 (register Lisp_Object symbol
, Lisp_Object definition
)
681 register Lisp_Object function
;
682 CHECK_SYMBOL (symbol
);
684 function
= XSYMBOL (symbol
)->function
;
686 if (!NILP (Vautoload_queue
) && !NILP (function
))
687 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
689 if (AUTOLOADP (function
))
690 Fput (symbol
, Qautoload
, XCDR (function
));
692 /* Convert to eassert or remove after GC bug is found. In the
693 meantime, check unconditionally, at a slight perf hit. */
694 if (! valid_lisp_object_p (definition
))
697 set_symbol_function (symbol
, definition
);
702 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
703 doc
: /* Set SYMBOL's function definition to DEFINITION.
704 Associates the function with the current load file, if any.
705 The optional third argument DOCSTRING specifies the documentation string
706 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
707 determined by DEFINITION.
709 Internally, this normally uses `fset', but if SYMBOL has a
710 `defalias-fset-function' property, the associated value is used instead.
712 The return value is undefined. */)
713 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
715 CHECK_SYMBOL (symbol
);
716 if (!NILP (Vpurify_flag
)
717 /* If `definition' is a keymap, immutable (and copying) is wrong. */
718 && !KEYMAPP (definition
))
719 definition
= Fpurecopy (definition
);
722 bool autoload
= AUTOLOADP (definition
);
723 if (NILP (Vpurify_flag
) || !autoload
)
724 { /* Only add autoload entries after dumping, because the ones before are
725 not useful and else we get loads of them from the loaddefs.el. */
727 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
728 /* Remember that the function was already an autoload. */
729 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
730 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
734 { /* Handle automatic advice activation. */
735 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
737 call2 (hook
, symbol
, definition
);
739 Ffset (symbol
, definition
);
742 if (!NILP (docstring
))
743 Fput (symbol
, Qfunction_documentation
, docstring
);
744 /* We used to return `definition', but now that `defun' and `defmacro' expand
745 to a call to `defalias', we return `symbol' for backward compatibility
750 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
751 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
752 (register Lisp_Object symbol
, Lisp_Object newplist
)
754 CHECK_SYMBOL (symbol
);
755 set_symbol_plist (symbol
, newplist
);
759 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
760 doc
: /* Return minimum and maximum number of args allowed for SUBR.
761 SUBR must be a built-in function.
762 The returned value is a pair (MIN . MAX). MIN is the minimum number
763 of args. MAX is the maximum number or the symbol `many', for a
764 function with `&rest' args, or `unevalled' for a special form. */)
767 short minargs
, maxargs
;
769 minargs
= XSUBR (subr
)->min_args
;
770 maxargs
= XSUBR (subr
)->max_args
;
771 return Fcons (make_number (minargs
),
772 maxargs
== MANY
? Qmany
773 : maxargs
== UNEVALLED
? Qunevalled
774 : make_number (maxargs
));
777 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
778 doc
: /* Return name of subroutine SUBR.
779 SUBR must be a built-in function. */)
784 name
= XSUBR (subr
)->symbol_name
;
785 return build_string (name
);
788 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
789 doc
: /* Return the interactive form of CMD or nil if none.
790 If CMD is not a command, the return value is nil.
791 Value, if non-nil, is a list (interactive SPEC). */)
794 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
799 /* Use an `interactive-form' property if present, analogous to the
800 function-documentation property. */
802 while (SYMBOLP (fun
))
804 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
808 fun
= Fsymbol_function (fun
);
813 const char *spec
= XSUBR (fun
)->intspec
;
815 return list2 (Qinteractive
,
816 (*spec
!= '(') ? build_string (spec
) :
817 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
819 else if (COMPILEDP (fun
))
821 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
822 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
824 else if (AUTOLOADP (fun
))
825 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
826 else if (CONSP (fun
))
828 Lisp_Object funcar
= XCAR (fun
);
829 if (EQ (funcar
, Qclosure
))
830 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
831 else if (EQ (funcar
, Qlambda
))
832 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
838 /***********************************************************************
839 Getting and Setting Values of Symbols
840 ***********************************************************************/
842 /* Return the symbol holding SYMBOL's value. Signal
843 `cyclic-variable-indirection' if SYMBOL's chain of variable
844 indirections contains a loop. */
847 indirect_variable (struct Lisp_Symbol
*symbol
)
849 struct Lisp_Symbol
*tortoise
, *hare
;
851 hare
= tortoise
= symbol
;
853 while (hare
->redirect
== SYMBOL_VARALIAS
)
855 hare
= SYMBOL_ALIAS (hare
);
856 if (hare
->redirect
!= SYMBOL_VARALIAS
)
859 hare
= SYMBOL_ALIAS (hare
);
860 tortoise
= SYMBOL_ALIAS (tortoise
);
862 if (hare
== tortoise
)
865 XSETSYMBOL (tem
, symbol
);
866 xsignal1 (Qcyclic_variable_indirection
, tem
);
874 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
875 doc
: /* Return the variable at the end of OBJECT's variable chain.
876 If OBJECT is a symbol, follow its variable indirections (if any), and
877 return the variable at the end of the chain of aliases. See Info node
878 `(elisp)Variable Aliases'.
880 If OBJECT is not a symbol, just return it. If there is a loop in the
881 chain of aliases, signal a `cyclic-variable-indirection' error. */)
884 if (SYMBOLP (object
))
886 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
887 XSETSYMBOL (object
, sym
);
893 /* Given the raw contents of a symbol value cell,
894 return the Lisp value of the symbol.
895 This does not handle buffer-local variables; use
896 swap_in_symval_forwarding for that. */
899 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
901 register Lisp_Object val
;
902 switch (XFWDTYPE (valcontents
))
905 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
909 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
912 return *XOBJFWD (valcontents
)->objvar
;
914 case Lisp_Fwd_Buffer_Obj
:
915 return per_buffer_value (current_buffer
,
916 XBUFFER_OBJFWD (valcontents
)->offset
);
918 case Lisp_Fwd_Kboard_Obj
:
919 /* We used to simply use current_kboard here, but from Lisp
920 code, its value is often unexpected. It seems nicer to
921 allow constructions like this to work as intuitively expected:
923 (with-selected-frame frame
924 (define-key local-function-map "\eOP" [f1]))
926 On the other hand, this affects the semantics of
927 last-command and real-last-command, and people may rely on
928 that. I took a quick look at the Lisp codebase, and I
929 don't think anything will break. --lorentey */
930 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
931 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
932 default: emacs_abort ();
936 /* Used to signal a user-friendly error when symbol WRONG is
937 not a member of CHOICE, which should be a list of symbols. */
940 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
942 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
943 Lisp_Object obj
, *args
;
944 AUTO_STRING (one_of
, "One of ");
945 AUTO_STRING (comma
, ", ");
946 AUTO_STRING (or, " or ");
947 AUTO_STRING (should_be_specified
, " should be specified");
950 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
954 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
956 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
957 args
[i
++] = (NILP (XCDR (obj
)) ? should_be_specified
958 : NILP (XCDR (XCDR (obj
))) ? or : comma
);
961 obj
= Fconcat (i
, args
);
963 xsignal2 (Qerror
, obj
, wrong
);
966 /* Used to signal a user-friendly error if WRONG is not a number or
967 integer/floating-point number outsize of inclusive MIN..MAX range. */
970 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
972 AUTO_STRING (value_should_be_from
, "Value should be from ");
973 AUTO_STRING (to
, " to ");
975 CALLN (Fconcat
, value_should_be_from
, Fnumber_to_string (min
),
976 to
, Fnumber_to_string (max
)),
980 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
981 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
982 buffer-independent contents of the value cell: forwarded just one
983 step past the buffer-localness.
985 BUF non-zero means set the value in buffer BUF instead of the
986 current buffer. This only plays a role for per-buffer variables. */
989 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
991 switch (XFWDTYPE (valcontents
))
994 CHECK_NUMBER (newval
);
995 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
999 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1003 *XOBJFWD (valcontents
)->objvar
= newval
;
1005 /* If this variable is a default for something stored
1006 in the buffer itself, such as default-fill-column,
1007 find the buffers that don't have local values for it
1009 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1010 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1012 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1013 - (char *) &buffer_defaults
);
1014 int idx
= PER_BUFFER_IDX (offset
);
1016 Lisp_Object tail
, buf
;
1021 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1023 struct buffer
*b
= XBUFFER (buf
);
1025 if (! PER_BUFFER_VALUE_P (b
, idx
))
1026 set_per_buffer_value (b
, offset
, newval
);
1031 case Lisp_Fwd_Buffer_Obj
:
1033 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1034 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1038 if (SYMBOLP (predicate
))
1042 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1044 if (NILP (Fmemq (newval
, prop
)))
1045 wrong_choice (prop
, newval
);
1047 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1049 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1051 if (!NUMBERP (newval
)
1052 || !NILP (arithcompare (newval
, min
, ARITH_LESS
))
1053 || !NILP (arithcompare (newval
, max
, ARITH_GRTR
)))
1054 wrong_range (min
, max
, newval
);
1056 else if (FUNCTIONP (predicate
))
1058 if (NILP (call1 (predicate
, newval
)))
1059 wrong_type_argument (predicate
, newval
);
1064 buf
= current_buffer
;
1065 set_per_buffer_value (buf
, offset
, newval
);
1069 case Lisp_Fwd_Kboard_Obj
:
1071 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1072 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1073 *(Lisp_Object
*) p
= newval
;
1078 emacs_abort (); /* goto def; */
1082 /* Set up SYMBOL to refer to its global binding. This makes it safe
1083 to alter the status of other bindings. BEWARE: this may be called
1084 during the mark phase of GC, where we assume that Lisp_Object slots
1085 of BLV are marked after this function has changed them. */
1088 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1090 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1092 /* Unload the previously loaded binding. */
1094 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1096 /* Select the global binding in the symbol. */
1097 set_blv_valcell (blv
, blv
->defcell
);
1099 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1101 /* Indicate that the global binding is set up now. */
1102 set_blv_where (blv
, Qnil
);
1103 set_blv_found (blv
, 0);
1106 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1107 VALCONTENTS is the contents of its value cell,
1108 which points to a struct Lisp_Buffer_Local_Value.
1110 Return the value forwarded one step past the buffer-local stage.
1111 This could be another forwarding pointer. */
1114 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1116 register Lisp_Object tem1
;
1118 eassert (blv
== SYMBOL_BLV (symbol
));
1123 || (blv
->frame_local
1124 ? !EQ (selected_frame
, tem1
)
1125 : current_buffer
!= XBUFFER (tem1
)))
1128 /* Unload the previously loaded binding. */
1129 tem1
= blv
->valcell
;
1131 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1132 /* Choose the new binding. */
1135 XSETSYMBOL (var
, symbol
);
1136 if (blv
->frame_local
)
1138 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1139 set_blv_where (blv
, selected_frame
);
1143 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1144 set_blv_where (blv
, Fcurrent_buffer ());
1147 if (!(blv
->found
= !NILP (tem1
)))
1148 tem1
= blv
->defcell
;
1150 /* Load the new binding. */
1151 set_blv_valcell (blv
, tem1
);
1153 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1157 /* Find the value of a symbol, returning Qunbound if it's not bound.
1158 This is helpful for code which just wants to get a variable's value
1159 if it has one, without signaling an error.
1160 Note that it must not be possible to quit
1161 within this function. Great care is required for this. */
1164 find_symbol_value (Lisp_Object symbol
)
1166 struct Lisp_Symbol
*sym
;
1168 CHECK_SYMBOL (symbol
);
1169 sym
= XSYMBOL (symbol
);
1172 switch (sym
->redirect
)
1174 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1175 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1176 case SYMBOL_LOCALIZED
:
1178 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1179 swap_in_symval_forwarding (sym
, blv
);
1180 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1183 case SYMBOL_FORWARDED
:
1184 return do_symval_forwarding (SYMBOL_FWD (sym
));
1185 default: emacs_abort ();
1189 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1190 doc
: /* Return SYMBOL's value. Error if that is void.
1191 Note that if `lexical-binding' is in effect, this returns the
1192 global value outside of any lexical scope. */)
1193 (Lisp_Object symbol
)
1197 val
= find_symbol_value (symbol
);
1198 if (!EQ (val
, Qunbound
))
1201 xsignal1 (Qvoid_variable
, symbol
);
1204 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1205 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1206 (register Lisp_Object symbol
, Lisp_Object newval
)
1208 set_internal (symbol
, newval
, Qnil
, 0);
1212 /* Store the value NEWVAL into SYMBOL.
1213 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1214 (nil stands for the current buffer/frame).
1216 If BINDFLAG is false, then if this symbol is supposed to become
1217 local in every buffer where it is set, then we make it local.
1218 If BINDFLAG is true, we don't do that. */
1221 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1224 bool voide
= EQ (newval
, Qunbound
);
1225 struct Lisp_Symbol
*sym
;
1228 /* If restoring in a dead buffer, do nothing. */
1229 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1232 CHECK_SYMBOL (symbol
);
1233 if (SYMBOL_CONSTANT_P (symbol
))
1235 if (NILP (Fkeywordp (symbol
))
1236 || !EQ (newval
, Fsymbol_value (symbol
)))
1237 xsignal1 (Qsetting_constant
, symbol
);
1239 /* Allow setting keywords to their own value. */
1243 sym
= XSYMBOL (symbol
);
1246 switch (sym
->redirect
)
1248 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1249 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1250 case SYMBOL_LOCALIZED
:
1252 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1255 if (blv
->frame_local
)
1256 where
= selected_frame
;
1258 XSETBUFFER (where
, current_buffer
);
1260 /* If the current buffer is not the buffer whose binding is
1261 loaded, or if there may be frame-local bindings and the frame
1262 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1263 the default binding is loaded, the loaded binding may be the
1265 if (!EQ (blv
->where
, where
)
1266 /* Also unload a global binding (if the var is local_if_set). */
1267 || (EQ (blv
->valcell
, blv
->defcell
)))
1269 /* The currently loaded binding is not necessarily valid.
1270 We need to unload it, and choose a new binding. */
1272 /* Write out `realvalue' to the old loaded binding. */
1274 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1276 /* Find the new binding. */
1277 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1278 tem1
= assq_no_quit (symbol
,
1280 ? XFRAME (where
)->param_alist
1281 : BVAR (XBUFFER (where
), local_var_alist
)));
1282 set_blv_where (blv
, where
);
1287 /* This buffer still sees the default value. */
1289 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1290 or if this is `let' rather than `set',
1291 make CURRENT-ALIST-ELEMENT point to itself,
1292 indicating that we're seeing the default value.
1293 Likewise if the variable has been let-bound
1294 in the current buffer. */
1295 if (bindflag
|| !blv
->local_if_set
1296 || let_shadows_buffer_binding_p (sym
))
1299 tem1
= blv
->defcell
;
1301 /* If it's a local_if_set, being set not bound,
1302 and we're not within a let that was made for this buffer,
1303 create a new buffer-local binding for the variable.
1304 That means, give this buffer a new assoc for a local value
1305 and load that binding. */
1308 /* local_if_set is only supported for buffer-local
1309 bindings, not for frame-local bindings. */
1310 eassert (!blv
->frame_local
);
1311 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1312 bset_local_var_alist
1314 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1318 /* Record which binding is now loaded. */
1319 set_blv_valcell (blv
, tem1
);
1322 /* Store the new value in the cons cell. */
1323 set_blv_value (blv
, newval
);
1328 /* If storing void (making the symbol void), forward only through
1329 buffer-local indicator, not through Lisp_Objfwd, etc. */
1332 store_symval_forwarding (blv
->fwd
, newval
,
1334 ? XBUFFER (where
) : current_buffer
);
1338 case SYMBOL_FORWARDED
:
1341 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1342 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1343 if (BUFFER_OBJFWDP (innercontents
))
1345 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1346 int idx
= PER_BUFFER_IDX (offset
);
1349 && !let_shadows_buffer_binding_p (sym
))
1350 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1354 { /* If storing void (making the symbol void), forward only through
1355 buffer-local indicator, not through Lisp_Objfwd, etc. */
1356 sym
->redirect
= SYMBOL_PLAINVAL
;
1357 SET_SYMBOL_VAL (sym
, newval
);
1360 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1363 default: emacs_abort ();
1368 /* Access or set a buffer-local symbol's default value. */
1370 /* Return the default value of SYMBOL, but don't check for voidness.
1371 Return Qunbound if it is void. */
1374 default_value (Lisp_Object symbol
)
1376 struct Lisp_Symbol
*sym
;
1378 CHECK_SYMBOL (symbol
);
1379 sym
= XSYMBOL (symbol
);
1382 switch (sym
->redirect
)
1384 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1385 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1386 case SYMBOL_LOCALIZED
:
1388 /* If var is set up for a buffer that lacks a local value for it,
1389 the current value is nominally the default value.
1390 But the `realvalue' slot may be more up to date, since
1391 ordinary setq stores just that slot. So use that. */
1392 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1393 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1394 return do_symval_forwarding (blv
->fwd
);
1396 return XCDR (blv
->defcell
);
1398 case SYMBOL_FORWARDED
:
1400 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1402 /* For a built-in buffer-local variable, get the default value
1403 rather than letting do_symval_forwarding get the current value. */
1404 if (BUFFER_OBJFWDP (valcontents
))
1406 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1407 if (PER_BUFFER_IDX (offset
) != 0)
1408 return per_buffer_default (offset
);
1411 /* For other variables, get the current value. */
1412 return do_symval_forwarding (valcontents
);
1414 default: emacs_abort ();
1418 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1419 doc
: /* Return t if SYMBOL has a non-void default value.
1420 This is the value that is seen in buffers that do not have their own values
1421 for this variable. */)
1422 (Lisp_Object symbol
)
1424 register Lisp_Object value
;
1426 value
= default_value (symbol
);
1427 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1430 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1431 doc
: /* Return SYMBOL's default value.
1432 This is the value that is seen in buffers that do not have their own values
1433 for this variable. The default value is meaningful for variables with
1434 local bindings in certain buffers. */)
1435 (Lisp_Object symbol
)
1437 Lisp_Object value
= default_value (symbol
);
1438 if (!EQ (value
, Qunbound
))
1441 xsignal1 (Qvoid_variable
, symbol
);
1444 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1445 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1446 The default value is seen in buffers that do not have their own values
1447 for this variable. */)
1448 (Lisp_Object symbol
, Lisp_Object value
)
1450 struct Lisp_Symbol
*sym
;
1452 CHECK_SYMBOL (symbol
);
1453 if (SYMBOL_CONSTANT_P (symbol
))
1455 if (NILP (Fkeywordp (symbol
))
1456 || !EQ (value
, Fdefault_value (symbol
)))
1457 xsignal1 (Qsetting_constant
, symbol
);
1459 /* Allow setting keywords to their own value. */
1462 sym
= XSYMBOL (symbol
);
1465 switch (sym
->redirect
)
1467 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1468 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1469 case SYMBOL_LOCALIZED
:
1471 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1473 /* Store new value into the DEFAULT-VALUE slot. */
1474 XSETCDR (blv
->defcell
, value
);
1476 /* If the default binding is now loaded, set the REALVALUE slot too. */
1477 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1478 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1481 case SYMBOL_FORWARDED
:
1483 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1485 /* Handle variables like case-fold-search that have special slots
1487 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1488 if (BUFFER_OBJFWDP (valcontents
))
1490 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1491 int idx
= PER_BUFFER_IDX (offset
);
1493 set_per_buffer_default (offset
, value
);
1495 /* If this variable is not always local in all buffers,
1496 set it in the buffers that don't nominally have a local value. */
1502 if (!PER_BUFFER_VALUE_P (b
, idx
))
1503 set_per_buffer_value (b
, offset
, value
);
1508 return Fset (symbol
, value
);
1510 default: emacs_abort ();
1514 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1515 doc
: /* Set the default value of variable VAR to VALUE.
1516 VAR, the variable name, is literal (not evaluated);
1517 VALUE is an expression: it is evaluated and its value returned.
1518 The default value of a variable is seen in buffers
1519 that do not have their own values for the variable.
1521 More generally, you can use multiple variables and values, as in
1522 (setq-default VAR VALUE VAR VALUE...)
1523 This sets each VAR's default value to the corresponding VALUE.
1524 The VALUE for the Nth VAR can refer to the new default values
1526 usage: (setq-default [VAR VALUE]...) */)
1529 Lisp_Object args_left
, symbol
, val
;
1531 args_left
= val
= args
;
1533 while (CONSP (args_left
))
1535 val
= eval_sub (Fcar (XCDR (args_left
)));
1536 symbol
= XCAR (args_left
);
1537 Fset_default (symbol
, val
);
1538 args_left
= Fcdr (XCDR (args_left
));
1544 /* Lisp functions for creating and removing buffer-local variables. */
1549 union Lisp_Fwd
*fwd
;
1552 static struct Lisp_Buffer_Local_Value
*
1553 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1554 union Lisp_Val_Fwd valcontents
)
1556 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1560 XSETSYMBOL (symbol
, sym
);
1561 tem
= Fcons (symbol
, (forwarded
1562 ? do_symval_forwarding (valcontents
.fwd
)
1563 : valcontents
.value
));
1565 /* Buffer_Local_Values cannot have as realval a buffer-local
1566 or keyboard-local forwarding. */
1567 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1568 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1569 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1570 set_blv_where (blv
, Qnil
);
1571 blv
->frame_local
= 0;
1572 blv
->local_if_set
= 0;
1573 set_blv_defcell (blv
, tem
);
1574 set_blv_valcell (blv
, tem
);
1575 set_blv_found (blv
, 0);
1579 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1580 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1581 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1582 At any time, the value for the current buffer is in effect,
1583 unless the variable has never been set in this buffer,
1584 in which case the default value is in effect.
1585 Note that binding the variable with `let', or setting it while
1586 a `let'-style binding made in this buffer is in effect,
1587 does not make the variable buffer-local. Return VARIABLE.
1589 This globally affects all uses of this variable, so it belongs together with
1590 the variable declaration, rather than with its uses (if you just want to make
1591 a variable local to the current buffer for one particular use, use
1592 `make-local-variable'). Buffer-local bindings are normally cleared
1593 while setting up a new major mode, unless they have a `permanent-local'
1596 The function `default-value' gets the default value and `set-default' sets it. */)
1597 (register Lisp_Object variable
)
1599 struct Lisp_Symbol
*sym
;
1600 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1601 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1602 bool forwarded
IF_LINT (= 0);
1604 CHECK_SYMBOL (variable
);
1605 sym
= XSYMBOL (variable
);
1608 switch (sym
->redirect
)
1610 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1611 case SYMBOL_PLAINVAL
:
1612 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1613 if (EQ (valcontents
.value
, Qunbound
))
1614 valcontents
.value
= Qnil
;
1616 case SYMBOL_LOCALIZED
:
1617 blv
= SYMBOL_BLV (sym
);
1618 if (blv
->frame_local
)
1619 error ("Symbol %s may not be buffer-local",
1620 SDATA (SYMBOL_NAME (variable
)));
1622 case SYMBOL_FORWARDED
:
1623 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1624 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1625 error ("Symbol %s may not be buffer-local",
1626 SDATA (SYMBOL_NAME (variable
)));
1627 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1630 default: emacs_abort ();
1634 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1638 blv
= make_blv (sym
, forwarded
, valcontents
);
1639 sym
->redirect
= SYMBOL_LOCALIZED
;
1640 SET_SYMBOL_BLV (sym
, blv
);
1643 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1644 if (let_shadows_global_binding_p (symbol
))
1646 AUTO_STRING (format
, "Making %s buffer-local while let-bound!");
1647 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1652 blv
->local_if_set
= 1;
1656 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1657 1, 1, "vMake Local Variable: ",
1658 doc
: /* Make VARIABLE have a separate value in the current buffer.
1659 Other buffers will continue to share a common default value.
1660 (The buffer-local value of VARIABLE starts out as the same value
1661 VARIABLE previously had. If VARIABLE was void, it remains void.)
1664 If the variable is already arranged to become local when set,
1665 this function causes a local value to exist for this buffer,
1666 just as setting the variable would do.
1668 This function returns VARIABLE, and therefore
1669 (set (make-local-variable \\='VARIABLE) VALUE-EXP)
1672 See also `make-variable-buffer-local'.
1674 Do not use `make-local-variable' to make a hook variable buffer-local.
1675 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1676 (Lisp_Object variable
)
1679 bool forwarded
IF_LINT (= 0);
1680 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1681 struct Lisp_Symbol
*sym
;
1682 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1684 CHECK_SYMBOL (variable
);
1685 sym
= XSYMBOL (variable
);
1688 switch (sym
->redirect
)
1690 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1691 case SYMBOL_PLAINVAL
:
1692 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1693 case SYMBOL_LOCALIZED
:
1694 blv
= SYMBOL_BLV (sym
);
1695 if (blv
->frame_local
)
1696 error ("Symbol %s may not be buffer-local",
1697 SDATA (SYMBOL_NAME (variable
)));
1699 case SYMBOL_FORWARDED
:
1700 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1701 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1702 error ("Symbol %s may not be buffer-local",
1703 SDATA (SYMBOL_NAME (variable
)));
1705 default: emacs_abort ();
1709 error ("Symbol %s may not be buffer-local",
1710 SDATA (SYMBOL_NAME (variable
)));
1712 if (blv
? blv
->local_if_set
1713 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1715 tem
= Fboundp (variable
);
1716 /* Make sure the symbol has a local value in this particular buffer,
1717 by setting it to the same value it already has. */
1718 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1723 blv
= make_blv (sym
, forwarded
, valcontents
);
1724 sym
->redirect
= SYMBOL_LOCALIZED
;
1725 SET_SYMBOL_BLV (sym
, blv
);
1728 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1729 if (let_shadows_global_binding_p (symbol
))
1731 AUTO_STRING (format
, "Making %s local to %s while let-bound!");
1732 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
),
1733 BVAR (current_buffer
, name
));
1738 /* Make sure this buffer has its own value of symbol. */
1739 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1740 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1743 if (let_shadows_buffer_binding_p (sym
))
1745 AUTO_STRING (format
,
1746 "Making %s buffer-local while locally let-bound!");
1747 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1750 /* Swap out any local binding for some other buffer, and make
1751 sure the current value is permanently recorded, if it's the
1753 find_symbol_value (variable
);
1755 bset_local_var_alist
1757 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1758 BVAR (current_buffer
, local_var_alist
)));
1760 /* Make sure symbol does not think it is set up for this buffer;
1761 force it to look once again for this buffer's value. */
1762 if (current_buffer
== XBUFFER (blv
->where
))
1763 set_blv_where (blv
, Qnil
);
1764 set_blv_found (blv
, 0);
1767 /* If the symbol forwards into a C variable, then load the binding
1768 for this buffer now. If C code modifies the variable before we
1769 load the binding in, then that new value will clobber the default
1770 binding the next time we unload it. */
1772 swap_in_symval_forwarding (sym
, blv
);
1777 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1778 1, 1, "vKill Local Variable: ",
1779 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1780 From now on the default value will apply in this buffer. Return VARIABLE. */)
1781 (register Lisp_Object variable
)
1783 register Lisp_Object tem
;
1784 struct Lisp_Buffer_Local_Value
*blv
;
1785 struct Lisp_Symbol
*sym
;
1787 CHECK_SYMBOL (variable
);
1788 sym
= XSYMBOL (variable
);
1791 switch (sym
->redirect
)
1793 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1794 case SYMBOL_PLAINVAL
: return variable
;
1795 case SYMBOL_FORWARDED
:
1797 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1798 if (BUFFER_OBJFWDP (valcontents
))
1800 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1801 int idx
= PER_BUFFER_IDX (offset
);
1805 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1806 set_per_buffer_value (current_buffer
, offset
,
1807 per_buffer_default (offset
));
1812 case SYMBOL_LOCALIZED
:
1813 blv
= SYMBOL_BLV (sym
);
1814 if (blv
->frame_local
)
1817 default: emacs_abort ();
1820 /* Get rid of this buffer's alist element, if any. */
1821 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1822 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1824 bset_local_var_alist
1826 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1828 /* If the symbol is set up with the current buffer's binding
1829 loaded, recompute its value. We have to do it now, or else
1830 forwarded objects won't work right. */
1832 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1833 if (EQ (buf
, blv
->where
))
1835 set_blv_where (blv
, Qnil
);
1837 find_symbol_value (variable
);
1844 /* Lisp functions for creating and removing buffer-local variables. */
1846 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1847 when/if this is removed. */
1849 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1850 1, 1, "vMake Variable Frame Local: ",
1851 doc
: /* Enable VARIABLE to have frame-local bindings.
1852 This does not create any frame-local bindings for VARIABLE,
1853 it just makes them possible.
1855 A frame-local binding is actually a frame parameter value.
1856 If a frame F has a value for the frame parameter named VARIABLE,
1857 that also acts as a frame-local binding for VARIABLE in F--
1858 provided this function has been called to enable VARIABLE
1859 to have frame-local bindings at all.
1861 The only way to create a frame-local binding for VARIABLE in a frame
1862 is to set the VARIABLE frame parameter of that frame. See
1863 `modify-frame-parameters' for how to set frame parameters.
1865 Note that since Emacs 23.1, variables cannot be both buffer-local and
1866 frame-local any more (buffer-local bindings used to take precedence over
1867 frame-local bindings). */)
1868 (Lisp_Object variable
)
1871 union Lisp_Val_Fwd valcontents
;
1872 struct Lisp_Symbol
*sym
;
1873 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1875 CHECK_SYMBOL (variable
);
1876 sym
= XSYMBOL (variable
);
1879 switch (sym
->redirect
)
1881 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1882 case SYMBOL_PLAINVAL
:
1883 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1884 if (EQ (valcontents
.value
, Qunbound
))
1885 valcontents
.value
= Qnil
;
1887 case SYMBOL_LOCALIZED
:
1888 if (SYMBOL_BLV (sym
)->frame_local
)
1891 error ("Symbol %s may not be frame-local",
1892 SDATA (SYMBOL_NAME (variable
)));
1893 case SYMBOL_FORWARDED
:
1894 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1895 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1896 error ("Symbol %s may not be frame-local",
1897 SDATA (SYMBOL_NAME (variable
)));
1899 default: emacs_abort ();
1903 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1905 blv
= make_blv (sym
, forwarded
, valcontents
);
1906 blv
->frame_local
= 1;
1907 sym
->redirect
= SYMBOL_LOCALIZED
;
1908 SET_SYMBOL_BLV (sym
, blv
);
1911 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1912 if (let_shadows_global_binding_p (symbol
))
1914 AUTO_STRING (format
, "Making %s frame-local while let-bound!");
1915 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1921 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1923 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1924 BUFFER defaults to the current buffer. */)
1925 (Lisp_Object variable
, Lisp_Object buffer
)
1927 struct buffer
*buf
= decode_buffer (buffer
);
1928 struct Lisp_Symbol
*sym
;
1930 CHECK_SYMBOL (variable
);
1931 sym
= XSYMBOL (variable
);
1934 switch (sym
->redirect
)
1936 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1937 case SYMBOL_PLAINVAL
: return Qnil
;
1938 case SYMBOL_LOCALIZED
:
1940 Lisp_Object tail
, elt
, tmp
;
1941 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1942 XSETBUFFER (tmp
, buf
);
1943 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1945 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1946 return blv_found (blv
) ? Qt
: Qnil
;
1948 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1951 if (EQ (variable
, XCAR (elt
)))
1953 eassert (!blv
->frame_local
);
1959 case SYMBOL_FORWARDED
:
1961 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1962 if (BUFFER_OBJFWDP (valcontents
))
1964 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1965 int idx
= PER_BUFFER_IDX (offset
);
1966 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1971 default: emacs_abort ();
1975 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1977 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1978 BUFFER defaults to the current buffer.
1980 More precisely, return non-nil if either VARIABLE already has a local
1981 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1982 `make-variable-buffer-local'). */)
1983 (register Lisp_Object variable
, Lisp_Object buffer
)
1985 struct Lisp_Symbol
*sym
;
1987 CHECK_SYMBOL (variable
);
1988 sym
= XSYMBOL (variable
);
1991 switch (sym
->redirect
)
1993 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1994 case SYMBOL_PLAINVAL
: return Qnil
;
1995 case SYMBOL_LOCALIZED
:
1997 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1998 if (blv
->local_if_set
)
2000 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2001 return Flocal_variable_p (variable
, buffer
);
2003 case SYMBOL_FORWARDED
:
2004 /* All BUFFER_OBJFWD slots become local if they are set. */
2005 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2006 default: emacs_abort ();
2010 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2012 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2013 If the current binding is buffer-local, the value is the current buffer.
2014 If the current binding is frame-local, the value is the selected frame.
2015 If the current binding is global (the default), the value is nil. */)
2016 (register Lisp_Object variable
)
2018 struct Lisp_Symbol
*sym
;
2020 CHECK_SYMBOL (variable
);
2021 sym
= XSYMBOL (variable
);
2023 /* Make sure the current binding is actually swapped in. */
2024 find_symbol_value (variable
);
2027 switch (sym
->redirect
)
2029 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2030 case SYMBOL_PLAINVAL
: return Qnil
;
2031 case SYMBOL_FORWARDED
:
2033 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2034 if (KBOARD_OBJFWDP (valcontents
))
2035 return Fframe_terminal (selected_frame
);
2036 else if (!BUFFER_OBJFWDP (valcontents
))
2040 case SYMBOL_LOCALIZED
:
2041 /* For a local variable, record both the symbol and which
2042 buffer's or frame's value we are saving. */
2043 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2044 return Fcurrent_buffer ();
2045 else if (sym
->redirect
== SYMBOL_LOCALIZED
2046 && blv_found (SYMBOL_BLV (sym
)))
2047 return SYMBOL_BLV (sym
)->where
;
2050 default: emacs_abort ();
2054 /* This code is disabled now that we use the selected frame to return
2055 keyboard-local-values. */
2057 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2059 DEFUN ("terminal-local-value", Fterminal_local_value
,
2060 Sterminal_local_value
, 2, 2, 0,
2061 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2062 If SYMBOL is not a terminal-local variable, then return its normal
2063 value, like `symbol-value'.
2065 TERMINAL may be a terminal object, a frame, or nil (meaning the
2066 selected frame's terminal device). */)
2067 (Lisp_Object symbol
, Lisp_Object terminal
)
2070 struct terminal
*t
= get_terminal (terminal
, 1);
2071 push_kboard (t
->kboard
);
2072 result
= Fsymbol_value (symbol
);
2077 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2078 Sset_terminal_local_value
, 3, 3, 0,
2079 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2080 If VARIABLE is not a terminal-local variable, then set its normal
2081 binding, like `set'.
2083 TERMINAL may be a terminal object, a frame, or nil (meaning the
2084 selected frame's terminal device). */)
2085 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2088 struct terminal
*t
= get_terminal (terminal
, 1);
2089 push_kboard (d
->kboard
);
2090 result
= Fset (symbol
, value
);
2096 /* Find the function at the end of a chain of symbol function indirections. */
2098 /* If OBJECT is a symbol, find the end of its function chain and
2099 return the value found there. If OBJECT is not a symbol, just
2100 return it. If there is a cycle in the function chain, signal a
2101 cyclic-function-indirection error.
2103 This is like Findirect_function, except that it doesn't signal an
2104 error if the chain ends up unbound. */
2106 indirect_function (register Lisp_Object object
)
2108 Lisp_Object tortoise
, hare
;
2110 hare
= tortoise
= object
;
2114 if (!SYMBOLP (hare
) || NILP (hare
))
2116 hare
= XSYMBOL (hare
)->function
;
2117 if (!SYMBOLP (hare
) || NILP (hare
))
2119 hare
= XSYMBOL (hare
)->function
;
2121 tortoise
= XSYMBOL (tortoise
)->function
;
2123 if (EQ (hare
, tortoise
))
2124 xsignal1 (Qcyclic_function_indirection
, object
);
2130 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2131 doc
: /* Return the function at the end of OBJECT's function chain.
2132 If OBJECT is not a symbol, just return it. Otherwise, follow all
2133 function indirections to find the final function binding and return it.
2134 Signal a cyclic-function-indirection error if there is a loop in the
2135 function chain of symbols. */)
2136 (register Lisp_Object object
, Lisp_Object noerror
)
2140 /* Optimize for no indirection. */
2142 if (SYMBOLP (result
) && !NILP (result
)
2143 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2144 result
= indirect_function (result
);
2151 /* Extract and set vector and string elements. */
2153 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2154 doc
: /* Return the element of ARRAY at index IDX.
2155 ARRAY may be a vector, a string, a char-table, a bool-vector,
2156 or a byte-code object. IDX starts at 0. */)
2157 (register Lisp_Object array
, Lisp_Object idx
)
2159 register EMACS_INT idxval
;
2162 idxval
= XINT (idx
);
2163 if (STRINGP (array
))
2166 ptrdiff_t idxval_byte
;
2168 if (idxval
< 0 || idxval
>= SCHARS (array
))
2169 args_out_of_range (array
, idx
);
2170 if (! STRING_MULTIBYTE (array
))
2171 return make_number ((unsigned char) SREF (array
, idxval
));
2172 idxval_byte
= string_char_to_byte (array
, idxval
);
2174 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2175 return make_number (c
);
2177 else if (BOOL_VECTOR_P (array
))
2179 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2180 args_out_of_range (array
, idx
);
2181 return bool_vector_ref (array
, idxval
);
2183 else if (CHAR_TABLE_P (array
))
2185 CHECK_CHARACTER (idx
);
2186 return CHAR_TABLE_REF (array
, idxval
);
2191 if (VECTORP (array
))
2192 size
= ASIZE (array
);
2193 else if (COMPILEDP (array
))
2194 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2196 wrong_type_argument (Qarrayp
, array
);
2198 if (idxval
< 0 || idxval
>= size
)
2199 args_out_of_range (array
, idx
);
2200 return AREF (array
, idxval
);
2204 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2205 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2206 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2207 bool-vector. IDX starts at 0. */)
2208 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2210 register EMACS_INT idxval
;
2213 idxval
= XINT (idx
);
2214 CHECK_ARRAY (array
, Qarrayp
);
2216 if (VECTORP (array
))
2218 CHECK_IMPURE (array
, XVECTOR (array
));
2219 if (idxval
< 0 || idxval
>= ASIZE (array
))
2220 args_out_of_range (array
, idx
);
2221 ASET (array
, idxval
, newelt
);
2223 else if (BOOL_VECTOR_P (array
))
2225 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2226 args_out_of_range (array
, idx
);
2227 bool_vector_set (array
, idxval
, !NILP (newelt
));
2229 else if (CHAR_TABLE_P (array
))
2231 CHECK_CHARACTER (idx
);
2232 CHAR_TABLE_SET (array
, idxval
, newelt
);
2238 CHECK_IMPURE (array
, XSTRING (array
));
2239 if (idxval
< 0 || idxval
>= SCHARS (array
))
2240 args_out_of_range (array
, idx
);
2241 CHECK_CHARACTER (newelt
);
2242 c
= XFASTINT (newelt
);
2244 if (STRING_MULTIBYTE (array
))
2246 ptrdiff_t idxval_byte
, nbytes
;
2247 int prev_bytes
, new_bytes
;
2248 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2250 nbytes
= SBYTES (array
);
2251 idxval_byte
= string_char_to_byte (array
, idxval
);
2252 p1
= SDATA (array
) + idxval_byte
;
2253 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2254 new_bytes
= CHAR_STRING (c
, p0
);
2255 if (prev_bytes
!= new_bytes
)
2257 /* We must relocate the string data. */
2258 ptrdiff_t nchars
= SCHARS (array
);
2260 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2262 memcpy (str
, SDATA (array
), nbytes
);
2263 allocate_string_data (XSTRING (array
), nchars
,
2264 nbytes
+ new_bytes
- prev_bytes
);
2265 memcpy (SDATA (array
), str
, idxval_byte
);
2266 p1
= SDATA (array
) + idxval_byte
;
2267 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2268 nbytes
- (idxval_byte
+ prev_bytes
));
2270 clear_string_char_byte_cache ();
2277 if (! SINGLE_BYTE_CHAR_P (c
))
2281 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2282 if (SREF (array
, i
) >= 0x80)
2283 args_out_of_range (array
, newelt
);
2284 /* ARRAY is an ASCII string. Convert it to a multibyte
2285 string, and try `aset' again. */
2286 STRING_SET_MULTIBYTE (array
);
2287 return Faset (array
, idx
, newelt
);
2289 SSET (array
, idxval
, c
);
2296 /* Arithmetic functions */
2299 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2301 double f1
= 0, f2
= 0;
2304 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2305 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2307 if (FLOATP (num1
) || FLOATP (num2
))
2310 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2311 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2317 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2321 case ARITH_NOTEQUAL
:
2322 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2327 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2331 case ARITH_LESS_OR_EQUAL
:
2332 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2337 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2341 case ARITH_GRTR_OR_EQUAL
:
2342 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2352 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2353 enum Arith_Comparison comparison
)
2356 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2358 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2364 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2365 doc
: /* Return t if args, all numbers or markers, are equal.
2366 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2367 (ptrdiff_t nargs
, Lisp_Object
*args
)
2369 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2372 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2373 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2374 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2375 (ptrdiff_t nargs
, Lisp_Object
*args
)
2377 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2380 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2381 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2382 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2383 (ptrdiff_t nargs
, Lisp_Object
*args
)
2385 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2388 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2389 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2390 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2391 (ptrdiff_t nargs
, Lisp_Object
*args
)
2393 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2396 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2397 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2398 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2399 (ptrdiff_t nargs
, Lisp_Object
*args
)
2401 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2404 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2405 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2406 (register Lisp_Object num1
, Lisp_Object num2
)
2408 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2411 /* Convert the cons-of-integers, integer, or float value C to an
2412 unsigned value with maximum value MAX. Signal an error if C does not
2413 have a valid format or is out of range. */
2415 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2418 uintmax_t val
IF_LINT (= 0);
2421 valid
= 0 <= XINT (c
);
2424 else if (FLOATP (c
))
2426 double d
= XFLOAT_DATA (c
);
2428 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2434 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2436 uintmax_t top
= XFASTINT (XCAR (c
));
2437 Lisp_Object rest
= XCDR (c
);
2438 if (top
<= UINTMAX_MAX
>> 24 >> 16
2440 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2441 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2443 uintmax_t mid
= XFASTINT (XCAR (rest
));
2444 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2447 else if (top
<= UINTMAX_MAX
>> 16)
2451 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2453 val
= top
<< 16 | XFASTINT (rest
);
2459 if (! (valid
&& val
<= max
))
2460 error ("Not an in-range integer, float, or cons of integers");
2464 /* Convert the cons-of-integers, integer, or float value C to a signed
2465 value with extrema MIN and MAX. Signal an error if C does not have
2466 a valid format or is out of range. */
2468 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2471 intmax_t val
IF_LINT (= 0);
2477 else if (FLOATP (c
))
2479 double d
= XFLOAT_DATA (c
);
2481 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2487 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2489 intmax_t top
= XINT (XCAR (c
));
2490 Lisp_Object rest
= XCDR (c
);
2491 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2493 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2494 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2496 intmax_t mid
= XFASTINT (XCAR (rest
));
2497 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2500 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2504 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2506 val
= top
<< 16 | XFASTINT (rest
);
2512 if (! (valid
&& min
<= val
&& val
<= max
))
2513 error ("Not an in-range integer, float, or cons of integers");
2517 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2518 doc
: /* Return the decimal representation of NUMBER as a string.
2519 Uses a minus sign if negative.
2520 NUMBER may be an integer or a floating point number. */)
2521 (Lisp_Object number
)
2523 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2526 CHECK_NUMBER_OR_FLOAT (number
);
2528 if (FLOATP (number
))
2529 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2531 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2533 return make_unibyte_string (buffer
, len
);
2536 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2537 doc
: /* Parse STRING as a decimal number and return the number.
2538 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2539 STRING cannot be parsed as an integer or floating point number.
2541 If BASE, interpret STRING as a number in that base. If BASE isn't
2542 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2543 If the base used is not 10, STRING is always parsed as an integer. */)
2544 (register Lisp_Object string
, Lisp_Object base
)
2550 CHECK_STRING (string
);
2556 CHECK_NUMBER (base
);
2557 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2558 xsignal1 (Qargs_out_of_range
, base
);
2562 p
= SSDATA (string
);
2563 while (*p
== ' ' || *p
== '\t')
2566 val
= string_to_number (p
, b
, 1);
2567 return NILP (val
) ? make_number (0) : val
;
2583 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2584 ptrdiff_t, Lisp_Object
*);
2586 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2589 ptrdiff_t argnum
, ok_args
;
2590 EMACS_INT accum
= 0;
2591 EMACS_INT next
, ok_accum
;
2613 for (argnum
= 0; argnum
< nargs
; argnum
++)
2621 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2623 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2626 return float_arith_driver (ok_accum
, ok_args
, code
,
2629 next
= XINT (args
[argnum
]);
2633 if (INT_ADD_OVERFLOW (accum
, next
))
2641 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2646 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2649 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2651 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2653 accum
= ab
& INTMASK
;
2659 if (! (argnum
|| nargs
== 1))
2664 xsignal0 (Qarith_error
);
2678 if (!argnum
|| next
> accum
)
2682 if (!argnum
|| next
< accum
)
2688 XSETINT (val
, accum
);
2693 #define isnan(x) ((x) != (x))
2696 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2697 ptrdiff_t nargs
, Lisp_Object
*args
)
2699 register Lisp_Object val
;
2702 for (; argnum
< nargs
; argnum
++)
2704 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2705 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2709 next
= XFLOAT_DATA (val
);
2713 args
[argnum
] = val
; /* runs into a compiler bug. */
2714 next
= XINT (args
[argnum
]);
2722 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2728 if (! (argnum
|| nargs
== 1))
2732 if (! IEEE_FLOATING_POINT
&& next
== 0)
2733 xsignal0 (Qarith_error
);
2740 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2742 if (!argnum
|| isnan (next
) || next
> accum
)
2746 if (!argnum
|| isnan (next
) || next
< accum
)
2752 return make_float (accum
);
2756 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2757 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2758 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2759 (ptrdiff_t nargs
, Lisp_Object
*args
)
2761 return arith_driver (Aadd
, nargs
, args
);
2764 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2765 doc
: /* Negate number or subtract numbers or markers and return the result.
2766 With one arg, negates it. With more than one arg,
2767 subtracts all but the first from the first.
2768 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2769 (ptrdiff_t nargs
, Lisp_Object
*args
)
2771 return arith_driver (Asub
, nargs
, args
);
2774 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2775 doc
: /* Return product of any number of arguments, which are numbers or markers.
2776 usage: (* &rest NUMBERS-OR-MARKERS) */)
2777 (ptrdiff_t nargs
, Lisp_Object
*args
)
2779 return arith_driver (Amult
, nargs
, args
);
2782 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2783 doc
: /* Divide number by divisors and return the result.
2784 With two or more arguments, return first argument divided by the rest.
2785 With one argument, return 1 divided by the argument.
2786 The arguments must be numbers or markers.
2787 usage: (/ NUMBER &rest DIVISORS) */)
2788 (ptrdiff_t nargs
, Lisp_Object
*args
)
2791 for (argnum
= 2; argnum
< nargs
; argnum
++)
2792 if (FLOATP (args
[argnum
]))
2793 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2794 return arith_driver (Adiv
, nargs
, args
);
2797 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2798 doc
: /* Return remainder of X divided by Y.
2799 Both must be integers or markers. */)
2800 (register Lisp_Object x
, Lisp_Object y
)
2804 CHECK_NUMBER_COERCE_MARKER (x
);
2805 CHECK_NUMBER_COERCE_MARKER (y
);
2808 xsignal0 (Qarith_error
);
2810 XSETINT (val
, XINT (x
) % XINT (y
));
2814 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2815 doc
: /* Return X modulo Y.
2816 The result falls between zero (inclusive) and Y (exclusive).
2817 Both X and Y must be numbers or markers. */)
2818 (register Lisp_Object x
, Lisp_Object y
)
2823 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2824 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2826 if (FLOATP (x
) || FLOATP (y
))
2827 return fmod_float (x
, y
);
2833 xsignal0 (Qarith_error
);
2837 /* If the "remainder" comes out with the wrong sign, fix it. */
2838 if (i2
< 0 ? i1
> 0 : i1
< 0)
2845 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2846 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2847 The value is always a number; markers are converted to numbers.
2848 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2849 (ptrdiff_t nargs
, Lisp_Object
*args
)
2851 return arith_driver (Amax
, nargs
, args
);
2854 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2855 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2856 The value is always a number; markers are converted to numbers.
2857 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2858 (ptrdiff_t nargs
, Lisp_Object
*args
)
2860 return arith_driver (Amin
, nargs
, args
);
2863 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2864 doc
: /* Return bitwise-and of all the arguments.
2865 Arguments may be integers, or markers converted to integers.
2866 usage: (logand &rest INTS-OR-MARKERS) */)
2867 (ptrdiff_t nargs
, Lisp_Object
*args
)
2869 return arith_driver (Alogand
, nargs
, args
);
2872 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2873 doc
: /* Return bitwise-or of all the arguments.
2874 Arguments may be integers, or markers converted to integers.
2875 usage: (logior &rest INTS-OR-MARKERS) */)
2876 (ptrdiff_t nargs
, Lisp_Object
*args
)
2878 return arith_driver (Alogior
, nargs
, args
);
2881 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2882 doc
: /* Return bitwise-exclusive-or of all the arguments.
2883 Arguments may be integers, or markers converted to integers.
2884 usage: (logxor &rest INTS-OR-MARKERS) */)
2885 (ptrdiff_t nargs
, Lisp_Object
*args
)
2887 return arith_driver (Alogxor
, nargs
, args
);
2890 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2891 doc
: /* Return VALUE with its bits shifted left by COUNT.
2892 If COUNT is negative, shifting is actually to the right.
2893 In this case, the sign bit is duplicated. */)
2894 (register Lisp_Object value
, Lisp_Object count
)
2896 register Lisp_Object val
;
2898 CHECK_NUMBER (value
);
2899 CHECK_NUMBER (count
);
2901 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2903 else if (XINT (count
) > 0)
2904 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2905 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2906 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2908 XSETINT (val
, XINT (value
) >> -XINT (count
));
2912 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2913 doc
: /* Return VALUE with its bits shifted left by COUNT.
2914 If COUNT is negative, shifting is actually to the right.
2915 In this case, zeros are shifted in on the left. */)
2916 (register Lisp_Object value
, Lisp_Object count
)
2918 register Lisp_Object val
;
2920 CHECK_NUMBER (value
);
2921 CHECK_NUMBER (count
);
2923 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2925 else if (XINT (count
) > 0)
2926 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2927 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2930 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2934 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2935 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2936 Markers are converted to integers. */)
2937 (register Lisp_Object number
)
2939 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2941 if (FLOATP (number
))
2942 return (make_float (1.0 + XFLOAT_DATA (number
)));
2944 XSETINT (number
, XINT (number
) + 1);
2948 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2949 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2950 Markers are converted to integers. */)
2951 (register Lisp_Object number
)
2953 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2955 if (FLOATP (number
))
2956 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2958 XSETINT (number
, XINT (number
) - 1);
2962 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2963 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2964 (register Lisp_Object number
)
2966 CHECK_NUMBER (number
);
2967 XSETINT (number
, ~XINT (number
));
2971 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2972 doc
: /* Return the byteorder for the machine.
2973 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2974 lowercase l) for small endian machines. */
2978 unsigned i
= 0x04030201;
2979 int order
= *(char *)&i
== 1 ? 108 : 66;
2981 return make_number (order
);
2984 /* Because we round up the bool vector allocate size to word_size
2985 units, we can safely read past the "end" of the vector in the
2986 operations below. These extra bits are always zero. */
2989 bool_vector_spare_mask (EMACS_INT nr_bits
)
2991 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2994 /* Info about unsigned long long, falling back on unsigned long
2995 if unsigned long long is not available. */
2997 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2998 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2999 # define ULL_MAX ULLONG_MAX
3001 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
3002 # define ULL_MAX ULONG_MAX
3003 # define count_one_bits_ll count_one_bits_l
3004 # define count_trailing_zeros_ll count_trailing_zeros_l
3007 /* Shift VAL right by the width of an unsigned long long.
3008 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3011 shift_right_ull (bits_word w
)
3013 /* Pacify bogus GCC warning about shift count exceeding type width. */
3014 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3018 /* Return the number of 1 bits in W. */
3021 count_one_bits_word (bits_word w
)
3023 if (BITS_WORD_MAX
<= UINT_MAX
)
3024 return count_one_bits (w
);
3025 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3026 return count_one_bits_l (w
);
3029 int i
= 0, count
= 0;
3030 while (count
+= count_one_bits_ll (w
),
3031 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3032 w
= shift_right_ull (w
);
3037 enum bool_vector_op
{ bool_vector_exclusive_or
,
3039 bool_vector_intersection
,
3040 bool_vector_set_difference
,
3041 bool_vector_subsetp
};
3044 bool_vector_binop_driver (Lisp_Object a
,
3047 enum bool_vector_op op
)
3050 bits_word
*adata
, *bdata
, *destdata
;
3054 CHECK_BOOL_VECTOR (a
);
3055 CHECK_BOOL_VECTOR (b
);
3057 nr_bits
= bool_vector_size (a
);
3058 if (bool_vector_size (b
) != nr_bits
)
3059 wrong_length_argument (a
, b
, dest
);
3061 nr_words
= bool_vector_words (nr_bits
);
3062 adata
= bool_vector_data (a
);
3063 bdata
= bool_vector_data (b
);
3067 dest
= make_uninit_bool_vector (nr_bits
);
3068 destdata
= bool_vector_data (dest
);
3072 CHECK_BOOL_VECTOR (dest
);
3073 destdata
= bool_vector_data (dest
);
3074 if (bool_vector_size (dest
) != nr_bits
)
3075 wrong_length_argument (a
, b
, dest
);
3079 case bool_vector_exclusive_or
:
3080 for (; i
< nr_words
; i
++)
3081 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3085 case bool_vector_subsetp
:
3086 for (; i
< nr_words
; i
++)
3087 if (adata
[i
] &~ bdata
[i
])
3091 case bool_vector_union
:
3092 for (; i
< nr_words
; i
++)
3093 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3097 case bool_vector_intersection
:
3098 for (; i
< nr_words
; i
++)
3099 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3103 case bool_vector_set_difference
:
3104 for (; i
< nr_words
; i
++)
3105 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3116 case bool_vector_exclusive_or
:
3117 for (; i
< nr_words
; i
++)
3118 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3121 case bool_vector_union
:
3122 for (; i
< nr_words
; i
++)
3123 destdata
[i
] = adata
[i
] | bdata
[i
];
3126 case bool_vector_intersection
:
3127 for (; i
< nr_words
; i
++)
3128 destdata
[i
] = adata
[i
] & bdata
[i
];
3131 case bool_vector_set_difference
:
3132 for (; i
< nr_words
; i
++)
3133 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3143 /* PRECONDITION must be true. Return VALUE. This odd construction
3144 works around a bogus GCC diagnostic "shift count >= width of type". */
3147 pre_value (bool precondition
, int value
)
3149 eassume (precondition
);
3150 return precondition
? value
: 0;
3153 /* Compute the number of trailing zero bits in val. If val is zero,
3154 return the number of bits in val. */
3156 count_trailing_zero_bits (bits_word val
)
3158 if (BITS_WORD_MAX
== UINT_MAX
)
3159 return count_trailing_zeros (val
);
3160 if (BITS_WORD_MAX
== ULONG_MAX
)
3161 return count_trailing_zeros_l (val
);
3162 if (BITS_WORD_MAX
== ULL_MAX
)
3163 return count_trailing_zeros_ll (val
);
3165 /* The rest of this code is for the unlikely platform where bits_word differs
3166 in width from unsigned int, unsigned long, and unsigned long long. */
3167 val
|= ~ BITS_WORD_MAX
;
3168 if (BITS_WORD_MAX
<= UINT_MAX
)
3169 return count_trailing_zeros (val
);
3170 if (BITS_WORD_MAX
<= ULONG_MAX
)
3171 return count_trailing_zeros_l (val
);
3176 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3177 count
+= BITS_PER_ULL
)
3180 return count
+ count_trailing_zeros_ll (val
);
3181 val
= shift_right_ull (val
);
3184 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3185 && BITS_WORD_MAX
== (bits_word
) -1)
3186 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3187 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3188 return count
+ count_trailing_zeros_ll (val
);
3193 bits_word_to_host_endian (bits_word val
)
3195 #ifndef WORDS_BIGENDIAN
3198 if (BITS_WORD_MAX
>> 31 == 1)
3199 return bswap_32 (val
);
3200 # if HAVE_UNSIGNED_LONG_LONG
3201 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3202 return bswap_64 (val
);
3207 for (i
= 0; i
< sizeof val
; i
++)
3209 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3210 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3211 val
= val
>> 1 >> (CHAR_BIT
- 1);
3218 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3219 Sbool_vector_exclusive_or
, 2, 3, 0,
3220 doc
: /* Return A ^ B, bitwise exclusive or.
3221 If optional third argument C is given, store result into C.
3222 A, B, and C must be bool vectors of the same length.
3223 Return the destination vector if it changed or nil otherwise. */)
3224 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3226 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3229 DEFUN ("bool-vector-union", Fbool_vector_union
,
3230 Sbool_vector_union
, 2, 3, 0,
3231 doc
: /* Return A | B, bitwise or.
3232 If optional third argument C is given, store result into C.
3233 A, B, and C must be bool vectors of the same length.
3234 Return the destination vector if it changed or nil otherwise. */)
3235 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3237 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3240 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3241 Sbool_vector_intersection
, 2, 3, 0,
3242 doc
: /* Return A & B, bitwise and.
3243 If optional third argument C is given, store result into C.
3244 A, B, and C must be bool vectors of the same length.
3245 Return the destination vector if it changed or nil otherwise. */)
3246 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3248 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3251 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3252 Sbool_vector_set_difference
, 2, 3, 0,
3253 doc
: /* Return A &~ B, set difference.
3254 If optional third argument C is given, store result into C.
3255 A, B, and C must be bool vectors of the same length.
3256 Return the destination vector if it changed or nil otherwise. */)
3257 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3259 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3262 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3263 Sbool_vector_subsetp
, 2, 2, 0,
3264 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3265 A and B must be bool vectors of the same length. */)
3266 (Lisp_Object a
, Lisp_Object b
)
3268 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3271 DEFUN ("bool-vector-not", Fbool_vector_not
,
3272 Sbool_vector_not
, 1, 2, 0,
3273 doc
: /* Compute ~A, set complement.
3274 If optional second argument B is given, store result into B.
3275 A and B must be bool vectors of the same length.
3276 Return the destination vector. */)
3277 (Lisp_Object a
, Lisp_Object b
)
3280 bits_word
*bdata
, *adata
;
3283 CHECK_BOOL_VECTOR (a
);
3284 nr_bits
= bool_vector_size (a
);
3287 b
= make_uninit_bool_vector (nr_bits
);
3290 CHECK_BOOL_VECTOR (b
);
3291 if (bool_vector_size (b
) != nr_bits
)
3292 wrong_length_argument (a
, b
, Qnil
);
3295 bdata
= bool_vector_data (b
);
3296 adata
= bool_vector_data (a
);
3298 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3299 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3301 if (nr_bits
% BITS_PER_BITS_WORD
)
3303 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3305 mword
&= bool_vector_spare_mask (nr_bits
);
3306 bdata
[i
] = bits_word_to_host_endian (mword
);
3312 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3313 Sbool_vector_count_population
, 1, 1, 0,
3314 doc
: /* Count how many elements in A are t.
3315 A is a bool vector. To count A's nil elements, subtract the return
3316 value from A's length. */)
3322 ptrdiff_t i
, nwords
;
3324 CHECK_BOOL_VECTOR (a
);
3326 nr_bits
= bool_vector_size (a
);
3327 nwords
= bool_vector_words (nr_bits
);
3329 adata
= bool_vector_data (a
);
3331 for (i
= 0; i
< nwords
; i
++)
3332 count
+= count_one_bits_word (adata
[i
]);
3334 return make_number (count
);
3337 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3338 Sbool_vector_count_consecutive
, 3, 3, 0,
3339 doc
: /* Count how many consecutive elements in A equal B starting at I.
3340 A is a bool vector, B is t or nil, and I is an index into A. */)
3341 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3348 bits_word mword
; /* Machine word. */
3349 ptrdiff_t pos
, pos0
;
3352 CHECK_BOOL_VECTOR (a
);
3355 nr_bits
= bool_vector_size (a
);
3356 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3357 args_out_of_range (a
, i
);
3359 adata
= bool_vector_data (a
);
3360 nr_words
= bool_vector_words (nr_bits
);
3361 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3362 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3365 /* By XORing with twiddle, we transform the problem of "count
3366 consecutive equal values" into "count the zero bits". The latter
3367 operation usually has hardware support. */
3368 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3370 /* Scan the remainder of the mword at the current offset. */
3371 if (pos
< nr_words
&& offset
!= 0)
3373 mword
= bits_word_to_host_endian (adata
[pos
]);
3377 /* Do not count the pad bits. */
3378 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3380 count
= count_trailing_zero_bits (mword
);
3382 if (count
+ offset
< BITS_PER_BITS_WORD
)
3383 return make_number (count
);
3386 /* Scan whole words until we either reach the end of the vector or
3387 find an mword that doesn't completely match. twiddle is
3388 endian-independent. */
3390 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3392 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3396 /* If we stopped because of a mismatch, see how many bits match
3397 in the current mword. */
3398 mword
= bits_word_to_host_endian (adata
[pos
]);
3400 count
+= count_trailing_zero_bits (mword
);
3402 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3404 /* If we hit the end, we might have overshot our count. Reduce
3405 the total by the number of spare bits at the end of the
3407 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3410 return make_number (count
);
3417 Lisp_Object error_tail
, arith_tail
;
3419 DEFSYM (Qquote
, "quote");
3420 DEFSYM (Qlambda
, "lambda");
3421 DEFSYM (Qsubr
, "subr");
3422 DEFSYM (Qerror_conditions
, "error-conditions");
3423 DEFSYM (Qerror_message
, "error-message");
3424 DEFSYM (Qtop_level
, "top-level");
3426 DEFSYM (Qerror
, "error");
3427 DEFSYM (Quser_error
, "user-error");
3428 DEFSYM (Qquit
, "quit");
3429 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3430 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3431 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3432 DEFSYM (Qvoid_function
, "void-function");
3433 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3434 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3435 DEFSYM (Qvoid_variable
, "void-variable");
3436 DEFSYM (Qsetting_constant
, "setting-constant");
3437 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3439 DEFSYM (Qinvalid_function
, "invalid-function");
3440 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3441 DEFSYM (Qno_catch
, "no-catch");
3442 DEFSYM (Qend_of_file
, "end-of-file");
3443 DEFSYM (Qarith_error
, "arith-error");
3444 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3445 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3446 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3447 DEFSYM (Qtext_read_only
, "text-read-only");
3448 DEFSYM (Qmark_inactive
, "mark-inactive");
3450 DEFSYM (Qlistp
, "listp");
3451 DEFSYM (Qconsp
, "consp");
3452 DEFSYM (Qsymbolp
, "symbolp");
3453 DEFSYM (Qintegerp
, "integerp");
3454 DEFSYM (Qnatnump
, "natnump");
3455 DEFSYM (Qwholenump
, "wholenump");
3456 DEFSYM (Qstringp
, "stringp");
3457 DEFSYM (Qarrayp
, "arrayp");
3458 DEFSYM (Qsequencep
, "sequencep");
3459 DEFSYM (Qbufferp
, "bufferp");
3460 DEFSYM (Qvectorp
, "vectorp");
3461 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3462 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3463 DEFSYM (Qmarkerp
, "markerp");
3464 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3465 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3466 DEFSYM (Qfboundp
, "fboundp");
3468 DEFSYM (Qfloatp
, "floatp");
3469 DEFSYM (Qnumberp
, "numberp");
3470 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3472 DEFSYM (Qchar_table_p
, "char-table-p");
3473 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3475 DEFSYM (Qsubrp
, "subrp");
3476 DEFSYM (Qunevalled
, "unevalled");
3477 DEFSYM (Qmany
, "many");
3479 DEFSYM (Qcdr
, "cdr");
3481 error_tail
= pure_cons (Qerror
, Qnil
);
3483 /* ERROR is used as a signaler for random errors for which nothing else is
3486 Fput (Qerror
, Qerror_conditions
,
3488 Fput (Qerror
, Qerror_message
,
3489 build_pure_c_string ("error"));
3491 #define PUT_ERROR(sym, tail, msg) \
3492 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3493 Fput (sym, Qerror_message, build_pure_c_string (msg))
3495 PUT_ERROR (Qquit
, Qnil
, "Quit");
3497 PUT_ERROR (Quser_error
, error_tail
, "");
3498 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3499 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3500 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3501 PUT_ERROR (Qvoid_function
, error_tail
,
3502 "Symbol's function definition is void");
3503 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3504 "Symbol's chain of function indirections contains a loop");
3505 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3506 "Symbol's chain of variable indirections contains a loop");
3507 DEFSYM (Qcircular_list
, "circular-list");
3508 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3509 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3510 PUT_ERROR (Qsetting_constant
, error_tail
,
3511 "Attempt to set a constant symbol");
3512 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3513 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3514 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3515 "Wrong number of arguments");
3516 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3517 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3519 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3520 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3521 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3523 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3524 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3525 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3526 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3527 "Text is read-only");
3529 DEFSYM (Qrange_error
, "range-error");
3530 DEFSYM (Qdomain_error
, "domain-error");
3531 DEFSYM (Qsingularity_error
, "singularity-error");
3532 DEFSYM (Qoverflow_error
, "overflow-error");
3533 DEFSYM (Qunderflow_error
, "underflow-error");
3535 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3537 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3539 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3540 "Arithmetic singularity error");
3542 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3543 "Arithmetic overflow error");
3544 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3545 "Arithmetic underflow error");
3547 /* Types that type-of returns. */
3548 DEFSYM (Qinteger
, "integer");
3549 DEFSYM (Qsymbol
, "symbol");
3550 DEFSYM (Qstring
, "string");
3551 DEFSYM (Qcons
, "cons");
3552 DEFSYM (Qmarker
, "marker");
3553 DEFSYM (Qoverlay
, "overlay");
3554 DEFSYM (Qfinalizer
, "finalizer");
3555 DEFSYM (Qfloat
, "float");
3556 DEFSYM (Qwindow_configuration
, "window-configuration");
3557 DEFSYM (Qprocess
, "process");
3558 DEFSYM (Qwindow
, "window");
3559 DEFSYM (Qcompiled_function
, "compiled-function");
3560 DEFSYM (Qbuffer
, "buffer");
3561 DEFSYM (Qframe
, "frame");
3562 DEFSYM (Qvector
, "vector");
3563 DEFSYM (Qchar_table
, "char-table");
3564 DEFSYM (Qbool_vector
, "bool-vector");
3565 DEFSYM (Qhash_table
, "hash-table");
3567 DEFSYM (Qdefun
, "defun");
3569 DEFSYM (Qfont_spec
, "font-spec");
3570 DEFSYM (Qfont_entity
, "font-entity");
3571 DEFSYM (Qfont_object
, "font-object");
3573 DEFSYM (Qinteractive_form
, "interactive-form");
3574 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3576 defsubr (&Sindirect_variable
);
3577 defsubr (&Sinteractive_form
);
3580 defsubr (&Stype_of
);
3585 defsubr (&Sintegerp
);
3586 defsubr (&Sinteger_or_marker_p
);
3587 defsubr (&Snumberp
);
3588 defsubr (&Snumber_or_marker_p
);
3590 defsubr (&Snatnump
);
3591 defsubr (&Ssymbolp
);
3592 defsubr (&Skeywordp
);
3593 defsubr (&Sstringp
);
3594 defsubr (&Smultibyte_string_p
);
3595 defsubr (&Svectorp
);
3596 defsubr (&Schar_table_p
);
3597 defsubr (&Svector_or_char_table_p
);
3598 defsubr (&Sbool_vector_p
);
3600 defsubr (&Ssequencep
);
3601 defsubr (&Sbufferp
);
3602 defsubr (&Smarkerp
);
3604 defsubr (&Sbyte_code_function_p
);
3605 defsubr (&Schar_or_string_p
);
3608 defsubr (&Scar_safe
);
3609 defsubr (&Scdr_safe
);
3612 defsubr (&Ssymbol_function
);
3613 defsubr (&Sindirect_function
);
3614 defsubr (&Ssymbol_plist
);
3615 defsubr (&Ssymbol_name
);
3616 defsubr (&Smakunbound
);
3617 defsubr (&Sfmakunbound
);
3619 defsubr (&Sfboundp
);
3621 defsubr (&Sdefalias
);
3622 defsubr (&Ssetplist
);
3623 defsubr (&Ssymbol_value
);
3625 defsubr (&Sdefault_boundp
);
3626 defsubr (&Sdefault_value
);
3627 defsubr (&Sset_default
);
3628 defsubr (&Ssetq_default
);
3629 defsubr (&Smake_variable_buffer_local
);
3630 defsubr (&Smake_local_variable
);
3631 defsubr (&Skill_local_variable
);
3632 defsubr (&Smake_variable_frame_local
);
3633 defsubr (&Slocal_variable_p
);
3634 defsubr (&Slocal_variable_if_set_p
);
3635 defsubr (&Svariable_binding_locus
);
3636 #if 0 /* XXX Remove this. --lorentey */
3637 defsubr (&Sterminal_local_value
);
3638 defsubr (&Sset_terminal_local_value
);
3642 defsubr (&Snumber_to_string
);
3643 defsubr (&Sstring_to_number
);
3644 defsubr (&Seqlsign
);
3666 defsubr (&Sbyteorder
);
3667 defsubr (&Ssubr_arity
);
3668 defsubr (&Ssubr_name
);
3670 defsubr (&Sbool_vector_exclusive_or
);
3671 defsubr (&Sbool_vector_union
);
3672 defsubr (&Sbool_vector_intersection
);
3673 defsubr (&Sbool_vector_set_difference
);
3674 defsubr (&Sbool_vector_not
);
3675 defsubr (&Sbool_vector_subsetp
);
3676 defsubr (&Sbool_vector_count_consecutive
);
3677 defsubr (&Sbool_vector_count_population
);
3679 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3681 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3682 doc
: /* The largest value that is representable in a Lisp integer. */);
3683 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3684 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3686 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3687 doc
: /* The smallest value that is representable in a Lisp integer. */);
3688 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3689 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;