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 maybe_set_redisplay (symbol
);
1244 sym
= XSYMBOL (symbol
);
1247 switch (sym
->redirect
)
1249 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1250 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1251 case SYMBOL_LOCALIZED
:
1253 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1256 if (blv
->frame_local
)
1257 where
= selected_frame
;
1259 XSETBUFFER (where
, current_buffer
);
1261 /* If the current buffer is not the buffer whose binding is
1262 loaded, or if there may be frame-local bindings and the frame
1263 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1264 the default binding is loaded, the loaded binding may be the
1266 if (!EQ (blv
->where
, where
)
1267 /* Also unload a global binding (if the var is local_if_set). */
1268 || (EQ (blv
->valcell
, blv
->defcell
)))
1270 /* The currently loaded binding is not necessarily valid.
1271 We need to unload it, and choose a new binding. */
1273 /* Write out `realvalue' to the old loaded binding. */
1275 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1277 /* Find the new binding. */
1278 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1279 tem1
= assq_no_quit (symbol
,
1281 ? XFRAME (where
)->param_alist
1282 : BVAR (XBUFFER (where
), local_var_alist
)));
1283 set_blv_where (blv
, where
);
1288 /* This buffer still sees the default value. */
1290 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1291 or if this is `let' rather than `set',
1292 make CURRENT-ALIST-ELEMENT point to itself,
1293 indicating that we're seeing the default value.
1294 Likewise if the variable has been let-bound
1295 in the current buffer. */
1296 if (bindflag
|| !blv
->local_if_set
1297 || let_shadows_buffer_binding_p (sym
))
1300 tem1
= blv
->defcell
;
1302 /* If it's a local_if_set, being set not bound,
1303 and we're not within a let that was made for this buffer,
1304 create a new buffer-local binding for the variable.
1305 That means, give this buffer a new assoc for a local value
1306 and load that binding. */
1309 /* local_if_set is only supported for buffer-local
1310 bindings, not for frame-local bindings. */
1311 eassert (!blv
->frame_local
);
1312 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1313 bset_local_var_alist
1315 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1319 /* Record which binding is now loaded. */
1320 set_blv_valcell (blv
, tem1
);
1323 /* Store the new value in the cons cell. */
1324 set_blv_value (blv
, newval
);
1329 /* If storing void (making the symbol void), forward only through
1330 buffer-local indicator, not through Lisp_Objfwd, etc. */
1333 store_symval_forwarding (blv
->fwd
, newval
,
1335 ? XBUFFER (where
) : current_buffer
);
1339 case SYMBOL_FORWARDED
:
1342 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1343 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1344 if (BUFFER_OBJFWDP (innercontents
))
1346 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1347 int idx
= PER_BUFFER_IDX (offset
);
1350 && !let_shadows_buffer_binding_p (sym
))
1351 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1355 { /* If storing void (making the symbol void), forward only through
1356 buffer-local indicator, not through Lisp_Objfwd, etc. */
1357 sym
->redirect
= SYMBOL_PLAINVAL
;
1358 SET_SYMBOL_VAL (sym
, newval
);
1361 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1364 default: emacs_abort ();
1369 /* Access or set a buffer-local symbol's default value. */
1371 /* Return the default value of SYMBOL, but don't check for voidness.
1372 Return Qunbound if it is void. */
1375 default_value (Lisp_Object symbol
)
1377 struct Lisp_Symbol
*sym
;
1379 CHECK_SYMBOL (symbol
);
1380 sym
= XSYMBOL (symbol
);
1383 switch (sym
->redirect
)
1385 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1386 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1387 case SYMBOL_LOCALIZED
:
1389 /* If var is set up for a buffer that lacks a local value for it,
1390 the current value is nominally the default value.
1391 But the `realvalue' slot may be more up to date, since
1392 ordinary setq stores just that slot. So use that. */
1393 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1394 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1395 return do_symval_forwarding (blv
->fwd
);
1397 return XCDR (blv
->defcell
);
1399 case SYMBOL_FORWARDED
:
1401 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1403 /* For a built-in buffer-local variable, get the default value
1404 rather than letting do_symval_forwarding get the current value. */
1405 if (BUFFER_OBJFWDP (valcontents
))
1407 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1408 if (PER_BUFFER_IDX (offset
) != 0)
1409 return per_buffer_default (offset
);
1412 /* For other variables, get the current value. */
1413 return do_symval_forwarding (valcontents
);
1415 default: emacs_abort ();
1419 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1420 doc
: /* Return t if SYMBOL has a non-void default value.
1421 This is the value that is seen in buffers that do not have their own values
1422 for this variable. */)
1423 (Lisp_Object symbol
)
1425 register Lisp_Object value
;
1427 value
= default_value (symbol
);
1428 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1431 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1432 doc
: /* Return SYMBOL's default value.
1433 This is the value that is seen in buffers that do not have their own values
1434 for this variable. The default value is meaningful for variables with
1435 local bindings in certain buffers. */)
1436 (Lisp_Object symbol
)
1438 Lisp_Object value
= default_value (symbol
);
1439 if (!EQ (value
, Qunbound
))
1442 xsignal1 (Qvoid_variable
, symbol
);
1445 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1446 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1447 The default value is seen in buffers that do not have their own values
1448 for this variable. */)
1449 (Lisp_Object symbol
, Lisp_Object value
)
1451 struct Lisp_Symbol
*sym
;
1453 CHECK_SYMBOL (symbol
);
1454 if (SYMBOL_CONSTANT_P (symbol
))
1456 if (NILP (Fkeywordp (symbol
))
1457 || !EQ (value
, Fdefault_value (symbol
)))
1458 xsignal1 (Qsetting_constant
, symbol
);
1460 /* Allow setting keywords to their own value. */
1463 sym
= XSYMBOL (symbol
);
1466 switch (sym
->redirect
)
1468 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1469 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1470 case SYMBOL_LOCALIZED
:
1472 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1474 /* Store new value into the DEFAULT-VALUE slot. */
1475 XSETCDR (blv
->defcell
, value
);
1477 /* If the default binding is now loaded, set the REALVALUE slot too. */
1478 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1479 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1482 case SYMBOL_FORWARDED
:
1484 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1486 /* Handle variables like case-fold-search that have special slots
1488 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1489 if (BUFFER_OBJFWDP (valcontents
))
1491 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1492 int idx
= PER_BUFFER_IDX (offset
);
1494 set_per_buffer_default (offset
, value
);
1496 /* If this variable is not always local in all buffers,
1497 set it in the buffers that don't nominally have a local value. */
1503 if (!PER_BUFFER_VALUE_P (b
, idx
))
1504 set_per_buffer_value (b
, offset
, value
);
1509 return Fset (symbol
, value
);
1511 default: emacs_abort ();
1515 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1516 doc
: /* Set the default value of variable VAR to VALUE.
1517 VAR, the variable name, is literal (not evaluated);
1518 VALUE is an expression: it is evaluated and its value returned.
1519 The default value of a variable is seen in buffers
1520 that do not have their own values for the variable.
1522 More generally, you can use multiple variables and values, as in
1523 (setq-default VAR VALUE VAR VALUE...)
1524 This sets each VAR's default value to the corresponding VALUE.
1525 The VALUE for the Nth VAR can refer to the new default values
1527 usage: (setq-default [VAR VALUE]...) */)
1530 Lisp_Object args_left
, symbol
, val
;
1532 args_left
= val
= args
;
1534 while (CONSP (args_left
))
1536 val
= eval_sub (Fcar (XCDR (args_left
)));
1537 symbol
= XCAR (args_left
);
1538 Fset_default (symbol
, val
);
1539 args_left
= Fcdr (XCDR (args_left
));
1545 /* Lisp functions for creating and removing buffer-local variables. */
1550 union Lisp_Fwd
*fwd
;
1553 static struct Lisp_Buffer_Local_Value
*
1554 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1555 union Lisp_Val_Fwd valcontents
)
1557 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1561 XSETSYMBOL (symbol
, sym
);
1562 tem
= Fcons (symbol
, (forwarded
1563 ? do_symval_forwarding (valcontents
.fwd
)
1564 : valcontents
.value
));
1566 /* Buffer_Local_Values cannot have as realval a buffer-local
1567 or keyboard-local forwarding. */
1568 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1569 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1570 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1571 set_blv_where (blv
, Qnil
);
1572 blv
->frame_local
= 0;
1573 blv
->local_if_set
= 0;
1574 set_blv_defcell (blv
, tem
);
1575 set_blv_valcell (blv
, tem
);
1576 set_blv_found (blv
, 0);
1580 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1581 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1582 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1583 At any time, the value for the current buffer is in effect,
1584 unless the variable has never been set in this buffer,
1585 in which case the default value is in effect.
1586 Note that binding the variable with `let', or setting it while
1587 a `let'-style binding made in this buffer is in effect,
1588 does not make the variable buffer-local. Return VARIABLE.
1590 This globally affects all uses of this variable, so it belongs together with
1591 the variable declaration, rather than with its uses (if you just want to make
1592 a variable local to the current buffer for one particular use, use
1593 `make-local-variable'). Buffer-local bindings are normally cleared
1594 while setting up a new major mode, unless they have a `permanent-local'
1597 The function `default-value' gets the default value and `set-default' sets it. */)
1598 (register Lisp_Object variable
)
1600 struct Lisp_Symbol
*sym
;
1601 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1602 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1603 bool forwarded
IF_LINT (= 0);
1605 CHECK_SYMBOL (variable
);
1606 sym
= XSYMBOL (variable
);
1609 switch (sym
->redirect
)
1611 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1612 case SYMBOL_PLAINVAL
:
1613 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1614 if (EQ (valcontents
.value
, Qunbound
))
1615 valcontents
.value
= Qnil
;
1617 case SYMBOL_LOCALIZED
:
1618 blv
= SYMBOL_BLV (sym
);
1619 if (blv
->frame_local
)
1620 error ("Symbol %s may not be buffer-local",
1621 SDATA (SYMBOL_NAME (variable
)));
1623 case SYMBOL_FORWARDED
:
1624 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1625 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1626 error ("Symbol %s may not be buffer-local",
1627 SDATA (SYMBOL_NAME (variable
)));
1628 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1631 default: emacs_abort ();
1635 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1639 blv
= make_blv (sym
, forwarded
, valcontents
);
1640 sym
->redirect
= SYMBOL_LOCALIZED
;
1641 SET_SYMBOL_BLV (sym
, blv
);
1644 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1645 if (let_shadows_global_binding_p (symbol
))
1647 AUTO_STRING (format
, "Making %s buffer-local while let-bound!");
1648 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1653 blv
->local_if_set
= 1;
1657 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1658 1, 1, "vMake Local Variable: ",
1659 doc
: /* Make VARIABLE have a separate value in the current buffer.
1660 Other buffers will continue to share a common default value.
1661 (The buffer-local value of VARIABLE starts out as the same value
1662 VARIABLE previously had. If VARIABLE was void, it remains void.)
1665 If the variable is already arranged to become local when set,
1666 this function causes a local value to exist for this buffer,
1667 just as setting the variable would do.
1669 This function returns VARIABLE, and therefore
1670 (set (make-local-variable \\='VARIABLE) VALUE-EXP)
1673 See also `make-variable-buffer-local'.
1675 Do not use `make-local-variable' to make a hook variable buffer-local.
1676 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1677 (Lisp_Object variable
)
1680 bool forwarded
IF_LINT (= 0);
1681 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1682 struct Lisp_Symbol
*sym
;
1683 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1685 CHECK_SYMBOL (variable
);
1686 sym
= XSYMBOL (variable
);
1689 switch (sym
->redirect
)
1691 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1692 case SYMBOL_PLAINVAL
:
1693 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1694 case SYMBOL_LOCALIZED
:
1695 blv
= SYMBOL_BLV (sym
);
1696 if (blv
->frame_local
)
1697 error ("Symbol %s may not be buffer-local",
1698 SDATA (SYMBOL_NAME (variable
)));
1700 case SYMBOL_FORWARDED
:
1701 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1702 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1703 error ("Symbol %s may not be buffer-local",
1704 SDATA (SYMBOL_NAME (variable
)));
1706 default: emacs_abort ();
1710 error ("Symbol %s may not be buffer-local",
1711 SDATA (SYMBOL_NAME (variable
)));
1713 if (blv
? blv
->local_if_set
1714 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1716 tem
= Fboundp (variable
);
1717 /* Make sure the symbol has a local value in this particular buffer,
1718 by setting it to the same value it already has. */
1719 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1724 blv
= make_blv (sym
, forwarded
, valcontents
);
1725 sym
->redirect
= SYMBOL_LOCALIZED
;
1726 SET_SYMBOL_BLV (sym
, blv
);
1729 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1730 if (let_shadows_global_binding_p (symbol
))
1732 AUTO_STRING (format
, "Making %s local to %s while let-bound!");
1733 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
),
1734 BVAR (current_buffer
, name
));
1739 /* Make sure this buffer has its own value of symbol. */
1740 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1741 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1744 if (let_shadows_buffer_binding_p (sym
))
1746 AUTO_STRING (format
,
1747 "Making %s buffer-local while locally let-bound!");
1748 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1751 /* Swap out any local binding for some other buffer, and make
1752 sure the current value is permanently recorded, if it's the
1754 find_symbol_value (variable
);
1756 bset_local_var_alist
1758 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1759 BVAR (current_buffer
, local_var_alist
)));
1761 /* Make sure symbol does not think it is set up for this buffer;
1762 force it to look once again for this buffer's value. */
1763 if (current_buffer
== XBUFFER (blv
->where
))
1764 set_blv_where (blv
, Qnil
);
1765 set_blv_found (blv
, 0);
1768 /* If the symbol forwards into a C variable, then load the binding
1769 for this buffer now. If C code modifies the variable before we
1770 load the binding in, then that new value will clobber the default
1771 binding the next time we unload it. */
1773 swap_in_symval_forwarding (sym
, blv
);
1778 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1779 1, 1, "vKill Local Variable: ",
1780 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1781 From now on the default value will apply in this buffer. Return VARIABLE. */)
1782 (register Lisp_Object variable
)
1784 register Lisp_Object tem
;
1785 struct Lisp_Buffer_Local_Value
*blv
;
1786 struct Lisp_Symbol
*sym
;
1788 CHECK_SYMBOL (variable
);
1789 sym
= XSYMBOL (variable
);
1792 switch (sym
->redirect
)
1794 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1795 case SYMBOL_PLAINVAL
: return variable
;
1796 case SYMBOL_FORWARDED
:
1798 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1799 if (BUFFER_OBJFWDP (valcontents
))
1801 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1802 int idx
= PER_BUFFER_IDX (offset
);
1806 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1807 set_per_buffer_value (current_buffer
, offset
,
1808 per_buffer_default (offset
));
1813 case SYMBOL_LOCALIZED
:
1814 blv
= SYMBOL_BLV (sym
);
1815 if (blv
->frame_local
)
1818 default: emacs_abort ();
1821 /* Get rid of this buffer's alist element, if any. */
1822 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1823 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1825 bset_local_var_alist
1827 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1829 /* If the symbol is set up with the current buffer's binding
1830 loaded, recompute its value. We have to do it now, or else
1831 forwarded objects won't work right. */
1833 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1834 if (EQ (buf
, blv
->where
))
1836 set_blv_where (blv
, Qnil
);
1838 find_symbol_value (variable
);
1845 /* Lisp functions for creating and removing buffer-local variables. */
1847 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1848 when/if this is removed. */
1850 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1851 1, 1, "vMake Variable Frame Local: ",
1852 doc
: /* Enable VARIABLE to have frame-local bindings.
1853 This does not create any frame-local bindings for VARIABLE,
1854 it just makes them possible.
1856 A frame-local binding is actually a frame parameter value.
1857 If a frame F has a value for the frame parameter named VARIABLE,
1858 that also acts as a frame-local binding for VARIABLE in F--
1859 provided this function has been called to enable VARIABLE
1860 to have frame-local bindings at all.
1862 The only way to create a frame-local binding for VARIABLE in a frame
1863 is to set the VARIABLE frame parameter of that frame. See
1864 `modify-frame-parameters' for how to set frame parameters.
1866 Note that since Emacs 23.1, variables cannot be both buffer-local and
1867 frame-local any more (buffer-local bindings used to take precedence over
1868 frame-local bindings). */)
1869 (Lisp_Object variable
)
1872 union Lisp_Val_Fwd valcontents
;
1873 struct Lisp_Symbol
*sym
;
1874 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1876 CHECK_SYMBOL (variable
);
1877 sym
= XSYMBOL (variable
);
1880 switch (sym
->redirect
)
1882 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1883 case SYMBOL_PLAINVAL
:
1884 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1885 if (EQ (valcontents
.value
, Qunbound
))
1886 valcontents
.value
= Qnil
;
1888 case SYMBOL_LOCALIZED
:
1889 if (SYMBOL_BLV (sym
)->frame_local
)
1892 error ("Symbol %s may not be frame-local",
1893 SDATA (SYMBOL_NAME (variable
)));
1894 case SYMBOL_FORWARDED
:
1895 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1896 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1897 error ("Symbol %s may not be frame-local",
1898 SDATA (SYMBOL_NAME (variable
)));
1900 default: emacs_abort ();
1904 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1906 blv
= make_blv (sym
, forwarded
, valcontents
);
1907 blv
->frame_local
= 1;
1908 sym
->redirect
= SYMBOL_LOCALIZED
;
1909 SET_SYMBOL_BLV (sym
, blv
);
1912 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1913 if (let_shadows_global_binding_p (symbol
))
1915 AUTO_STRING (format
, "Making %s frame-local while let-bound!");
1916 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1922 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1924 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1925 BUFFER defaults to the current buffer. */)
1926 (Lisp_Object variable
, Lisp_Object buffer
)
1928 struct buffer
*buf
= decode_buffer (buffer
);
1929 struct Lisp_Symbol
*sym
;
1931 CHECK_SYMBOL (variable
);
1932 sym
= XSYMBOL (variable
);
1935 switch (sym
->redirect
)
1937 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1938 case SYMBOL_PLAINVAL
: return Qnil
;
1939 case SYMBOL_LOCALIZED
:
1941 Lisp_Object tail
, elt
, tmp
;
1942 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1943 XSETBUFFER (tmp
, buf
);
1944 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1946 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1947 return blv_found (blv
) ? Qt
: Qnil
;
1949 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1952 if (EQ (variable
, XCAR (elt
)))
1954 eassert (!blv
->frame_local
);
1960 case SYMBOL_FORWARDED
:
1962 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1963 if (BUFFER_OBJFWDP (valcontents
))
1965 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1966 int idx
= PER_BUFFER_IDX (offset
);
1967 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1972 default: emacs_abort ();
1976 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1978 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1979 BUFFER defaults to the current buffer.
1981 More precisely, return non-nil if either VARIABLE already has a local
1982 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1983 `make-variable-buffer-local'). */)
1984 (register Lisp_Object variable
, Lisp_Object buffer
)
1986 struct Lisp_Symbol
*sym
;
1988 CHECK_SYMBOL (variable
);
1989 sym
= XSYMBOL (variable
);
1992 switch (sym
->redirect
)
1994 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1995 case SYMBOL_PLAINVAL
: return Qnil
;
1996 case SYMBOL_LOCALIZED
:
1998 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1999 if (blv
->local_if_set
)
2001 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2002 return Flocal_variable_p (variable
, buffer
);
2004 case SYMBOL_FORWARDED
:
2005 /* All BUFFER_OBJFWD slots become local if they are set. */
2006 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2007 default: emacs_abort ();
2011 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2013 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2014 If the current binding is buffer-local, the value is the current buffer.
2015 If the current binding is frame-local, the value is the selected frame.
2016 If the current binding is global (the default), the value is nil. */)
2017 (register Lisp_Object variable
)
2019 struct Lisp_Symbol
*sym
;
2021 CHECK_SYMBOL (variable
);
2022 sym
= XSYMBOL (variable
);
2024 /* Make sure the current binding is actually swapped in. */
2025 find_symbol_value (variable
);
2028 switch (sym
->redirect
)
2030 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2031 case SYMBOL_PLAINVAL
: return Qnil
;
2032 case SYMBOL_FORWARDED
:
2034 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2035 if (KBOARD_OBJFWDP (valcontents
))
2036 return Fframe_terminal (selected_frame
);
2037 else if (!BUFFER_OBJFWDP (valcontents
))
2041 case SYMBOL_LOCALIZED
:
2042 /* For a local variable, record both the symbol and which
2043 buffer's or frame's value we are saving. */
2044 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2045 return Fcurrent_buffer ();
2046 else if (sym
->redirect
== SYMBOL_LOCALIZED
2047 && blv_found (SYMBOL_BLV (sym
)))
2048 return SYMBOL_BLV (sym
)->where
;
2051 default: emacs_abort ();
2055 /* This code is disabled now that we use the selected frame to return
2056 keyboard-local-values. */
2058 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2060 DEFUN ("terminal-local-value", Fterminal_local_value
,
2061 Sterminal_local_value
, 2, 2, 0,
2062 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2063 If SYMBOL is not a terminal-local variable, then return its normal
2064 value, like `symbol-value'.
2066 TERMINAL may be a terminal object, a frame, or nil (meaning the
2067 selected frame's terminal device). */)
2068 (Lisp_Object symbol
, Lisp_Object terminal
)
2071 struct terminal
*t
= get_terminal (terminal
, 1);
2072 push_kboard (t
->kboard
);
2073 result
= Fsymbol_value (symbol
);
2078 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2079 Sset_terminal_local_value
, 3, 3, 0,
2080 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2081 If VARIABLE is not a terminal-local variable, then set its normal
2082 binding, like `set'.
2084 TERMINAL may be a terminal object, a frame, or nil (meaning the
2085 selected frame's terminal device). */)
2086 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2089 struct terminal
*t
= get_terminal (terminal
, 1);
2090 push_kboard (d
->kboard
);
2091 result
= Fset (symbol
, value
);
2097 /* Find the function at the end of a chain of symbol function indirections. */
2099 /* If OBJECT is a symbol, find the end of its function chain and
2100 return the value found there. If OBJECT is not a symbol, just
2101 return it. If there is a cycle in the function chain, signal a
2102 cyclic-function-indirection error.
2104 This is like Findirect_function, except that it doesn't signal an
2105 error if the chain ends up unbound. */
2107 indirect_function (register Lisp_Object object
)
2109 Lisp_Object tortoise
, hare
;
2111 hare
= tortoise
= object
;
2115 if (!SYMBOLP (hare
) || NILP (hare
))
2117 hare
= XSYMBOL (hare
)->function
;
2118 if (!SYMBOLP (hare
) || NILP (hare
))
2120 hare
= XSYMBOL (hare
)->function
;
2122 tortoise
= XSYMBOL (tortoise
)->function
;
2124 if (EQ (hare
, tortoise
))
2125 xsignal1 (Qcyclic_function_indirection
, object
);
2131 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2132 doc
: /* Return the function at the end of OBJECT's function chain.
2133 If OBJECT is not a symbol, just return it. Otherwise, follow all
2134 function indirections to find the final function binding and return it.
2135 Signal a cyclic-function-indirection error if there is a loop in the
2136 function chain of symbols. */)
2137 (register Lisp_Object object
, Lisp_Object noerror
)
2141 /* Optimize for no indirection. */
2143 if (SYMBOLP (result
) && !NILP (result
)
2144 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2145 result
= indirect_function (result
);
2152 /* Extract and set vector and string elements. */
2154 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2155 doc
: /* Return the element of ARRAY at index IDX.
2156 ARRAY may be a vector, a string, a char-table, a bool-vector,
2157 or a byte-code object. IDX starts at 0. */)
2158 (register Lisp_Object array
, Lisp_Object idx
)
2160 register EMACS_INT idxval
;
2163 idxval
= XINT (idx
);
2164 if (STRINGP (array
))
2167 ptrdiff_t idxval_byte
;
2169 if (idxval
< 0 || idxval
>= SCHARS (array
))
2170 args_out_of_range (array
, idx
);
2171 if (! STRING_MULTIBYTE (array
))
2172 return make_number ((unsigned char) SREF (array
, idxval
));
2173 idxval_byte
= string_char_to_byte (array
, idxval
);
2175 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2176 return make_number (c
);
2178 else if (BOOL_VECTOR_P (array
))
2180 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2181 args_out_of_range (array
, idx
);
2182 return bool_vector_ref (array
, idxval
);
2184 else if (CHAR_TABLE_P (array
))
2186 CHECK_CHARACTER (idx
);
2187 return CHAR_TABLE_REF (array
, idxval
);
2192 if (VECTORP (array
))
2193 size
= ASIZE (array
);
2194 else if (COMPILEDP (array
))
2195 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2197 wrong_type_argument (Qarrayp
, array
);
2199 if (idxval
< 0 || idxval
>= size
)
2200 args_out_of_range (array
, idx
);
2201 return AREF (array
, idxval
);
2205 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2206 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2207 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2208 bool-vector. IDX starts at 0. */)
2209 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2211 register EMACS_INT idxval
;
2214 idxval
= XINT (idx
);
2215 CHECK_ARRAY (array
, Qarrayp
);
2217 if (VECTORP (array
))
2219 CHECK_IMPURE (array
, XVECTOR (array
));
2220 if (idxval
< 0 || idxval
>= ASIZE (array
))
2221 args_out_of_range (array
, idx
);
2222 ASET (array
, idxval
, newelt
);
2224 else if (BOOL_VECTOR_P (array
))
2226 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2227 args_out_of_range (array
, idx
);
2228 bool_vector_set (array
, idxval
, !NILP (newelt
));
2230 else if (CHAR_TABLE_P (array
))
2232 CHECK_CHARACTER (idx
);
2233 CHAR_TABLE_SET (array
, idxval
, newelt
);
2239 CHECK_IMPURE (array
, XSTRING (array
));
2240 if (idxval
< 0 || idxval
>= SCHARS (array
))
2241 args_out_of_range (array
, idx
);
2242 CHECK_CHARACTER (newelt
);
2243 c
= XFASTINT (newelt
);
2245 if (STRING_MULTIBYTE (array
))
2247 ptrdiff_t idxval_byte
, nbytes
;
2248 int prev_bytes
, new_bytes
;
2249 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2251 nbytes
= SBYTES (array
);
2252 idxval_byte
= string_char_to_byte (array
, idxval
);
2253 p1
= SDATA (array
) + idxval_byte
;
2254 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2255 new_bytes
= CHAR_STRING (c
, p0
);
2256 if (prev_bytes
!= new_bytes
)
2258 /* We must relocate the string data. */
2259 ptrdiff_t nchars
= SCHARS (array
);
2261 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2263 memcpy (str
, SDATA (array
), nbytes
);
2264 allocate_string_data (XSTRING (array
), nchars
,
2265 nbytes
+ new_bytes
- prev_bytes
);
2266 memcpy (SDATA (array
), str
, idxval_byte
);
2267 p1
= SDATA (array
) + idxval_byte
;
2268 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2269 nbytes
- (idxval_byte
+ prev_bytes
));
2271 clear_string_char_byte_cache ();
2278 if (! SINGLE_BYTE_CHAR_P (c
))
2282 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2283 if (SREF (array
, i
) >= 0x80)
2284 args_out_of_range (array
, newelt
);
2285 /* ARRAY is an ASCII string. Convert it to a multibyte
2286 string, and try `aset' again. */
2287 STRING_SET_MULTIBYTE (array
);
2288 return Faset (array
, idx
, newelt
);
2290 SSET (array
, idxval
, c
);
2297 /* Arithmetic functions */
2300 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2302 double f1
= 0, f2
= 0;
2305 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2306 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2308 if (FLOATP (num1
) || FLOATP (num2
))
2311 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2312 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2318 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2322 case ARITH_NOTEQUAL
:
2323 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2328 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2332 case ARITH_LESS_OR_EQUAL
:
2333 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2338 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2342 case ARITH_GRTR_OR_EQUAL
:
2343 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2353 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2354 enum Arith_Comparison comparison
)
2357 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2359 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2365 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2366 doc
: /* Return t if args, all numbers or markers, are equal.
2367 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2368 (ptrdiff_t nargs
, Lisp_Object
*args
)
2370 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2373 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2374 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2375 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2376 (ptrdiff_t nargs
, Lisp_Object
*args
)
2378 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2381 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2382 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2383 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2384 (ptrdiff_t nargs
, Lisp_Object
*args
)
2386 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2389 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2390 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2391 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2392 (ptrdiff_t nargs
, Lisp_Object
*args
)
2394 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2397 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2398 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2399 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2400 (ptrdiff_t nargs
, Lisp_Object
*args
)
2402 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2405 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2406 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2407 (register Lisp_Object num1
, Lisp_Object num2
)
2409 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2412 /* Convert the integer I to a cons-of-integers, where I is not in
2415 #define INTBIG_TO_LISP(i, extremum) \
2416 (eassert (FIXNUM_OVERFLOW_P (i)), \
2417 (! (FIXNUM_OVERFLOW_P ((extremum) >> 16) \
2418 && FIXNUM_OVERFLOW_P ((i) >> 16)) \
2419 ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff)) \
2420 : ! (FIXNUM_OVERFLOW_P ((extremum) >> 16 >> 24) \
2421 && FIXNUM_OVERFLOW_P ((i) >> 16 >> 24)) \
2422 ? Fcons (make_number ((i) >> 16 >> 24), \
2423 Fcons (make_number ((i) >> 16 & 0xffffff), \
2424 make_number ((i) & 0xffff))) \
2428 intbig_to_lisp (intmax_t i
)
2430 return INTBIG_TO_LISP (i
, INTMAX_MIN
);
2434 uintbig_to_lisp (uintmax_t i
)
2436 return INTBIG_TO_LISP (i
, UINTMAX_MAX
);
2439 /* Convert the cons-of-integers, integer, or float value C to an
2440 unsigned value with maximum value MAX. Signal an error if C does not
2441 have a valid format or is out of range. */
2443 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2446 uintmax_t val
IF_LINT (= 0);
2449 valid
= 0 <= XINT (c
);
2452 else if (FLOATP (c
))
2454 double d
= XFLOAT_DATA (c
);
2456 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2462 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2464 uintmax_t top
= XFASTINT (XCAR (c
));
2465 Lisp_Object rest
= XCDR (c
);
2466 if (top
<= UINTMAX_MAX
>> 24 >> 16
2468 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2469 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2471 uintmax_t mid
= XFASTINT (XCAR (rest
));
2472 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2475 else if (top
<= UINTMAX_MAX
>> 16)
2479 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2481 val
= top
<< 16 | XFASTINT (rest
);
2487 if (! (valid
&& val
<= max
))
2488 error ("Not an in-range integer, float, or cons of integers");
2492 /* Convert the cons-of-integers, integer, or float value C to a signed
2493 value with extrema MIN and MAX. Signal an error if C does not have
2494 a valid format or is out of range. */
2496 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2499 intmax_t val
IF_LINT (= 0);
2505 else if (FLOATP (c
))
2507 double d
= XFLOAT_DATA (c
);
2509 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2515 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2517 intmax_t top
= XINT (XCAR (c
));
2518 Lisp_Object rest
= XCDR (c
);
2519 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2521 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2522 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2524 intmax_t mid
= XFASTINT (XCAR (rest
));
2525 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2528 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2532 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2534 val
= top
<< 16 | XFASTINT (rest
);
2540 if (! (valid
&& min
<= val
&& val
<= max
))
2541 error ("Not an in-range integer, float, or cons of integers");
2545 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2546 doc
: /* Return the decimal representation of NUMBER as a string.
2547 Uses a minus sign if negative.
2548 NUMBER may be an integer or a floating point number. */)
2549 (Lisp_Object number
)
2551 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2554 CHECK_NUMBER_OR_FLOAT (number
);
2556 if (FLOATP (number
))
2557 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2559 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2561 return make_unibyte_string (buffer
, len
);
2564 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2565 doc
: /* Parse STRING as a decimal number and return the number.
2566 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2567 STRING cannot be parsed as an integer or floating point number.
2569 If BASE, interpret STRING as a number in that base. If BASE isn't
2570 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2571 If the base used is not 10, STRING is always parsed as an integer. */)
2572 (register Lisp_Object string
, Lisp_Object base
)
2578 CHECK_STRING (string
);
2584 CHECK_NUMBER (base
);
2585 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2586 xsignal1 (Qargs_out_of_range
, base
);
2590 p
= SSDATA (string
);
2591 while (*p
== ' ' || *p
== '\t')
2594 val
= string_to_number (p
, b
, 1);
2595 return NILP (val
) ? make_number (0) : val
;
2611 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2612 ptrdiff_t, Lisp_Object
*);
2614 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2617 ptrdiff_t argnum
, ok_args
;
2618 EMACS_INT accum
= 0;
2619 EMACS_INT next
, ok_accum
;
2641 for (argnum
= 0; argnum
< nargs
; argnum
++)
2649 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2651 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2654 return float_arith_driver (ok_accum
, ok_args
, code
,
2657 next
= XINT (args
[argnum
]);
2661 overflow
|= INT_ADD_WRAPV (accum
, next
, &accum
);
2665 accum
= nargs
== 1 ? - next
: next
;
2667 overflow
|= INT_SUBTRACT_WRAPV (accum
, next
, &accum
);
2670 overflow
|= INT_MULTIPLY_WRAPV (accum
, next
, &accum
);
2673 if (! (argnum
|| nargs
== 1))
2678 xsignal0 (Qarith_error
);
2679 if (INT_DIVIDE_OVERFLOW (accum
, next
))
2695 if (!argnum
|| next
> accum
)
2699 if (!argnum
|| next
< accum
)
2705 XSETINT (val
, accum
);
2710 #define isnan(x) ((x) != (x))
2713 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2714 ptrdiff_t nargs
, Lisp_Object
*args
)
2716 register Lisp_Object val
;
2719 for (; argnum
< nargs
; argnum
++)
2721 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2722 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2726 next
= XFLOAT_DATA (val
);
2730 args
[argnum
] = val
; /* runs into a compiler bug. */
2731 next
= XINT (args
[argnum
]);
2739 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2745 if (! (argnum
|| nargs
== 1))
2749 if (! IEEE_FLOATING_POINT
&& next
== 0)
2750 xsignal0 (Qarith_error
);
2757 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2759 if (!argnum
|| isnan (next
) || next
> accum
)
2763 if (!argnum
|| isnan (next
) || next
< accum
)
2769 return make_float (accum
);
2773 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2774 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2775 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2776 (ptrdiff_t nargs
, Lisp_Object
*args
)
2778 return arith_driver (Aadd
, nargs
, args
);
2781 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2782 doc
: /* Negate number or subtract numbers or markers and return the result.
2783 With one arg, negates it. With more than one arg,
2784 subtracts all but the first from the first.
2785 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2786 (ptrdiff_t nargs
, Lisp_Object
*args
)
2788 return arith_driver (Asub
, nargs
, args
);
2791 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2792 doc
: /* Return product of any number of arguments, which are numbers or markers.
2793 usage: (* &rest NUMBERS-OR-MARKERS) */)
2794 (ptrdiff_t nargs
, Lisp_Object
*args
)
2796 return arith_driver (Amult
, nargs
, args
);
2799 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2800 doc
: /* Divide number by divisors and return the result.
2801 With two or more arguments, return first argument divided by the rest.
2802 With one argument, return 1 divided by the argument.
2803 The arguments must be numbers or markers.
2804 usage: (/ NUMBER &rest DIVISORS) */)
2805 (ptrdiff_t nargs
, Lisp_Object
*args
)
2808 for (argnum
= 2; argnum
< nargs
; argnum
++)
2809 if (FLOATP (args
[argnum
]))
2810 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2811 return arith_driver (Adiv
, nargs
, args
);
2814 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2815 doc
: /* Return remainder of X divided by Y.
2816 Both must be integers or markers. */)
2817 (register Lisp_Object x
, Lisp_Object y
)
2821 CHECK_NUMBER_COERCE_MARKER (x
);
2822 CHECK_NUMBER_COERCE_MARKER (y
);
2825 xsignal0 (Qarith_error
);
2827 XSETINT (val
, XINT (x
) % XINT (y
));
2831 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2832 doc
: /* Return X modulo Y.
2833 The result falls between zero (inclusive) and Y (exclusive).
2834 Both X and Y must be numbers or markers. */)
2835 (register Lisp_Object x
, Lisp_Object y
)
2840 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2841 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2843 if (FLOATP (x
) || FLOATP (y
))
2844 return fmod_float (x
, y
);
2850 xsignal0 (Qarith_error
);
2854 /* If the "remainder" comes out with the wrong sign, fix it. */
2855 if (i2
< 0 ? i1
> 0 : i1
< 0)
2862 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2863 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2864 The value is always a number; markers are converted to numbers.
2865 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2866 (ptrdiff_t nargs
, Lisp_Object
*args
)
2868 return arith_driver (Amax
, nargs
, args
);
2871 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2872 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2873 The value is always a number; markers are converted to numbers.
2874 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2875 (ptrdiff_t nargs
, Lisp_Object
*args
)
2877 return arith_driver (Amin
, nargs
, args
);
2880 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2881 doc
: /* Return bitwise-and of all the arguments.
2882 Arguments may be integers, or markers converted to integers.
2883 usage: (logand &rest INTS-OR-MARKERS) */)
2884 (ptrdiff_t nargs
, Lisp_Object
*args
)
2886 return arith_driver (Alogand
, nargs
, args
);
2889 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2890 doc
: /* Return bitwise-or of all the arguments.
2891 Arguments may be integers, or markers converted to integers.
2892 usage: (logior &rest INTS-OR-MARKERS) */)
2893 (ptrdiff_t nargs
, Lisp_Object
*args
)
2895 return arith_driver (Alogior
, nargs
, args
);
2898 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2899 doc
: /* Return bitwise-exclusive-or of all the arguments.
2900 Arguments may be integers, or markers converted to integers.
2901 usage: (logxor &rest INTS-OR-MARKERS) */)
2902 (ptrdiff_t nargs
, Lisp_Object
*args
)
2904 return arith_driver (Alogxor
, nargs
, args
);
2907 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2908 doc
: /* Return VALUE with its bits shifted left by COUNT.
2909 If COUNT is negative, shifting is actually to the right.
2910 In this case, the sign bit is duplicated. */)
2911 (register Lisp_Object value
, Lisp_Object count
)
2913 register Lisp_Object val
;
2915 CHECK_NUMBER (value
);
2916 CHECK_NUMBER (count
);
2918 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2920 else if (XINT (count
) > 0)
2921 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2922 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2923 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2925 XSETINT (val
, XINT (value
) >> -XINT (count
));
2929 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2930 doc
: /* Return VALUE with its bits shifted left by COUNT.
2931 If COUNT is negative, shifting is actually to the right.
2932 In this case, zeros are shifted in on the left. */)
2933 (register Lisp_Object value
, Lisp_Object count
)
2935 register Lisp_Object val
;
2937 CHECK_NUMBER (value
);
2938 CHECK_NUMBER (count
);
2940 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2942 else if (XINT (count
) > 0)
2943 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2944 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2947 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2951 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2952 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2953 Markers are converted to integers. */)
2954 (register Lisp_Object number
)
2956 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2958 if (FLOATP (number
))
2959 return (make_float (1.0 + XFLOAT_DATA (number
)));
2961 XSETINT (number
, XINT (number
) + 1);
2965 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2966 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2967 Markers are converted to integers. */)
2968 (register Lisp_Object number
)
2970 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2972 if (FLOATP (number
))
2973 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2975 XSETINT (number
, XINT (number
) - 1);
2979 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2980 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2981 (register Lisp_Object number
)
2983 CHECK_NUMBER (number
);
2984 XSETINT (number
, ~XINT (number
));
2988 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2989 doc
: /* Return the byteorder for the machine.
2990 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2991 lowercase l) for small endian machines. */
2995 unsigned i
= 0x04030201;
2996 int order
= *(char *)&i
== 1 ? 108 : 66;
2998 return make_number (order
);
3001 /* Because we round up the bool vector allocate size to word_size
3002 units, we can safely read past the "end" of the vector in the
3003 operations below. These extra bits are always zero. */
3006 bool_vector_spare_mask (EMACS_INT nr_bits
)
3008 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
3011 /* Info about unsigned long long, falling back on unsigned long
3012 if unsigned long long is not available. */
3014 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
3015 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
3016 # define ULL_MAX ULLONG_MAX
3018 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
3019 # define ULL_MAX ULONG_MAX
3020 # define count_one_bits_ll count_one_bits_l
3021 # define count_trailing_zeros_ll count_trailing_zeros_l
3024 /* Shift VAL right by the width of an unsigned long long.
3025 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3028 shift_right_ull (bits_word w
)
3030 /* Pacify bogus GCC warning about shift count exceeding type width. */
3031 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3035 /* Return the number of 1 bits in W. */
3038 count_one_bits_word (bits_word w
)
3040 if (BITS_WORD_MAX
<= UINT_MAX
)
3041 return count_one_bits (w
);
3042 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3043 return count_one_bits_l (w
);
3046 int i
= 0, count
= 0;
3047 while (count
+= count_one_bits_ll (w
),
3048 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3049 w
= shift_right_ull (w
);
3054 enum bool_vector_op
{ bool_vector_exclusive_or
,
3056 bool_vector_intersection
,
3057 bool_vector_set_difference
,
3058 bool_vector_subsetp
};
3061 bool_vector_binop_driver (Lisp_Object a
,
3064 enum bool_vector_op op
)
3067 bits_word
*adata
, *bdata
, *destdata
;
3071 CHECK_BOOL_VECTOR (a
);
3072 CHECK_BOOL_VECTOR (b
);
3074 nr_bits
= bool_vector_size (a
);
3075 if (bool_vector_size (b
) != nr_bits
)
3076 wrong_length_argument (a
, b
, dest
);
3078 nr_words
= bool_vector_words (nr_bits
);
3079 adata
= bool_vector_data (a
);
3080 bdata
= bool_vector_data (b
);
3084 dest
= make_uninit_bool_vector (nr_bits
);
3085 destdata
= bool_vector_data (dest
);
3089 CHECK_BOOL_VECTOR (dest
);
3090 destdata
= bool_vector_data (dest
);
3091 if (bool_vector_size (dest
) != nr_bits
)
3092 wrong_length_argument (a
, b
, dest
);
3096 case bool_vector_exclusive_or
:
3097 for (; i
< nr_words
; i
++)
3098 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3102 case bool_vector_subsetp
:
3103 for (; i
< nr_words
; i
++)
3104 if (adata
[i
] &~ bdata
[i
])
3108 case bool_vector_union
:
3109 for (; i
< nr_words
; i
++)
3110 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3114 case bool_vector_intersection
:
3115 for (; i
< nr_words
; i
++)
3116 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3120 case bool_vector_set_difference
:
3121 for (; i
< nr_words
; i
++)
3122 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3133 case bool_vector_exclusive_or
:
3134 for (; i
< nr_words
; i
++)
3135 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3138 case bool_vector_union
:
3139 for (; i
< nr_words
; i
++)
3140 destdata
[i
] = adata
[i
] | bdata
[i
];
3143 case bool_vector_intersection
:
3144 for (; i
< nr_words
; i
++)
3145 destdata
[i
] = adata
[i
] & bdata
[i
];
3148 case bool_vector_set_difference
:
3149 for (; i
< nr_words
; i
++)
3150 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3160 /* PRECONDITION must be true. Return VALUE. This odd construction
3161 works around a bogus GCC diagnostic "shift count >= width of type". */
3164 pre_value (bool precondition
, int value
)
3166 eassume (precondition
);
3167 return precondition
? value
: 0;
3170 /* Compute the number of trailing zero bits in val. If val is zero,
3171 return the number of bits in val. */
3173 count_trailing_zero_bits (bits_word val
)
3175 if (BITS_WORD_MAX
== UINT_MAX
)
3176 return count_trailing_zeros (val
);
3177 if (BITS_WORD_MAX
== ULONG_MAX
)
3178 return count_trailing_zeros_l (val
);
3179 if (BITS_WORD_MAX
== ULL_MAX
)
3180 return count_trailing_zeros_ll (val
);
3182 /* The rest of this code is for the unlikely platform where bits_word differs
3183 in width from unsigned int, unsigned long, and unsigned long long. */
3184 val
|= ~ BITS_WORD_MAX
;
3185 if (BITS_WORD_MAX
<= UINT_MAX
)
3186 return count_trailing_zeros (val
);
3187 if (BITS_WORD_MAX
<= ULONG_MAX
)
3188 return count_trailing_zeros_l (val
);
3193 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3194 count
+= BITS_PER_ULL
)
3197 return count
+ count_trailing_zeros_ll (val
);
3198 val
= shift_right_ull (val
);
3201 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3202 && BITS_WORD_MAX
== (bits_word
) -1)
3203 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3204 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3205 return count
+ count_trailing_zeros_ll (val
);
3210 bits_word_to_host_endian (bits_word val
)
3212 #ifndef WORDS_BIGENDIAN
3215 if (BITS_WORD_MAX
>> 31 == 1)
3216 return bswap_32 (val
);
3217 # if HAVE_UNSIGNED_LONG_LONG
3218 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3219 return bswap_64 (val
);
3224 for (i
= 0; i
< sizeof val
; i
++)
3226 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3227 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3228 val
= val
>> 1 >> (CHAR_BIT
- 1);
3235 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3236 Sbool_vector_exclusive_or
, 2, 3, 0,
3237 doc
: /* Return A ^ B, bitwise exclusive or.
3238 If optional third argument C is given, store result into C.
3239 A, B, and C must be bool vectors of the same length.
3240 Return the destination vector if it changed or nil otherwise. */)
3241 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3243 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3246 DEFUN ("bool-vector-union", Fbool_vector_union
,
3247 Sbool_vector_union
, 2, 3, 0,
3248 doc
: /* Return A | B, bitwise or.
3249 If optional third argument C is given, store result into C.
3250 A, B, and C must be bool vectors of the same length.
3251 Return the destination vector if it changed or nil otherwise. */)
3252 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3254 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3257 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3258 Sbool_vector_intersection
, 2, 3, 0,
3259 doc
: /* Return A & B, bitwise and.
3260 If optional third argument C is given, store result into C.
3261 A, B, and C must be bool vectors of the same length.
3262 Return the destination vector if it changed or nil otherwise. */)
3263 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3265 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3268 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3269 Sbool_vector_set_difference
, 2, 3, 0,
3270 doc
: /* Return A &~ B, set difference.
3271 If optional third argument C is given, store result into C.
3272 A, B, and C must be bool vectors of the same length.
3273 Return the destination vector if it changed or nil otherwise. */)
3274 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3276 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3279 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3280 Sbool_vector_subsetp
, 2, 2, 0,
3281 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3282 A and B must be bool vectors of the same length. */)
3283 (Lisp_Object a
, Lisp_Object b
)
3285 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3288 DEFUN ("bool-vector-not", Fbool_vector_not
,
3289 Sbool_vector_not
, 1, 2, 0,
3290 doc
: /* Compute ~A, set complement.
3291 If optional second argument B is given, store result into B.
3292 A and B must be bool vectors of the same length.
3293 Return the destination vector. */)
3294 (Lisp_Object a
, Lisp_Object b
)
3297 bits_word
*bdata
, *adata
;
3300 CHECK_BOOL_VECTOR (a
);
3301 nr_bits
= bool_vector_size (a
);
3304 b
= make_uninit_bool_vector (nr_bits
);
3307 CHECK_BOOL_VECTOR (b
);
3308 if (bool_vector_size (b
) != nr_bits
)
3309 wrong_length_argument (a
, b
, Qnil
);
3312 bdata
= bool_vector_data (b
);
3313 adata
= bool_vector_data (a
);
3315 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3316 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3318 if (nr_bits
% BITS_PER_BITS_WORD
)
3320 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3322 mword
&= bool_vector_spare_mask (nr_bits
);
3323 bdata
[i
] = bits_word_to_host_endian (mword
);
3329 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3330 Sbool_vector_count_population
, 1, 1, 0,
3331 doc
: /* Count how many elements in A are t.
3332 A is a bool vector. To count A's nil elements, subtract the return
3333 value from A's length. */)
3339 ptrdiff_t i
, nwords
;
3341 CHECK_BOOL_VECTOR (a
);
3343 nr_bits
= bool_vector_size (a
);
3344 nwords
= bool_vector_words (nr_bits
);
3346 adata
= bool_vector_data (a
);
3348 for (i
= 0; i
< nwords
; i
++)
3349 count
+= count_one_bits_word (adata
[i
]);
3351 return make_number (count
);
3354 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3355 Sbool_vector_count_consecutive
, 3, 3, 0,
3356 doc
: /* Count how many consecutive elements in A equal B starting at I.
3357 A is a bool vector, B is t or nil, and I is an index into A. */)
3358 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3365 bits_word mword
; /* Machine word. */
3366 ptrdiff_t pos
, pos0
;
3369 CHECK_BOOL_VECTOR (a
);
3372 nr_bits
= bool_vector_size (a
);
3373 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3374 args_out_of_range (a
, i
);
3376 adata
= bool_vector_data (a
);
3377 nr_words
= bool_vector_words (nr_bits
);
3378 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3379 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3382 /* By XORing with twiddle, we transform the problem of "count
3383 consecutive equal values" into "count the zero bits". The latter
3384 operation usually has hardware support. */
3385 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3387 /* Scan the remainder of the mword at the current offset. */
3388 if (pos
< nr_words
&& offset
!= 0)
3390 mword
= bits_word_to_host_endian (adata
[pos
]);
3394 /* Do not count the pad bits. */
3395 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3397 count
= count_trailing_zero_bits (mword
);
3399 if (count
+ offset
< BITS_PER_BITS_WORD
)
3400 return make_number (count
);
3403 /* Scan whole words until we either reach the end of the vector or
3404 find an mword that doesn't completely match. twiddle is
3405 endian-independent. */
3407 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3409 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3413 /* If we stopped because of a mismatch, see how many bits match
3414 in the current mword. */
3415 mword
= bits_word_to_host_endian (adata
[pos
]);
3417 count
+= count_trailing_zero_bits (mword
);
3419 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3421 /* If we hit the end, we might have overshot our count. Reduce
3422 the total by the number of spare bits at the end of the
3424 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3427 return make_number (count
);
3434 Lisp_Object error_tail
, arith_tail
;
3436 DEFSYM (Qquote
, "quote");
3437 DEFSYM (Qlambda
, "lambda");
3438 DEFSYM (Qsubr
, "subr");
3439 DEFSYM (Qerror_conditions
, "error-conditions");
3440 DEFSYM (Qerror_message
, "error-message");
3441 DEFSYM (Qtop_level
, "top-level");
3443 DEFSYM (Qerror
, "error");
3444 DEFSYM (Quser_error
, "user-error");
3445 DEFSYM (Qquit
, "quit");
3446 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3447 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3448 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3449 DEFSYM (Qvoid_function
, "void-function");
3450 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3451 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3452 DEFSYM (Qvoid_variable
, "void-variable");
3453 DEFSYM (Qsetting_constant
, "setting-constant");
3454 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3456 DEFSYM (Qinvalid_function
, "invalid-function");
3457 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3458 DEFSYM (Qno_catch
, "no-catch");
3459 DEFSYM (Qend_of_file
, "end-of-file");
3460 DEFSYM (Qarith_error
, "arith-error");
3461 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3462 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3463 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3464 DEFSYM (Qtext_read_only
, "text-read-only");
3465 DEFSYM (Qmark_inactive
, "mark-inactive");
3467 DEFSYM (Qlistp
, "listp");
3468 DEFSYM (Qconsp
, "consp");
3469 DEFSYM (Qsymbolp
, "symbolp");
3470 DEFSYM (Qintegerp
, "integerp");
3471 DEFSYM (Qnatnump
, "natnump");
3472 DEFSYM (Qwholenump
, "wholenump");
3473 DEFSYM (Qstringp
, "stringp");
3474 DEFSYM (Qarrayp
, "arrayp");
3475 DEFSYM (Qsequencep
, "sequencep");
3476 DEFSYM (Qbufferp
, "bufferp");
3477 DEFSYM (Qvectorp
, "vectorp");
3478 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3479 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3480 DEFSYM (Qmarkerp
, "markerp");
3481 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3482 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3483 DEFSYM (Qfboundp
, "fboundp");
3485 DEFSYM (Qfloatp
, "floatp");
3486 DEFSYM (Qnumberp
, "numberp");
3487 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3489 DEFSYM (Qchar_table_p
, "char-table-p");
3490 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3492 DEFSYM (Qsubrp
, "subrp");
3493 DEFSYM (Qunevalled
, "unevalled");
3494 DEFSYM (Qmany
, "many");
3496 DEFSYM (Qcdr
, "cdr");
3498 error_tail
= pure_cons (Qerror
, Qnil
);
3500 /* ERROR is used as a signaler for random errors for which nothing else is
3503 Fput (Qerror
, Qerror_conditions
,
3505 Fput (Qerror
, Qerror_message
,
3506 build_pure_c_string ("error"));
3508 #define PUT_ERROR(sym, tail, msg) \
3509 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3510 Fput (sym, Qerror_message, build_pure_c_string (msg))
3512 PUT_ERROR (Qquit
, Qnil
, "Quit");
3514 PUT_ERROR (Quser_error
, error_tail
, "");
3515 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3516 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3517 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3518 PUT_ERROR (Qvoid_function
, error_tail
,
3519 "Symbol's function definition is void");
3520 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3521 "Symbol's chain of function indirections contains a loop");
3522 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3523 "Symbol's chain of variable indirections contains a loop");
3524 DEFSYM (Qcircular_list
, "circular-list");
3525 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3526 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3527 PUT_ERROR (Qsetting_constant
, error_tail
,
3528 "Attempt to set a constant symbol");
3529 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3530 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3531 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3532 "Wrong number of arguments");
3533 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3534 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3536 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3537 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3538 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3540 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3541 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3542 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3543 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3544 "Text is read-only");
3546 DEFSYM (Qrange_error
, "range-error");
3547 DEFSYM (Qdomain_error
, "domain-error");
3548 DEFSYM (Qsingularity_error
, "singularity-error");
3549 DEFSYM (Qoverflow_error
, "overflow-error");
3550 DEFSYM (Qunderflow_error
, "underflow-error");
3552 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3554 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3556 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3557 "Arithmetic singularity error");
3559 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3560 "Arithmetic overflow error");
3561 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3562 "Arithmetic underflow error");
3564 /* Types that type-of returns. */
3565 DEFSYM (Qinteger
, "integer");
3566 DEFSYM (Qsymbol
, "symbol");
3567 DEFSYM (Qstring
, "string");
3568 DEFSYM (Qcons
, "cons");
3569 DEFSYM (Qmarker
, "marker");
3570 DEFSYM (Qoverlay
, "overlay");
3571 DEFSYM (Qfinalizer
, "finalizer");
3572 DEFSYM (Qfloat
, "float");
3573 DEFSYM (Qwindow_configuration
, "window-configuration");
3574 DEFSYM (Qprocess
, "process");
3575 DEFSYM (Qwindow
, "window");
3576 DEFSYM (Qcompiled_function
, "compiled-function");
3577 DEFSYM (Qbuffer
, "buffer");
3578 DEFSYM (Qframe
, "frame");
3579 DEFSYM (Qvector
, "vector");
3580 DEFSYM (Qchar_table
, "char-table");
3581 DEFSYM (Qbool_vector
, "bool-vector");
3582 DEFSYM (Qhash_table
, "hash-table");
3584 DEFSYM (Qdefun
, "defun");
3586 DEFSYM (Qfont_spec
, "font-spec");
3587 DEFSYM (Qfont_entity
, "font-entity");
3588 DEFSYM (Qfont_object
, "font-object");
3590 DEFSYM (Qinteractive_form
, "interactive-form");
3591 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3593 defsubr (&Sindirect_variable
);
3594 defsubr (&Sinteractive_form
);
3597 defsubr (&Stype_of
);
3602 defsubr (&Sintegerp
);
3603 defsubr (&Sinteger_or_marker_p
);
3604 defsubr (&Snumberp
);
3605 defsubr (&Snumber_or_marker_p
);
3607 defsubr (&Snatnump
);
3608 defsubr (&Ssymbolp
);
3609 defsubr (&Skeywordp
);
3610 defsubr (&Sstringp
);
3611 defsubr (&Smultibyte_string_p
);
3612 defsubr (&Svectorp
);
3613 defsubr (&Schar_table_p
);
3614 defsubr (&Svector_or_char_table_p
);
3615 defsubr (&Sbool_vector_p
);
3617 defsubr (&Ssequencep
);
3618 defsubr (&Sbufferp
);
3619 defsubr (&Smarkerp
);
3621 defsubr (&Sbyte_code_function_p
);
3622 defsubr (&Schar_or_string_p
);
3625 defsubr (&Scar_safe
);
3626 defsubr (&Scdr_safe
);
3629 defsubr (&Ssymbol_function
);
3630 defsubr (&Sindirect_function
);
3631 defsubr (&Ssymbol_plist
);
3632 defsubr (&Ssymbol_name
);
3633 defsubr (&Smakunbound
);
3634 defsubr (&Sfmakunbound
);
3636 defsubr (&Sfboundp
);
3638 defsubr (&Sdefalias
);
3639 defsubr (&Ssetplist
);
3640 defsubr (&Ssymbol_value
);
3642 defsubr (&Sdefault_boundp
);
3643 defsubr (&Sdefault_value
);
3644 defsubr (&Sset_default
);
3645 defsubr (&Ssetq_default
);
3646 defsubr (&Smake_variable_buffer_local
);
3647 defsubr (&Smake_local_variable
);
3648 defsubr (&Skill_local_variable
);
3649 defsubr (&Smake_variable_frame_local
);
3650 defsubr (&Slocal_variable_p
);
3651 defsubr (&Slocal_variable_if_set_p
);
3652 defsubr (&Svariable_binding_locus
);
3653 #if 0 /* XXX Remove this. --lorentey */
3654 defsubr (&Sterminal_local_value
);
3655 defsubr (&Sset_terminal_local_value
);
3659 defsubr (&Snumber_to_string
);
3660 defsubr (&Sstring_to_number
);
3661 defsubr (&Seqlsign
);
3683 defsubr (&Sbyteorder
);
3684 defsubr (&Ssubr_arity
);
3685 defsubr (&Ssubr_name
);
3687 defsubr (&Sbool_vector_exclusive_or
);
3688 defsubr (&Sbool_vector_union
);
3689 defsubr (&Sbool_vector_intersection
);
3690 defsubr (&Sbool_vector_set_difference
);
3691 defsubr (&Sbool_vector_not
);
3692 defsubr (&Sbool_vector_subsetp
);
3693 defsubr (&Sbool_vector_count_consecutive
);
3694 defsubr (&Sbool_vector_count_population
);
3696 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3698 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3699 doc
: /* The largest value that is representable in a Lisp integer. */);
3700 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3701 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3703 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3704 doc
: /* The smallest value that is representable in a Lisp integer. */);
3705 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3706 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;