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"
35 #include "syssignal.h"
36 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 static void swap_in_symval_forwarding (struct Lisp_Symbol
*,
41 struct Lisp_Buffer_Local_Value
*);
44 BOOLFWDP (union Lisp_Fwd
*a
)
46 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
49 INTFWDP (union Lisp_Fwd
*a
)
51 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
54 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
56 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
59 OBJFWDP (union Lisp_Fwd
*a
)
61 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
64 static struct Lisp_Boolfwd
*
65 XBOOLFWD (union Lisp_Fwd
*a
)
67 eassert (BOOLFWDP (a
));
70 static struct Lisp_Kboard_Objfwd
*
71 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
73 eassert (KBOARD_OBJFWDP (a
));
74 return &a
->u_kboard_objfwd
;
76 static struct Lisp_Intfwd
*
77 XINTFWD (union Lisp_Fwd
*a
)
79 eassert (INTFWDP (a
));
82 static struct Lisp_Objfwd
*
83 XOBJFWD (union Lisp_Fwd
*a
)
85 eassert (OBJFWDP (a
));
90 CHECK_SUBR (Lisp_Object x
)
92 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
96 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
98 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
103 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
105 return XCDR (blv
->valcell
);
109 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
111 XSETCDR (blv
->valcell
, val
);
115 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
121 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
127 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
132 static _Noreturn
void
133 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
135 Lisp_Object size1
= make_number (bool_vector_size (a1
));
136 Lisp_Object size2
= make_number (bool_vector_size (a2
));
138 xsignal2 (Qwrong_length_argument
, size1
, size2
);
140 xsignal3 (Qwrong_length_argument
, size1
, size2
,
141 make_number (bool_vector_size (a3
)));
145 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
147 /* If VALUE is not even a valid Lisp object, we'd want to abort here
148 where we can get a backtrace showing where it came from. We used
149 to try and do that by checking the tagbits, but nowadays all
150 tagbits are potentially valid. */
151 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
154 xsignal2 (Qwrong_type_argument
, predicate
, value
);
158 pure_write_error (Lisp_Object obj
)
160 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
164 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
166 xsignal2 (Qargs_out_of_range
, a1
, a2
);
170 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
172 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
176 /* Data type predicates. */
178 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
179 doc
: /* Return t if the two args are the same Lisp object. */
181 (Lisp_Object obj1
, Lisp_Object obj2
)
188 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
189 doc
: /* Return t if OBJECT is nil, and return nil otherwise. */
198 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
199 doc
: /* Return a symbol representing the type of OBJECT.
200 The symbol returned names the object's basic type;
201 for example, (type-of 1) returns `integer'. */)
204 switch (XTYPE (object
))
219 switch (XMISCTYPE (object
))
221 case Lisp_Misc_Marker
:
223 case Lisp_Misc_Overlay
:
225 case Lisp_Misc_Float
:
227 case Lisp_Misc_Finalizer
:
232 case Lisp_Vectorlike
:
233 if (WINDOW_CONFIGURATIONP (object
))
234 return Qwindow_configuration
;
235 if (PROCESSP (object
))
237 if (WINDOWP (object
))
241 if (COMPILEDP (object
))
242 return Qcompiled_function
;
243 if (BUFFERP (object
))
245 if (CHAR_TABLE_P (object
))
247 if (BOOL_VECTOR_P (object
))
251 if (HASH_TABLE_P (object
))
253 if (FONT_SPEC_P (object
))
255 if (FONT_ENTITY_P (object
))
257 if (FONT_OBJECT_P (object
))
269 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
270 doc
: /* Return t if OBJECT is a cons cell. */
279 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */
289 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
290 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
291 Otherwise, return nil. */
295 if (CONSP (object
) || NILP (object
))
300 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
301 doc
: /* Return t if OBJECT is not a list. Lists include nil. */
305 if (CONSP (object
) || NILP (object
))
310 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
311 doc
: /* Return t if OBJECT is a symbol. */
315 if (SYMBOLP (object
))
320 /* Define this in C to avoid unnecessarily consing up the symbol
322 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
323 doc
: /* Return t if OBJECT is a keyword.
324 This means that it is a symbol with a print name beginning with `:'
325 interned in the initial obarray. */)
329 && SREF (SYMBOL_NAME (object
), 0) == ':'
330 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
335 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
336 doc
: /* Return t if OBJECT is a vector. */)
339 if (VECTORP (object
))
344 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
345 doc
: /* Return t if OBJECT is a string. */
349 if (STRINGP (object
))
354 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
356 doc
: /* Return t if OBJECT is a multibyte string.
357 Return nil if OBJECT is either a unibyte string, or not a string. */)
360 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
365 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
366 doc
: /* Return t if OBJECT is a char-table. */)
369 if (CHAR_TABLE_P (object
))
374 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
375 Svector_or_char_table_p
, 1, 1, 0,
376 doc
: /* Return t if OBJECT is a char-table or vector. */)
379 if (VECTORP (object
) || CHAR_TABLE_P (object
))
384 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
385 doc
: /* Return t if OBJECT is a bool-vector. */)
388 if (BOOL_VECTOR_P (object
))
393 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
394 doc
: /* Return t if OBJECT is an array (string or vector). */)
402 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
403 doc
: /* Return t if OBJECT is a sequence (list or array). */)
404 (register Lisp_Object object
)
406 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
411 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
412 doc
: /* Return t if OBJECT is an editor buffer. */)
415 if (BUFFERP (object
))
420 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
421 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
424 if (MARKERP (object
))
429 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
430 doc
: /* Return t if OBJECT is a built-in function. */)
438 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
440 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
443 if (COMPILEDP (object
))
448 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is a character or a string. */
451 (register Lisp_Object object
)
453 if (CHARACTERP (object
) || STRINGP (object
))
458 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer. */
463 if (INTEGERP (object
))
468 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
470 (register Lisp_Object object
)
472 if (MARKERP (object
) || INTEGERP (object
))
477 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
478 doc
: /* Return t if OBJECT is a nonnegative integer. */
482 if (NATNUMP (object
))
487 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
488 doc
: /* Return t if OBJECT is a number (floating point or integer). */
492 if (NUMBERP (object
))
498 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
499 Snumber_or_marker_p
, 1, 1, 0,
500 doc
: /* Return t if OBJECT is a number or a marker. */)
503 if (NUMBERP (object
) || MARKERP (object
))
508 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
509 doc
: /* Return t if OBJECT is a floating point number. */
519 /* Extract and set components of lists. */
521 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
522 doc
: /* Return the car of LIST. If arg is nil, return nil.
523 Error if arg is not nil and not a cons cell. See also `car-safe'.
525 See Info node `(elisp)Cons Cells' for a discussion of related basic
526 Lisp concepts such as car, cdr, cons cell and list. */)
527 (register Lisp_Object list
)
532 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
533 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
536 return CAR_SAFE (object
);
539 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
540 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
541 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
543 See Info node `(elisp)Cons Cells' for a discussion of related basic
544 Lisp concepts such as cdr, car, cons cell and list. */)
545 (register Lisp_Object list
)
550 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
551 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
554 return CDR_SAFE (object
);
557 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
558 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
559 (register Lisp_Object cell
, Lisp_Object newcar
)
563 XSETCAR (cell
, newcar
);
567 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
568 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
569 (register Lisp_Object cell
, Lisp_Object newcdr
)
573 XSETCDR (cell
, newcdr
);
577 /* Extract and set components of symbols. */
579 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
580 doc
: /* Return t if SYMBOL's value is not void.
581 Note that if `lexical-binding' is in effect, this refers to the
582 global value outside of any lexical scope. */)
583 (register Lisp_Object symbol
)
585 Lisp_Object valcontents
;
586 struct Lisp_Symbol
*sym
;
587 CHECK_SYMBOL (symbol
);
588 sym
= XSYMBOL (symbol
);
591 switch (sym
->redirect
)
593 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
594 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
595 case SYMBOL_LOCALIZED
:
597 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
599 /* In set_internal, we un-forward vars when their value is
604 swap_in_symval_forwarding (sym
, blv
);
605 valcontents
= blv_value (blv
);
609 case SYMBOL_FORWARDED
:
610 /* In set_internal, we un-forward vars when their value is
613 default: emacs_abort ();
616 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
619 /* FIXME: Make it an alias for function-symbol! */
620 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
621 doc
: /* Return t if SYMBOL's function definition is not void. */)
622 (register Lisp_Object symbol
)
624 CHECK_SYMBOL (symbol
);
625 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
628 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
629 doc
: /* Make SYMBOL's value be void.
631 (register Lisp_Object symbol
)
633 CHECK_SYMBOL (symbol
);
634 if (SYMBOL_CONSTANT_P (symbol
))
635 xsignal1 (Qsetting_constant
, symbol
);
636 Fset (symbol
, Qunbound
);
640 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
641 doc
: /* Make SYMBOL's function definition be nil.
643 (register Lisp_Object symbol
)
645 CHECK_SYMBOL (symbol
);
646 if (NILP (symbol
) || EQ (symbol
, Qt
))
647 xsignal1 (Qsetting_constant
, symbol
);
648 set_symbol_function (symbol
, Qnil
);
652 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
653 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
654 (register Lisp_Object symbol
)
656 CHECK_SYMBOL (symbol
);
657 return XSYMBOL (symbol
)->function
;
660 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
661 doc
: /* Return SYMBOL's property list. */)
662 (register Lisp_Object symbol
)
664 CHECK_SYMBOL (symbol
);
665 return XSYMBOL (symbol
)->plist
;
668 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
669 doc
: /* Return SYMBOL's name, a string. */)
670 (register Lisp_Object symbol
)
672 register Lisp_Object name
;
674 CHECK_SYMBOL (symbol
);
675 name
= SYMBOL_NAME (symbol
);
679 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
680 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
681 (register Lisp_Object symbol
, Lisp_Object definition
)
683 register Lisp_Object function
;
684 CHECK_SYMBOL (symbol
);
686 function
= XSYMBOL (symbol
)->function
;
688 if (!NILP (Vautoload_queue
) && !NILP (function
))
689 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
691 if (AUTOLOADP (function
))
692 Fput (symbol
, Qautoload
, XCDR (function
));
694 /* Convert to eassert or remove after GC bug is found. In the
695 meantime, check unconditionally, at a slight perf hit. */
696 if (! valid_lisp_object_p (definition
))
699 set_symbol_function (symbol
, definition
);
704 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
705 doc
: /* Set SYMBOL's function definition to DEFINITION.
706 Associates the function with the current load file, if any.
707 The optional third argument DOCSTRING specifies the documentation string
708 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
709 determined by DEFINITION.
711 Internally, this normally uses `fset', but if SYMBOL has a
712 `defalias-fset-function' property, the associated value is used instead.
714 The return value is undefined. */)
715 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
717 CHECK_SYMBOL (symbol
);
718 if (!NILP (Vpurify_flag
)
719 /* If `definition' is a keymap, immutable (and copying) is wrong. */
720 && !KEYMAPP (definition
))
721 definition
= Fpurecopy (definition
);
724 bool autoload
= AUTOLOADP (definition
);
725 if (NILP (Vpurify_flag
) || !autoload
)
726 { /* Only add autoload entries after dumping, because the ones before are
727 not useful and else we get loads of them from the loaddefs.el. */
729 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
730 /* Remember that the function was already an autoload. */
731 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
732 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
736 { /* Handle automatic advice activation. */
737 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
739 call2 (hook
, symbol
, definition
);
741 Ffset (symbol
, definition
);
744 if (!NILP (docstring
))
745 Fput (symbol
, Qfunction_documentation
, docstring
);
746 /* We used to return `definition', but now that `defun' and `defmacro' expand
747 to a call to `defalias', we return `symbol' for backward compatibility
752 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
753 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
754 (register Lisp_Object symbol
, Lisp_Object newplist
)
756 CHECK_SYMBOL (symbol
);
757 set_symbol_plist (symbol
, newplist
);
761 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
762 doc
: /* Return minimum and maximum number of args allowed for SUBR.
763 SUBR must be a built-in function.
764 The returned value is a pair (MIN . MAX). MIN is the minimum number
765 of args. MAX is the maximum number or the symbol `many', for a
766 function with `&rest' args, or `unevalled' for a special form. */)
769 short minargs
, maxargs
;
771 minargs
= XSUBR (subr
)->min_args
;
772 maxargs
= XSUBR (subr
)->max_args
;
773 return Fcons (make_number (minargs
),
774 maxargs
== MANY
? Qmany
775 : maxargs
== UNEVALLED
? Qunevalled
776 : make_number (maxargs
));
779 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
780 doc
: /* Return name of subroutine SUBR.
781 SUBR must be a built-in function. */)
786 name
= XSUBR (subr
)->symbol_name
;
787 return build_string (name
);
790 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
791 doc
: /* Return the interactive form of CMD or nil if none.
792 If CMD is not a command, the return value is nil.
793 Value, if non-nil, is a list \(interactive SPEC). */)
796 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
801 /* Use an `interactive-form' property if present, analogous to the
802 function-documentation property. */
804 while (SYMBOLP (fun
))
806 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
810 fun
= Fsymbol_function (fun
);
815 const char *spec
= XSUBR (fun
)->intspec
;
817 return list2 (Qinteractive
,
818 (*spec
!= '(') ? build_string (spec
) :
819 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
821 else if (COMPILEDP (fun
))
823 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
824 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
826 else if (AUTOLOADP (fun
))
827 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
828 else if (CONSP (fun
))
830 Lisp_Object funcar
= XCAR (fun
);
831 if (EQ (funcar
, Qclosure
))
832 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
833 else if (EQ (funcar
, Qlambda
))
834 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
840 /***********************************************************************
841 Getting and Setting Values of Symbols
842 ***********************************************************************/
844 /* Return the symbol holding SYMBOL's value. Signal
845 `cyclic-variable-indirection' if SYMBOL's chain of variable
846 indirections contains a loop. */
849 indirect_variable (struct Lisp_Symbol
*symbol
)
851 struct Lisp_Symbol
*tortoise
, *hare
;
853 hare
= tortoise
= symbol
;
855 while (hare
->redirect
== SYMBOL_VARALIAS
)
857 hare
= SYMBOL_ALIAS (hare
);
858 if (hare
->redirect
!= SYMBOL_VARALIAS
)
861 hare
= SYMBOL_ALIAS (hare
);
862 tortoise
= SYMBOL_ALIAS (tortoise
);
864 if (hare
== tortoise
)
867 XSETSYMBOL (tem
, symbol
);
868 xsignal1 (Qcyclic_variable_indirection
, tem
);
876 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
877 doc
: /* Return the variable at the end of OBJECT's variable chain.
878 If OBJECT is a symbol, follow its variable indirections (if any), and
879 return the variable at the end of the chain of aliases. See Info node
880 `(elisp)Variable Aliases'.
882 If OBJECT is not a symbol, just return it. If there is a loop in the
883 chain of aliases, signal a `cyclic-variable-indirection' error. */)
886 if (SYMBOLP (object
))
888 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
889 XSETSYMBOL (object
, sym
);
895 /* Given the raw contents of a symbol value cell,
896 return the Lisp value of the symbol.
897 This does not handle buffer-local variables; use
898 swap_in_symval_forwarding for that. */
901 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
903 register Lisp_Object val
;
904 switch (XFWDTYPE (valcontents
))
907 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
911 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
914 return *XOBJFWD (valcontents
)->objvar
;
916 case Lisp_Fwd_Buffer_Obj
:
917 return per_buffer_value (current_buffer
,
918 XBUFFER_OBJFWD (valcontents
)->offset
);
920 case Lisp_Fwd_Kboard_Obj
:
921 /* We used to simply use current_kboard here, but from Lisp
922 code, its value is often unexpected. It seems nicer to
923 allow constructions like this to work as intuitively expected:
925 (with-selected-frame frame
926 (define-key local-function-map "\eOP" [f1]))
928 On the other hand, this affects the semantics of
929 last-command and real-last-command, and people may rely on
930 that. I took a quick look at the Lisp codebase, and I
931 don't think anything will break. --lorentey */
932 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
933 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
934 default: emacs_abort ();
938 /* Used to signal a user-friendly error when symbol WRONG is
939 not a member of CHOICE, which should be a list of symbols. */
942 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
944 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
945 Lisp_Object obj
, *args
;
946 AUTO_STRING (one_of
, "One of ");
947 AUTO_STRING (comma
, ", ");
948 AUTO_STRING (or, " or ");
949 AUTO_STRING (should_be_specified
, " should be specified");
952 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
956 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
958 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
959 args
[i
++] = (NILP (XCDR (obj
)) ? should_be_specified
960 : NILP (XCDR (XCDR (obj
))) ? or : comma
);
963 obj
= Fconcat (i
, args
);
965 xsignal2 (Qerror
, obj
, wrong
);
968 /* Used to signal a user-friendly error if WRONG is not a number or
969 integer/floating-point number outsize of inclusive MIN..MAX range. */
972 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
974 AUTO_STRING (value_should_be_from
, "Value should be from ");
975 AUTO_STRING (to
, " to ");
977 CALLN (Fconcat
, value_should_be_from
, Fnumber_to_string (min
),
978 to
, Fnumber_to_string (max
)),
982 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
983 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
984 buffer-independent contents of the value cell: forwarded just one
985 step past the buffer-localness.
987 BUF non-zero means set the value in buffer BUF instead of the
988 current buffer. This only plays a role for per-buffer variables. */
991 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
993 switch (XFWDTYPE (valcontents
))
996 CHECK_NUMBER (newval
);
997 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1001 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1005 *XOBJFWD (valcontents
)->objvar
= newval
;
1007 /* If this variable is a default for something stored
1008 in the buffer itself, such as default-fill-column,
1009 find the buffers that don't have local values for it
1011 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1012 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1014 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1015 - (char *) &buffer_defaults
);
1016 int idx
= PER_BUFFER_IDX (offset
);
1018 Lisp_Object tail
, buf
;
1023 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1025 struct buffer
*b
= XBUFFER (buf
);
1027 if (! PER_BUFFER_VALUE_P (b
, idx
))
1028 set_per_buffer_value (b
, offset
, newval
);
1033 case Lisp_Fwd_Buffer_Obj
:
1035 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1036 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1040 if (SYMBOLP (predicate
))
1044 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1046 if (NILP (Fmemq (newval
, prop
)))
1047 wrong_choice (prop
, newval
);
1049 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1051 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1053 if (!NUMBERP (newval
)
1054 || !NILP (arithcompare (newval
, min
, ARITH_LESS
))
1055 || !NILP (arithcompare (newval
, max
, ARITH_GRTR
)))
1056 wrong_range (min
, max
, newval
);
1058 else if (FUNCTIONP (predicate
))
1060 if (NILP (call1 (predicate
, newval
)))
1061 wrong_type_argument (predicate
, newval
);
1066 buf
= current_buffer
;
1067 set_per_buffer_value (buf
, offset
, newval
);
1071 case Lisp_Fwd_Kboard_Obj
:
1073 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1074 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1075 *(Lisp_Object
*) p
= newval
;
1080 emacs_abort (); /* goto def; */
1084 /* Set up SYMBOL to refer to its global binding. This makes it safe
1085 to alter the status of other bindings. BEWARE: this may be called
1086 during the mark phase of GC, where we assume that Lisp_Object slots
1087 of BLV are marked after this function has changed them. */
1090 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1092 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1094 /* Unload the previously loaded binding. */
1096 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1098 /* Select the global binding in the symbol. */
1099 set_blv_valcell (blv
, blv
->defcell
);
1101 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1103 /* Indicate that the global binding is set up now. */
1104 set_blv_where (blv
, Qnil
);
1105 set_blv_found (blv
, 0);
1108 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1109 VALCONTENTS is the contents of its value cell,
1110 which points to a struct Lisp_Buffer_Local_Value.
1112 Return the value forwarded one step past the buffer-local stage.
1113 This could be another forwarding pointer. */
1116 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1118 register Lisp_Object tem1
;
1120 eassert (blv
== SYMBOL_BLV (symbol
));
1125 || (blv
->frame_local
1126 ? !EQ (selected_frame
, tem1
)
1127 : current_buffer
!= XBUFFER (tem1
)))
1130 /* Unload the previously loaded binding. */
1131 tem1
= blv
->valcell
;
1133 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1134 /* Choose the new binding. */
1137 XSETSYMBOL (var
, symbol
);
1138 if (blv
->frame_local
)
1140 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1141 set_blv_where (blv
, selected_frame
);
1145 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1146 set_blv_where (blv
, Fcurrent_buffer ());
1149 if (!(blv
->found
= !NILP (tem1
)))
1150 tem1
= blv
->defcell
;
1152 /* Load the new binding. */
1153 set_blv_valcell (blv
, tem1
);
1155 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1159 /* Find the value of a symbol, returning Qunbound if it's not bound.
1160 This is helpful for code which just wants to get a variable's value
1161 if it has one, without signaling an error.
1162 Note that it must not be possible to quit
1163 within this function. Great care is required for this. */
1166 find_symbol_value (Lisp_Object symbol
)
1168 struct Lisp_Symbol
*sym
;
1170 CHECK_SYMBOL (symbol
);
1171 sym
= XSYMBOL (symbol
);
1174 switch (sym
->redirect
)
1176 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1177 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1178 case SYMBOL_LOCALIZED
:
1180 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1181 swap_in_symval_forwarding (sym
, blv
);
1182 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1185 case SYMBOL_FORWARDED
:
1186 return do_symval_forwarding (SYMBOL_FWD (sym
));
1187 default: emacs_abort ();
1191 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1192 doc
: /* Return SYMBOL's value. Error if that is void.
1193 Note that if `lexical-binding' is in effect, this returns the
1194 global value outside of any lexical scope. */)
1195 (Lisp_Object symbol
)
1199 val
= find_symbol_value (symbol
);
1200 if (!EQ (val
, Qunbound
))
1203 xsignal1 (Qvoid_variable
, symbol
);
1206 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1207 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1208 (register Lisp_Object symbol
, Lisp_Object newval
)
1210 set_internal (symbol
, newval
, Qnil
, 0);
1214 /* Store the value NEWVAL into SYMBOL.
1215 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1216 (nil stands for the current buffer/frame).
1218 If BINDFLAG is false, then if this symbol is supposed to become
1219 local in every buffer where it is set, then we make it local.
1220 If BINDFLAG is true, we don't do that. */
1223 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1226 bool voide
= EQ (newval
, Qunbound
);
1227 struct Lisp_Symbol
*sym
;
1230 /* If restoring in a dead buffer, do nothing. */
1231 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1234 CHECK_SYMBOL (symbol
);
1235 if (SYMBOL_CONSTANT_P (symbol
))
1237 if (NILP (Fkeywordp (symbol
))
1238 || !EQ (newval
, Fsymbol_value (symbol
)))
1239 xsignal1 (Qsetting_constant
, symbol
);
1241 /* Allow setting keywords to their own value. */
1245 sym
= XSYMBOL (symbol
);
1248 switch (sym
->redirect
)
1250 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1251 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1252 case SYMBOL_LOCALIZED
:
1254 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1257 if (blv
->frame_local
)
1258 where
= selected_frame
;
1260 XSETBUFFER (where
, current_buffer
);
1262 /* If the current buffer is not the buffer whose binding is
1263 loaded, or if there may be frame-local bindings and the frame
1264 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1265 the default binding is loaded, the loaded binding may be the
1267 if (!EQ (blv
->where
, where
)
1268 /* Also unload a global binding (if the var is local_if_set). */
1269 || (EQ (blv
->valcell
, blv
->defcell
)))
1271 /* The currently loaded binding is not necessarily valid.
1272 We need to unload it, and choose a new binding. */
1274 /* Write out `realvalue' to the old loaded binding. */
1276 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1278 /* Find the new binding. */
1279 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1280 tem1
= assq_no_quit (symbol
,
1282 ? XFRAME (where
)->param_alist
1283 : BVAR (XBUFFER (where
), local_var_alist
)));
1284 set_blv_where (blv
, where
);
1289 /* This buffer still sees the default value. */
1291 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1292 or if this is `let' rather than `set',
1293 make CURRENT-ALIST-ELEMENT point to itself,
1294 indicating that we're seeing the default value.
1295 Likewise if the variable has been let-bound
1296 in the current buffer. */
1297 if (bindflag
|| !blv
->local_if_set
1298 || let_shadows_buffer_binding_p (sym
))
1301 tem1
= blv
->defcell
;
1303 /* If it's a local_if_set, being set not bound,
1304 and we're not within a let that was made for this buffer,
1305 create a new buffer-local binding for the variable.
1306 That means, give this buffer a new assoc for a local value
1307 and load that binding. */
1310 /* local_if_set is only supported for buffer-local
1311 bindings, not for frame-local bindings. */
1312 eassert (!blv
->frame_local
);
1313 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1314 bset_local_var_alist
1316 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1320 /* Record which binding is now loaded. */
1321 set_blv_valcell (blv
, tem1
);
1324 /* Store the new value in the cons cell. */
1325 set_blv_value (blv
, newval
);
1330 /* If storing void (making the symbol void), forward only through
1331 buffer-local indicator, not through Lisp_Objfwd, etc. */
1334 store_symval_forwarding (blv
->fwd
, newval
,
1336 ? XBUFFER (where
) : current_buffer
);
1340 case SYMBOL_FORWARDED
:
1343 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1344 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1345 if (BUFFER_OBJFWDP (innercontents
))
1347 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1348 int idx
= PER_BUFFER_IDX (offset
);
1351 && !let_shadows_buffer_binding_p (sym
))
1352 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1356 { /* If storing void (making the symbol void), forward only through
1357 buffer-local indicator, not through Lisp_Objfwd, etc. */
1358 sym
->redirect
= SYMBOL_PLAINVAL
;
1359 SET_SYMBOL_VAL (sym
, newval
);
1362 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1365 default: emacs_abort ();
1370 /* Access or set a buffer-local symbol's default value. */
1372 /* Return the default value of SYMBOL, but don't check for voidness.
1373 Return Qunbound if it is void. */
1376 default_value (Lisp_Object symbol
)
1378 struct Lisp_Symbol
*sym
;
1380 CHECK_SYMBOL (symbol
);
1381 sym
= XSYMBOL (symbol
);
1384 switch (sym
->redirect
)
1386 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1387 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1388 case SYMBOL_LOCALIZED
:
1390 /* If var is set up for a buffer that lacks a local value for it,
1391 the current value is nominally the default value.
1392 But the `realvalue' slot may be more up to date, since
1393 ordinary setq stores just that slot. So use that. */
1394 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1395 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1396 return do_symval_forwarding (blv
->fwd
);
1398 return XCDR (blv
->defcell
);
1400 case SYMBOL_FORWARDED
:
1402 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1404 /* For a built-in buffer-local variable, get the default value
1405 rather than letting do_symval_forwarding get the current value. */
1406 if (BUFFER_OBJFWDP (valcontents
))
1408 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1409 if (PER_BUFFER_IDX (offset
) != 0)
1410 return per_buffer_default (offset
);
1413 /* For other variables, get the current value. */
1414 return do_symval_forwarding (valcontents
);
1416 default: emacs_abort ();
1420 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1421 doc
: /* Return t if SYMBOL has a non-void default value.
1422 This is the value that is seen in buffers that do not have their own values
1423 for this variable. */)
1424 (Lisp_Object symbol
)
1426 register Lisp_Object value
;
1428 value
= default_value (symbol
);
1429 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1432 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1433 doc
: /* Return SYMBOL's default value.
1434 This is the value that is seen in buffers that do not have their own values
1435 for this variable. The default value is meaningful for variables with
1436 local bindings in certain buffers. */)
1437 (Lisp_Object symbol
)
1439 Lisp_Object value
= default_value (symbol
);
1440 if (!EQ (value
, Qunbound
))
1443 xsignal1 (Qvoid_variable
, symbol
);
1446 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1447 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1448 The default value is seen in buffers that do not have their own values
1449 for this variable. */)
1450 (Lisp_Object symbol
, Lisp_Object value
)
1452 struct Lisp_Symbol
*sym
;
1454 CHECK_SYMBOL (symbol
);
1455 if (SYMBOL_CONSTANT_P (symbol
))
1457 if (NILP (Fkeywordp (symbol
))
1458 || !EQ (value
, Fdefault_value (symbol
)))
1459 xsignal1 (Qsetting_constant
, symbol
);
1461 /* Allow setting keywords to their own value. */
1464 sym
= XSYMBOL (symbol
);
1467 switch (sym
->redirect
)
1469 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1470 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1471 case SYMBOL_LOCALIZED
:
1473 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1475 /* Store new value into the DEFAULT-VALUE slot. */
1476 XSETCDR (blv
->defcell
, value
);
1478 /* If the default binding is now loaded, set the REALVALUE slot too. */
1479 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1480 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1483 case SYMBOL_FORWARDED
:
1485 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1487 /* Handle variables like case-fold-search that have special slots
1489 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1490 if (BUFFER_OBJFWDP (valcontents
))
1492 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1493 int idx
= PER_BUFFER_IDX (offset
);
1495 set_per_buffer_default (offset
, value
);
1497 /* If this variable is not always local in all buffers,
1498 set it in the buffers that don't nominally have a local value. */
1504 if (!PER_BUFFER_VALUE_P (b
, idx
))
1505 set_per_buffer_value (b
, offset
, value
);
1510 return Fset (symbol
, value
);
1512 default: emacs_abort ();
1516 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1517 doc
: /* Set the default value of variable VAR to VALUE.
1518 VAR, the variable name, is literal (not evaluated);
1519 VALUE is an expression: it is evaluated and its value returned.
1520 The default value of a variable is seen in buffers
1521 that do not have their own values for the variable.
1523 More generally, you can use multiple variables and values, as in
1524 (setq-default VAR VALUE VAR VALUE...)
1525 This sets each VAR's default value to the corresponding VALUE.
1526 The VALUE for the Nth VAR can refer to the new default values
1528 usage: (setq-default [VAR VALUE]...) */)
1531 Lisp_Object args_left
, symbol
, val
;
1533 args_left
= val
= args
;
1535 while (CONSP (args_left
))
1537 val
= eval_sub (Fcar (XCDR (args_left
)));
1538 symbol
= XCAR (args_left
);
1539 Fset_default (symbol
, val
);
1540 args_left
= Fcdr (XCDR (args_left
));
1546 /* Lisp functions for creating and removing buffer-local variables. */
1551 union Lisp_Fwd
*fwd
;
1554 static struct Lisp_Buffer_Local_Value
*
1555 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1556 union Lisp_Val_Fwd valcontents
)
1558 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1562 XSETSYMBOL (symbol
, sym
);
1563 tem
= Fcons (symbol
, (forwarded
1564 ? do_symval_forwarding (valcontents
.fwd
)
1565 : valcontents
.value
));
1567 /* Buffer_Local_Values cannot have as realval a buffer-local
1568 or keyboard-local forwarding. */
1569 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1570 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1571 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1572 set_blv_where (blv
, Qnil
);
1573 blv
->frame_local
= 0;
1574 blv
->local_if_set
= 0;
1575 set_blv_defcell (blv
, tem
);
1576 set_blv_valcell (blv
, tem
);
1577 set_blv_found (blv
, 0);
1581 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1582 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1583 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1584 At any time, the value for the current buffer is in effect,
1585 unless the variable has never been set in this buffer,
1586 in which case the default value is in effect.
1587 Note that binding the variable with `let', or setting it while
1588 a `let'-style binding made in this buffer is in effect,
1589 does not make the variable buffer-local. Return VARIABLE.
1591 This globally affects all uses of this variable, so it belongs together with
1592 the variable declaration, rather than with its uses (if you just want to make
1593 a variable local to the current buffer for one particular use, use
1594 `make-local-variable'). Buffer-local bindings are normally cleared
1595 while setting up a new major mode, unless they have a `permanent-local'
1598 The function `default-value' gets the default value and `set-default' sets it. */)
1599 (register Lisp_Object variable
)
1601 struct Lisp_Symbol
*sym
;
1602 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1603 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1604 bool forwarded
IF_LINT (= 0);
1606 CHECK_SYMBOL (variable
);
1607 sym
= XSYMBOL (variable
);
1610 switch (sym
->redirect
)
1612 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1613 case SYMBOL_PLAINVAL
:
1614 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1615 if (EQ (valcontents
.value
, Qunbound
))
1616 valcontents
.value
= Qnil
;
1618 case SYMBOL_LOCALIZED
:
1619 blv
= SYMBOL_BLV (sym
);
1620 if (blv
->frame_local
)
1621 error ("Symbol %s may not be buffer-local",
1622 SDATA (SYMBOL_NAME (variable
)));
1624 case SYMBOL_FORWARDED
:
1625 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1626 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1627 error ("Symbol %s may not be buffer-local",
1628 SDATA (SYMBOL_NAME (variable
)));
1629 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1632 default: emacs_abort ();
1636 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1640 blv
= make_blv (sym
, forwarded
, valcontents
);
1641 sym
->redirect
= SYMBOL_LOCALIZED
;
1642 SET_SYMBOL_BLV (sym
, blv
);
1645 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1646 if (let_shadows_global_binding_p (symbol
))
1648 AUTO_STRING (format
, "Making %s buffer-local while let-bound!");
1649 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1654 blv
->local_if_set
= 1;
1658 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1659 1, 1, "vMake Local Variable: ",
1660 doc
: /* Make VARIABLE have a separate value in the current buffer.
1661 Other buffers will continue to share a common default value.
1662 \(The buffer-local value of VARIABLE starts out as the same value
1663 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1666 If the variable is already arranged to become local when set,
1667 this function causes a local value to exist for this buffer,
1668 just as setting the variable would do.
1670 This function returns VARIABLE, and therefore
1671 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1674 See also `make-variable-buffer-local'.
1676 Do not use `make-local-variable' to make a hook variable buffer-local.
1677 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1678 (Lisp_Object variable
)
1681 bool forwarded
IF_LINT (= 0);
1682 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1683 struct Lisp_Symbol
*sym
;
1684 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1686 CHECK_SYMBOL (variable
);
1687 sym
= XSYMBOL (variable
);
1690 switch (sym
->redirect
)
1692 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1693 case SYMBOL_PLAINVAL
:
1694 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1695 case SYMBOL_LOCALIZED
:
1696 blv
= SYMBOL_BLV (sym
);
1697 if (blv
->frame_local
)
1698 error ("Symbol %s may not be buffer-local",
1699 SDATA (SYMBOL_NAME (variable
)));
1701 case SYMBOL_FORWARDED
:
1702 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1703 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1704 error ("Symbol %s may not be buffer-local",
1705 SDATA (SYMBOL_NAME (variable
)));
1707 default: emacs_abort ();
1711 error ("Symbol %s may not be buffer-local",
1712 SDATA (SYMBOL_NAME (variable
)));
1714 if (blv
? blv
->local_if_set
1715 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1717 tem
= Fboundp (variable
);
1718 /* Make sure the symbol has a local value in this particular buffer,
1719 by setting it to the same value it already has. */
1720 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1725 blv
= make_blv (sym
, forwarded
, valcontents
);
1726 sym
->redirect
= SYMBOL_LOCALIZED
;
1727 SET_SYMBOL_BLV (sym
, blv
);
1730 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1731 if (let_shadows_global_binding_p (symbol
))
1733 AUTO_STRING (format
, "Making %s local to %s while let-bound!");
1734 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
),
1735 BVAR (current_buffer
, name
));
1740 /* Make sure this buffer has its own value of symbol. */
1741 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1742 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1745 if (let_shadows_buffer_binding_p (sym
))
1747 AUTO_STRING (format
,
1748 "Making %s buffer-local while locally let-bound!");
1749 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1752 /* Swap out any local binding for some other buffer, and make
1753 sure the current value is permanently recorded, if it's the
1755 find_symbol_value (variable
);
1757 bset_local_var_alist
1759 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1760 BVAR (current_buffer
, local_var_alist
)));
1762 /* Make sure symbol does not think it is set up for this buffer;
1763 force it to look once again for this buffer's value. */
1764 if (current_buffer
== XBUFFER (blv
->where
))
1765 set_blv_where (blv
, Qnil
);
1766 set_blv_found (blv
, 0);
1769 /* If the symbol forwards into a C variable, then load the binding
1770 for this buffer now. If C code modifies the variable before we
1771 load the binding in, then that new value will clobber the default
1772 binding the next time we unload it. */
1774 swap_in_symval_forwarding (sym
, blv
);
1779 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1780 1, 1, "vKill Local Variable: ",
1781 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1782 From now on the default value will apply in this buffer. Return VARIABLE. */)
1783 (register Lisp_Object variable
)
1785 register Lisp_Object tem
;
1786 struct Lisp_Buffer_Local_Value
*blv
;
1787 struct Lisp_Symbol
*sym
;
1789 CHECK_SYMBOL (variable
);
1790 sym
= XSYMBOL (variable
);
1793 switch (sym
->redirect
)
1795 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1796 case SYMBOL_PLAINVAL
: return variable
;
1797 case SYMBOL_FORWARDED
:
1799 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1800 if (BUFFER_OBJFWDP (valcontents
))
1802 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1803 int idx
= PER_BUFFER_IDX (offset
);
1807 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1808 set_per_buffer_value (current_buffer
, offset
,
1809 per_buffer_default (offset
));
1814 case SYMBOL_LOCALIZED
:
1815 blv
= SYMBOL_BLV (sym
);
1816 if (blv
->frame_local
)
1819 default: emacs_abort ();
1822 /* Get rid of this buffer's alist element, if any. */
1823 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1824 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1826 bset_local_var_alist
1828 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1830 /* If the symbol is set up with the current buffer's binding
1831 loaded, recompute its value. We have to do it now, or else
1832 forwarded objects won't work right. */
1834 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1835 if (EQ (buf
, blv
->where
))
1837 set_blv_where (blv
, Qnil
);
1839 find_symbol_value (variable
);
1846 /* Lisp functions for creating and removing buffer-local variables. */
1848 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1849 when/if this is removed. */
1851 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1852 1, 1, "vMake Variable Frame Local: ",
1853 doc
: /* Enable VARIABLE to have frame-local bindings.
1854 This does not create any frame-local bindings for VARIABLE,
1855 it just makes them possible.
1857 A frame-local binding is actually a frame parameter value.
1858 If a frame F has a value for the frame parameter named VARIABLE,
1859 that also acts as a frame-local binding for VARIABLE in F--
1860 provided this function has been called to enable VARIABLE
1861 to have frame-local bindings at all.
1863 The only way to create a frame-local binding for VARIABLE in a frame
1864 is to set the VARIABLE frame parameter of that frame. See
1865 `modify-frame-parameters' for how to set frame parameters.
1867 Note that since Emacs 23.1, variables cannot be both buffer-local and
1868 frame-local any more (buffer-local bindings used to take precedence over
1869 frame-local bindings). */)
1870 (Lisp_Object variable
)
1873 union Lisp_Val_Fwd valcontents
;
1874 struct Lisp_Symbol
*sym
;
1875 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1877 CHECK_SYMBOL (variable
);
1878 sym
= XSYMBOL (variable
);
1881 switch (sym
->redirect
)
1883 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1884 case SYMBOL_PLAINVAL
:
1885 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1886 if (EQ (valcontents
.value
, Qunbound
))
1887 valcontents
.value
= Qnil
;
1889 case SYMBOL_LOCALIZED
:
1890 if (SYMBOL_BLV (sym
)->frame_local
)
1893 error ("Symbol %s may not be frame-local",
1894 SDATA (SYMBOL_NAME (variable
)));
1895 case SYMBOL_FORWARDED
:
1896 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1897 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1898 error ("Symbol %s may not be frame-local",
1899 SDATA (SYMBOL_NAME (variable
)));
1901 default: emacs_abort ();
1905 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1907 blv
= make_blv (sym
, forwarded
, valcontents
);
1908 blv
->frame_local
= 1;
1909 sym
->redirect
= SYMBOL_LOCALIZED
;
1910 SET_SYMBOL_BLV (sym
, blv
);
1913 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1914 if (let_shadows_global_binding_p (symbol
))
1916 AUTO_STRING (format
, "Making %s frame-local while let-bound!");
1917 CALLN (Fmessage
, format
, SYMBOL_NAME (variable
));
1923 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1925 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1926 BUFFER defaults to the current buffer. */)
1927 (Lisp_Object variable
, Lisp_Object buffer
)
1929 struct buffer
*buf
= decode_buffer (buffer
);
1930 struct Lisp_Symbol
*sym
;
1932 CHECK_SYMBOL (variable
);
1933 sym
= XSYMBOL (variable
);
1936 switch (sym
->redirect
)
1938 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1939 case SYMBOL_PLAINVAL
: return Qnil
;
1940 case SYMBOL_LOCALIZED
:
1942 Lisp_Object tail
, elt
, tmp
;
1943 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1944 XSETBUFFER (tmp
, buf
);
1945 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1947 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1948 return blv_found (blv
) ? Qt
: Qnil
;
1950 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1953 if (EQ (variable
, XCAR (elt
)))
1955 eassert (!blv
->frame_local
);
1961 case SYMBOL_FORWARDED
:
1963 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1964 if (BUFFER_OBJFWDP (valcontents
))
1966 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1967 int idx
= PER_BUFFER_IDX (offset
);
1968 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1973 default: emacs_abort ();
1977 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1979 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1980 BUFFER defaults to the current buffer.
1982 More precisely, return non-nil if either VARIABLE already has a local
1983 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1984 `make-variable-buffer-local'). */)
1985 (register Lisp_Object variable
, Lisp_Object buffer
)
1987 struct Lisp_Symbol
*sym
;
1989 CHECK_SYMBOL (variable
);
1990 sym
= XSYMBOL (variable
);
1993 switch (sym
->redirect
)
1995 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1996 case SYMBOL_PLAINVAL
: return Qnil
;
1997 case SYMBOL_LOCALIZED
:
1999 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2000 if (blv
->local_if_set
)
2002 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2003 return Flocal_variable_p (variable
, buffer
);
2005 case SYMBOL_FORWARDED
:
2006 /* All BUFFER_OBJFWD slots become local if they are set. */
2007 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2008 default: emacs_abort ();
2012 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2014 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2015 If the current binding is buffer-local, the value is the current buffer.
2016 If the current binding is frame-local, the value is the selected frame.
2017 If the current binding is global (the default), the value is nil. */)
2018 (register Lisp_Object variable
)
2020 struct Lisp_Symbol
*sym
;
2022 CHECK_SYMBOL (variable
);
2023 sym
= XSYMBOL (variable
);
2025 /* Make sure the current binding is actually swapped in. */
2026 find_symbol_value (variable
);
2029 switch (sym
->redirect
)
2031 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2032 case SYMBOL_PLAINVAL
: return Qnil
;
2033 case SYMBOL_FORWARDED
:
2035 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2036 if (KBOARD_OBJFWDP (valcontents
))
2037 return Fframe_terminal (selected_frame
);
2038 else if (!BUFFER_OBJFWDP (valcontents
))
2042 case SYMBOL_LOCALIZED
:
2043 /* For a local variable, record both the symbol and which
2044 buffer's or frame's value we are saving. */
2045 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2046 return Fcurrent_buffer ();
2047 else if (sym
->redirect
== SYMBOL_LOCALIZED
2048 && blv_found (SYMBOL_BLV (sym
)))
2049 return SYMBOL_BLV (sym
)->where
;
2052 default: emacs_abort ();
2056 /* This code is disabled now that we use the selected frame to return
2057 keyboard-local-values. */
2059 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2061 DEFUN ("terminal-local-value", Fterminal_local_value
,
2062 Sterminal_local_value
, 2, 2, 0,
2063 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2064 If SYMBOL is not a terminal-local variable, then return its normal
2065 value, like `symbol-value'.
2067 TERMINAL may be a terminal object, a frame, or nil (meaning the
2068 selected frame's terminal device). */)
2069 (Lisp_Object symbol
, Lisp_Object terminal
)
2072 struct terminal
*t
= get_terminal (terminal
, 1);
2073 push_kboard (t
->kboard
);
2074 result
= Fsymbol_value (symbol
);
2079 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2080 Sset_terminal_local_value
, 3, 3, 0,
2081 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2082 If VARIABLE is not a terminal-local variable, then set its normal
2083 binding, like `set'.
2085 TERMINAL may be a terminal object, a frame, or nil (meaning the
2086 selected frame's terminal device). */)
2087 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2090 struct terminal
*t
= get_terminal (terminal
, 1);
2091 push_kboard (d
->kboard
);
2092 result
= Fset (symbol
, value
);
2098 /* Find the function at the end of a chain of symbol function indirections. */
2100 /* If OBJECT is a symbol, find the end of its function chain and
2101 return the value found there. If OBJECT is not a symbol, just
2102 return it. If there is a cycle in the function chain, signal a
2103 cyclic-function-indirection error.
2105 This is like Findirect_function, except that it doesn't signal an
2106 error if the chain ends up unbound. */
2108 indirect_function (register Lisp_Object object
)
2110 Lisp_Object tortoise
, hare
;
2112 hare
= tortoise
= object
;
2116 if (!SYMBOLP (hare
) || NILP (hare
))
2118 hare
= XSYMBOL (hare
)->function
;
2119 if (!SYMBOLP (hare
) || NILP (hare
))
2121 hare
= XSYMBOL (hare
)->function
;
2123 tortoise
= XSYMBOL (tortoise
)->function
;
2125 if (EQ (hare
, tortoise
))
2126 xsignal1 (Qcyclic_function_indirection
, object
);
2132 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2133 doc
: /* Return the function at the end of OBJECT's function chain.
2134 If OBJECT is not a symbol, just return it. Otherwise, follow all
2135 function indirections to find the final function binding and return it.
2136 Signal a cyclic-function-indirection error if there is a loop in the
2137 function chain of symbols. */)
2138 (register Lisp_Object object
, Lisp_Object noerror
)
2142 /* Optimize for no indirection. */
2144 if (SYMBOLP (result
) && !NILP (result
)
2145 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2146 result
= indirect_function (result
);
2153 /* Extract and set vector and string elements. */
2155 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2156 doc
: /* Return the element of ARRAY at index IDX.
2157 ARRAY may be a vector, a string, a char-table, a bool-vector,
2158 or a byte-code object. IDX starts at 0. */)
2159 (register Lisp_Object array
, Lisp_Object idx
)
2161 register EMACS_INT idxval
;
2164 idxval
= XINT (idx
);
2165 if (STRINGP (array
))
2168 ptrdiff_t idxval_byte
;
2170 if (idxval
< 0 || idxval
>= SCHARS (array
))
2171 args_out_of_range (array
, idx
);
2172 if (! STRING_MULTIBYTE (array
))
2173 return make_number ((unsigned char) SREF (array
, idxval
));
2174 idxval_byte
= string_char_to_byte (array
, idxval
);
2176 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2177 return make_number (c
);
2179 else if (BOOL_VECTOR_P (array
))
2181 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2182 args_out_of_range (array
, idx
);
2183 return bool_vector_ref (array
, idxval
);
2185 else if (CHAR_TABLE_P (array
))
2187 CHECK_CHARACTER (idx
);
2188 return CHAR_TABLE_REF (array
, idxval
);
2193 if (VECTORP (array
))
2194 size
= ASIZE (array
);
2195 else if (COMPILEDP (array
))
2196 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2198 wrong_type_argument (Qarrayp
, array
);
2200 if (idxval
< 0 || idxval
>= size
)
2201 args_out_of_range (array
, idx
);
2202 return AREF (array
, idxval
);
2206 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2207 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2208 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2209 bool-vector. IDX starts at 0. */)
2210 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2212 register EMACS_INT idxval
;
2215 idxval
= XINT (idx
);
2216 CHECK_ARRAY (array
, Qarrayp
);
2217 CHECK_IMPURE (array
);
2219 if (VECTORP (array
))
2221 if (idxval
< 0 || idxval
>= ASIZE (array
))
2222 args_out_of_range (array
, idx
);
2223 ASET (array
, idxval
, newelt
);
2225 else if (BOOL_VECTOR_P (array
))
2227 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2228 args_out_of_range (array
, idx
);
2229 bool_vector_set (array
, idxval
, !NILP (newelt
));
2231 else if (CHAR_TABLE_P (array
))
2233 CHECK_CHARACTER (idx
);
2234 CHAR_TABLE_SET (array
, idxval
, newelt
);
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 cons-of-integers, integer, or float value C to an
2413 unsigned value with maximum value MAX. Signal an error if C does not
2414 have a valid format or is out of range. */
2416 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2419 uintmax_t val
IF_LINT (= 0);
2422 valid
= 0 <= XINT (c
);
2425 else if (FLOATP (c
))
2427 double d
= XFLOAT_DATA (c
);
2429 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2435 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2437 uintmax_t top
= XFASTINT (XCAR (c
));
2438 Lisp_Object rest
= XCDR (c
);
2439 if (top
<= UINTMAX_MAX
>> 24 >> 16
2441 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2442 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2444 uintmax_t mid
= XFASTINT (XCAR (rest
));
2445 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2448 else if (top
<= UINTMAX_MAX
>> 16)
2452 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2454 val
= top
<< 16 | XFASTINT (rest
);
2460 if (! (valid
&& val
<= max
))
2461 error ("Not an in-range integer, float, or cons of integers");
2465 /* Convert the cons-of-integers, integer, or float value C to a signed
2466 value with extrema MIN and MAX. Signal an error if C does not have
2467 a valid format or is out of range. */
2469 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2472 intmax_t val
IF_LINT (= 0);
2478 else if (FLOATP (c
))
2480 double d
= XFLOAT_DATA (c
);
2482 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2488 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2490 intmax_t top
= XINT (XCAR (c
));
2491 Lisp_Object rest
= XCDR (c
);
2492 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2494 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2495 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2497 intmax_t mid
= XFASTINT (XCAR (rest
));
2498 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2501 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2505 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2507 val
= top
<< 16 | XFASTINT (rest
);
2513 if (! (valid
&& min
<= val
&& val
<= max
))
2514 error ("Not an in-range integer, float, or cons of integers");
2518 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2519 doc
: /* Return the decimal representation of NUMBER as a string.
2520 Uses a minus sign if negative.
2521 NUMBER may be an integer or a floating point number. */)
2522 (Lisp_Object number
)
2524 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2527 CHECK_NUMBER_OR_FLOAT (number
);
2529 if (FLOATP (number
))
2530 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2532 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2534 return make_unibyte_string (buffer
, len
);
2537 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2538 doc
: /* Parse STRING as a decimal number and return the number.
2539 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2540 STRING cannot be parsed as an integer or floating point number.
2542 If BASE, interpret STRING as a number in that base. If BASE isn't
2543 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2544 If the base used is not 10, STRING is always parsed as an integer. */)
2545 (register Lisp_Object string
, Lisp_Object base
)
2551 CHECK_STRING (string
);
2557 CHECK_NUMBER (base
);
2558 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2559 xsignal1 (Qargs_out_of_range
, base
);
2563 p
= SSDATA (string
);
2564 while (*p
== ' ' || *p
== '\t')
2567 val
= string_to_number (p
, b
, 1);
2568 return NILP (val
) ? make_number (0) : val
;
2584 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2585 ptrdiff_t, Lisp_Object
*);
2587 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2590 ptrdiff_t argnum
, ok_args
;
2591 EMACS_INT accum
= 0;
2592 EMACS_INT next
, ok_accum
;
2613 for (argnum
= 0; argnum
< nargs
; argnum
++)
2621 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2623 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2626 return float_arith_driver (ok_accum
, ok_args
, code
,
2629 next
= XINT (args
[argnum
]);
2633 if (INT_ADD_OVERFLOW (accum
, next
))
2641 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2646 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2649 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2651 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2653 accum
= ab
& INTMASK
;
2664 xsignal0 (Qarith_error
);
2678 if (!argnum
|| next
> accum
)
2682 if (!argnum
|| next
< accum
)
2688 XSETINT (val
, accum
);
2693 #define isnan(x) ((x) != (x))
2696 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2697 ptrdiff_t nargs
, Lisp_Object
*args
)
2699 register Lisp_Object val
;
2702 for (; argnum
< nargs
; argnum
++)
2704 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2705 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2709 next
= XFLOAT_DATA (val
);
2713 args
[argnum
] = val
; /* runs into a compiler bug. */
2714 next
= XINT (args
[argnum
]);
2722 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2732 if (! IEEE_FLOATING_POINT
&& next
== 0)
2733 xsignal0 (Qarith_error
);
2740 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2742 if (!argnum
|| isnan (next
) || next
> accum
)
2746 if (!argnum
|| isnan (next
) || next
< accum
)
2752 return make_float (accum
);
2756 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2757 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2758 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2759 (ptrdiff_t nargs
, Lisp_Object
*args
)
2761 return arith_driver (Aadd
, nargs
, args
);
2764 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2765 doc
: /* Negate number or subtract numbers or markers and return the result.
2766 With one arg, negates it. With more than one arg,
2767 subtracts all but the first from the first.
2768 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2769 (ptrdiff_t nargs
, Lisp_Object
*args
)
2771 return arith_driver (Asub
, nargs
, args
);
2774 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2775 doc
: /* Return product of any number of arguments, which are numbers or markers.
2776 usage: (* &rest NUMBERS-OR-MARKERS) */)
2777 (ptrdiff_t nargs
, Lisp_Object
*args
)
2779 return arith_driver (Amult
, nargs
, args
);
2782 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2783 doc
: /* Return first argument divided by all the remaining arguments.
2784 The arguments must be numbers or markers.
2785 usage: (/ DIVIDEND &rest DIVISORS) */)
2786 (ptrdiff_t nargs
, Lisp_Object
*args
)
2789 for (argnum
= 2; argnum
< nargs
; argnum
++)
2790 if (FLOATP (args
[argnum
]))
2791 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2792 return arith_driver (Adiv
, nargs
, args
);
2795 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2796 doc
: /* Return remainder of X divided by Y.
2797 Both must be integers or markers. */)
2798 (register Lisp_Object x
, Lisp_Object y
)
2802 CHECK_NUMBER_COERCE_MARKER (x
);
2803 CHECK_NUMBER_COERCE_MARKER (y
);
2806 xsignal0 (Qarith_error
);
2808 XSETINT (val
, XINT (x
) % XINT (y
));
2812 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2813 doc
: /* Return X modulo Y.
2814 The result falls between zero (inclusive) and Y (exclusive).
2815 Both X and Y must be numbers or markers. */)
2816 (register Lisp_Object x
, Lisp_Object y
)
2821 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2822 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2824 if (FLOATP (x
) || FLOATP (y
))
2825 return fmod_float (x
, y
);
2831 xsignal0 (Qarith_error
);
2835 /* If the "remainder" comes out with the wrong sign, fix it. */
2836 if (i2
< 0 ? i1
> 0 : i1
< 0)
2843 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2844 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2845 The value is always a number; markers are converted to numbers.
2846 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2847 (ptrdiff_t nargs
, Lisp_Object
*args
)
2849 return arith_driver (Amax
, nargs
, args
);
2852 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2853 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2854 The value is always a number; markers are converted to numbers.
2855 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2856 (ptrdiff_t nargs
, Lisp_Object
*args
)
2858 return arith_driver (Amin
, nargs
, args
);
2861 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2862 doc
: /* Return bitwise-and of all the arguments.
2863 Arguments may be integers, or markers converted to integers.
2864 usage: (logand &rest INTS-OR-MARKERS) */)
2865 (ptrdiff_t nargs
, Lisp_Object
*args
)
2867 return arith_driver (Alogand
, nargs
, args
);
2870 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2871 doc
: /* Return bitwise-or of all the arguments.
2872 Arguments may be integers, or markers converted to integers.
2873 usage: (logior &rest INTS-OR-MARKERS) */)
2874 (ptrdiff_t nargs
, Lisp_Object
*args
)
2876 return arith_driver (Alogior
, nargs
, args
);
2879 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2880 doc
: /* Return bitwise-exclusive-or of all the arguments.
2881 Arguments may be integers, or markers converted to integers.
2882 usage: (logxor &rest INTS-OR-MARKERS) */)
2883 (ptrdiff_t nargs
, Lisp_Object
*args
)
2885 return arith_driver (Alogxor
, nargs
, args
);
2888 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2889 doc
: /* Return VALUE with its bits shifted left by COUNT.
2890 If COUNT is negative, shifting is actually to the right.
2891 In this case, the sign bit is duplicated. */)
2892 (register Lisp_Object value
, Lisp_Object count
)
2894 register Lisp_Object val
;
2896 CHECK_NUMBER (value
);
2897 CHECK_NUMBER (count
);
2899 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2901 else if (XINT (count
) > 0)
2902 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2903 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2904 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2906 XSETINT (val
, XINT (value
) >> -XINT (count
));
2910 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2911 doc
: /* Return VALUE with its bits shifted left by COUNT.
2912 If COUNT is negative, shifting is actually to the right.
2913 In this case, zeros are shifted in on the left. */)
2914 (register Lisp_Object value
, Lisp_Object count
)
2916 register Lisp_Object val
;
2918 CHECK_NUMBER (value
);
2919 CHECK_NUMBER (count
);
2921 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2923 else if (XINT (count
) > 0)
2924 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2925 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2928 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2932 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2933 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2934 Markers are converted to integers. */)
2935 (register Lisp_Object number
)
2937 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2939 if (FLOATP (number
))
2940 return (make_float (1.0 + XFLOAT_DATA (number
)));
2942 XSETINT (number
, XINT (number
) + 1);
2946 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2947 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2948 Markers are converted to integers. */)
2949 (register Lisp_Object number
)
2951 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2953 if (FLOATP (number
))
2954 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2956 XSETINT (number
, XINT (number
) - 1);
2960 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2961 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2962 (register Lisp_Object number
)
2964 CHECK_NUMBER (number
);
2965 XSETINT (number
, ~XINT (number
));
2969 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2970 doc
: /* Return the byteorder for the machine.
2971 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2972 lowercase l) for small endian machines. */
2976 unsigned i
= 0x04030201;
2977 int order
= *(char *)&i
== 1 ? 108 : 66;
2979 return make_number (order
);
2982 /* Because we round up the bool vector allocate size to word_size
2983 units, we can safely read past the "end" of the vector in the
2984 operations below. These extra bits are always zero. */
2987 bool_vector_spare_mask (EMACS_INT nr_bits
)
2989 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2992 /* Info about unsigned long long, falling back on unsigned long
2993 if unsigned long long is not available. */
2995 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2996 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2997 # define ULL_MAX ULLONG_MAX
2999 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
3000 # define ULL_MAX ULONG_MAX
3001 # define count_one_bits_ll count_one_bits_l
3002 # define count_trailing_zeros_ll count_trailing_zeros_l
3005 /* Shift VAL right by the width of an unsigned long long.
3006 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3009 shift_right_ull (bits_word w
)
3011 /* Pacify bogus GCC warning about shift count exceeding type width. */
3012 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3016 /* Return the number of 1 bits in W. */
3019 count_one_bits_word (bits_word w
)
3021 if (BITS_WORD_MAX
<= UINT_MAX
)
3022 return count_one_bits (w
);
3023 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3024 return count_one_bits_l (w
);
3027 int i
= 0, count
= 0;
3028 while (count
+= count_one_bits_ll (w
),
3029 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3030 w
= shift_right_ull (w
);
3035 enum bool_vector_op
{ bool_vector_exclusive_or
,
3037 bool_vector_intersection
,
3038 bool_vector_set_difference
,
3039 bool_vector_subsetp
};
3042 bool_vector_binop_driver (Lisp_Object a
,
3045 enum bool_vector_op op
)
3048 bits_word
*adata
, *bdata
, *destdata
;
3052 CHECK_BOOL_VECTOR (a
);
3053 CHECK_BOOL_VECTOR (b
);
3055 nr_bits
= bool_vector_size (a
);
3056 if (bool_vector_size (b
) != nr_bits
)
3057 wrong_length_argument (a
, b
, dest
);
3059 nr_words
= bool_vector_words (nr_bits
);
3060 adata
= bool_vector_data (a
);
3061 bdata
= bool_vector_data (b
);
3065 dest
= make_uninit_bool_vector (nr_bits
);
3066 destdata
= bool_vector_data (dest
);
3070 CHECK_BOOL_VECTOR (dest
);
3071 destdata
= bool_vector_data (dest
);
3072 if (bool_vector_size (dest
) != nr_bits
)
3073 wrong_length_argument (a
, b
, dest
);
3077 case bool_vector_exclusive_or
:
3078 for (; i
< nr_words
; i
++)
3079 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3083 case bool_vector_subsetp
:
3084 for (; i
< nr_words
; i
++)
3085 if (adata
[i
] &~ bdata
[i
])
3089 case bool_vector_union
:
3090 for (; i
< nr_words
; i
++)
3091 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3095 case bool_vector_intersection
:
3096 for (; i
< nr_words
; i
++)
3097 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3101 case bool_vector_set_difference
:
3102 for (; i
< nr_words
; i
++)
3103 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3114 case bool_vector_exclusive_or
:
3115 for (; i
< nr_words
; i
++)
3116 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3119 case bool_vector_union
:
3120 for (; i
< nr_words
; i
++)
3121 destdata
[i
] = adata
[i
] | bdata
[i
];
3124 case bool_vector_intersection
:
3125 for (; i
< nr_words
; i
++)
3126 destdata
[i
] = adata
[i
] & bdata
[i
];
3129 case bool_vector_set_difference
:
3130 for (; i
< nr_words
; i
++)
3131 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3141 /* PRECONDITION must be true. Return VALUE. This odd construction
3142 works around a bogus GCC diagnostic "shift count >= width of type". */
3145 pre_value (bool precondition
, int value
)
3147 eassume (precondition
);
3148 return precondition
? value
: 0;
3151 /* Compute the number of trailing zero bits in val. If val is zero,
3152 return the number of bits in val. */
3154 count_trailing_zero_bits (bits_word val
)
3156 if (BITS_WORD_MAX
== UINT_MAX
)
3157 return count_trailing_zeros (val
);
3158 if (BITS_WORD_MAX
== ULONG_MAX
)
3159 return count_trailing_zeros_l (val
);
3160 if (BITS_WORD_MAX
== ULL_MAX
)
3161 return count_trailing_zeros_ll (val
);
3163 /* The rest of this code is for the unlikely platform where bits_word differs
3164 in width from unsigned int, unsigned long, and unsigned long long. */
3165 val
|= ~ BITS_WORD_MAX
;
3166 if (BITS_WORD_MAX
<= UINT_MAX
)
3167 return count_trailing_zeros (val
);
3168 if (BITS_WORD_MAX
<= ULONG_MAX
)
3169 return count_trailing_zeros_l (val
);
3174 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3175 count
+= BITS_PER_ULL
)
3178 return count
+ count_trailing_zeros_ll (val
);
3179 val
= shift_right_ull (val
);
3182 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3183 && BITS_WORD_MAX
== (bits_word
) -1)
3184 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3185 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3186 return count
+ count_trailing_zeros_ll (val
);
3191 bits_word_to_host_endian (bits_word val
)
3193 #ifndef WORDS_BIGENDIAN
3196 if (BITS_WORD_MAX
>> 31 == 1)
3197 return bswap_32 (val
);
3198 # if HAVE_UNSIGNED_LONG_LONG
3199 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3200 return bswap_64 (val
);
3205 for (i
= 0; i
< sizeof val
; i
++)
3207 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3208 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3209 val
= val
>> 1 >> (CHAR_BIT
- 1);
3216 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3217 Sbool_vector_exclusive_or
, 2, 3, 0,
3218 doc
: /* Return A ^ B, bitwise exclusive or.
3219 If optional third argument C is given, store result into C.
3220 A, B, and C must be bool vectors of the same length.
3221 Return the destination vector if it changed or nil otherwise. */)
3222 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3224 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3227 DEFUN ("bool-vector-union", Fbool_vector_union
,
3228 Sbool_vector_union
, 2, 3, 0,
3229 doc
: /* Return A | B, bitwise or.
3230 If optional third argument C is given, store result into C.
3231 A, B, and C must be bool vectors of the same length.
3232 Return the destination vector if it changed or nil otherwise. */)
3233 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3235 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3238 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3239 Sbool_vector_intersection
, 2, 3, 0,
3240 doc
: /* Return A & B, bitwise and.
3241 If optional third argument C is given, store result into C.
3242 A, B, and C must be bool vectors of the same length.
3243 Return the destination vector if it changed or nil otherwise. */)
3244 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3246 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3249 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3250 Sbool_vector_set_difference
, 2, 3, 0,
3251 doc
: /* Return A &~ B, set difference.
3252 If optional third argument C is given, store result into C.
3253 A, B, and C must be bool vectors of the same length.
3254 Return the destination vector if it changed or nil otherwise. */)
3255 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3257 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3260 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3261 Sbool_vector_subsetp
, 2, 2, 0,
3262 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3263 A and B must be bool vectors of the same length. */)
3264 (Lisp_Object a
, Lisp_Object b
)
3266 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3269 DEFUN ("bool-vector-not", Fbool_vector_not
,
3270 Sbool_vector_not
, 1, 2, 0,
3271 doc
: /* Compute ~A, set complement.
3272 If optional second argument B is given, store result into B.
3273 A and B must be bool vectors of the same length.
3274 Return the destination vector. */)
3275 (Lisp_Object a
, Lisp_Object b
)
3278 bits_word
*bdata
, *adata
;
3281 CHECK_BOOL_VECTOR (a
);
3282 nr_bits
= bool_vector_size (a
);
3285 b
= make_uninit_bool_vector (nr_bits
);
3288 CHECK_BOOL_VECTOR (b
);
3289 if (bool_vector_size (b
) != nr_bits
)
3290 wrong_length_argument (a
, b
, Qnil
);
3293 bdata
= bool_vector_data (b
);
3294 adata
= bool_vector_data (a
);
3296 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3297 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3299 if (nr_bits
% BITS_PER_BITS_WORD
)
3301 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3303 mword
&= bool_vector_spare_mask (nr_bits
);
3304 bdata
[i
] = bits_word_to_host_endian (mword
);
3310 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3311 Sbool_vector_count_population
, 1, 1, 0,
3312 doc
: /* Count how many elements in A are t.
3313 A is a bool vector. To count A's nil elements, subtract the return
3314 value from A's length. */)
3320 ptrdiff_t i
, nwords
;
3322 CHECK_BOOL_VECTOR (a
);
3324 nr_bits
= bool_vector_size (a
);
3325 nwords
= bool_vector_words (nr_bits
);
3327 adata
= bool_vector_data (a
);
3329 for (i
= 0; i
< nwords
; i
++)
3330 count
+= count_one_bits_word (adata
[i
]);
3332 return make_number (count
);
3335 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3336 Sbool_vector_count_consecutive
, 3, 3, 0,
3337 doc
: /* Count how many consecutive elements in A equal B starting at I.
3338 A is a bool vector, B is t or nil, and I is an index into A. */)
3339 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3346 bits_word mword
; /* Machine word. */
3347 ptrdiff_t pos
, pos0
;
3350 CHECK_BOOL_VECTOR (a
);
3353 nr_bits
= bool_vector_size (a
);
3354 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3355 args_out_of_range (a
, i
);
3357 adata
= bool_vector_data (a
);
3358 nr_words
= bool_vector_words (nr_bits
);
3359 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3360 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3363 /* By XORing with twiddle, we transform the problem of "count
3364 consecutive equal values" into "count the zero bits". The latter
3365 operation usually has hardware support. */
3366 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3368 /* Scan the remainder of the mword at the current offset. */
3369 if (pos
< nr_words
&& offset
!= 0)
3371 mword
= bits_word_to_host_endian (adata
[pos
]);
3375 /* Do not count the pad bits. */
3376 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3378 count
= count_trailing_zero_bits (mword
);
3380 if (count
+ offset
< BITS_PER_BITS_WORD
)
3381 return make_number (count
);
3384 /* Scan whole words until we either reach the end of the vector or
3385 find an mword that doesn't completely match. twiddle is
3386 endian-independent. */
3388 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3390 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3394 /* If we stopped because of a mismatch, see how many bits match
3395 in the current mword. */
3396 mword
= bits_word_to_host_endian (adata
[pos
]);
3398 count
+= count_trailing_zero_bits (mword
);
3400 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3402 /* If we hit the end, we might have overshot our count. Reduce
3403 the total by the number of spare bits at the end of the
3405 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3408 return make_number (count
);
3415 Lisp_Object error_tail
, arith_tail
;
3417 DEFSYM (Qquote
, "quote");
3418 DEFSYM (Qlambda
, "lambda");
3419 DEFSYM (Qsubr
, "subr");
3420 DEFSYM (Qerror_conditions
, "error-conditions");
3421 DEFSYM (Qerror_message
, "error-message");
3422 DEFSYM (Qtop_level
, "top-level");
3424 DEFSYM (Qerror
, "error");
3425 DEFSYM (Quser_error
, "user-error");
3426 DEFSYM (Qquit
, "quit");
3427 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3428 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3429 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3430 DEFSYM (Qvoid_function
, "void-function");
3431 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3432 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3433 DEFSYM (Qvoid_variable
, "void-variable");
3434 DEFSYM (Qsetting_constant
, "setting-constant");
3435 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3437 DEFSYM (Qinvalid_function
, "invalid-function");
3438 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3439 DEFSYM (Qno_catch
, "no-catch");
3440 DEFSYM (Qend_of_file
, "end-of-file");
3441 DEFSYM (Qarith_error
, "arith-error");
3442 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3443 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3444 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3445 DEFSYM (Qtext_read_only
, "text-read-only");
3446 DEFSYM (Qmark_inactive
, "mark-inactive");
3448 DEFSYM (Qlistp
, "listp");
3449 DEFSYM (Qconsp
, "consp");
3450 DEFSYM (Qsymbolp
, "symbolp");
3451 DEFSYM (Qintegerp
, "integerp");
3452 DEFSYM (Qnatnump
, "natnump");
3453 DEFSYM (Qwholenump
, "wholenump");
3454 DEFSYM (Qstringp
, "stringp");
3455 DEFSYM (Qarrayp
, "arrayp");
3456 DEFSYM (Qsequencep
, "sequencep");
3457 DEFSYM (Qbufferp
, "bufferp");
3458 DEFSYM (Qvectorp
, "vectorp");
3459 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3460 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3461 DEFSYM (Qmarkerp
, "markerp");
3462 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3463 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3464 DEFSYM (Qfboundp
, "fboundp");
3466 DEFSYM (Qfloatp
, "floatp");
3467 DEFSYM (Qnumberp
, "numberp");
3468 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3470 DEFSYM (Qchar_table_p
, "char-table-p");
3471 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3473 DEFSYM (Qsubrp
, "subrp");
3474 DEFSYM (Qunevalled
, "unevalled");
3475 DEFSYM (Qmany
, "many");
3477 DEFSYM (Qcdr
, "cdr");
3479 error_tail
= pure_cons (Qerror
, Qnil
);
3481 /* ERROR is used as a signaler for random errors for which nothing else is
3484 Fput (Qerror
, Qerror_conditions
,
3486 Fput (Qerror
, Qerror_message
,
3487 build_pure_c_string ("error"));
3489 #define PUT_ERROR(sym, tail, msg) \
3490 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3491 Fput (sym, Qerror_message, build_pure_c_string (msg))
3493 PUT_ERROR (Qquit
, Qnil
, "Quit");
3495 PUT_ERROR (Quser_error
, error_tail
, "");
3496 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3497 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3498 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3499 PUT_ERROR (Qvoid_function
, error_tail
,
3500 "Symbol's function definition is void");
3501 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3502 "Symbol's chain of function indirections contains a loop");
3503 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3504 "Symbol's chain of variable indirections contains a loop");
3505 DEFSYM (Qcircular_list
, "circular-list");
3506 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3507 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3508 PUT_ERROR (Qsetting_constant
, error_tail
,
3509 "Attempt to set a constant symbol");
3510 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3511 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3512 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3513 "Wrong number of arguments");
3514 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3515 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3517 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3518 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3519 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3521 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3522 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3523 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3524 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3525 "Text is read-only");
3527 DEFSYM (Qrange_error
, "range-error");
3528 DEFSYM (Qdomain_error
, "domain-error");
3529 DEFSYM (Qsingularity_error
, "singularity-error");
3530 DEFSYM (Qoverflow_error
, "overflow-error");
3531 DEFSYM (Qunderflow_error
, "underflow-error");
3533 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3535 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3537 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3538 "Arithmetic singularity error");
3540 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3541 "Arithmetic overflow error");
3542 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3543 "Arithmetic underflow error");
3545 /* Types that type-of returns. */
3546 DEFSYM (Qinteger
, "integer");
3547 DEFSYM (Qsymbol
, "symbol");
3548 DEFSYM (Qstring
, "string");
3549 DEFSYM (Qcons
, "cons");
3550 DEFSYM (Qmarker
, "marker");
3551 DEFSYM (Qoverlay
, "overlay");
3552 DEFSYM (Qfinalizer
, "finalizer");
3553 DEFSYM (Qfloat
, "float");
3554 DEFSYM (Qwindow_configuration
, "window-configuration");
3555 DEFSYM (Qprocess
, "process");
3556 DEFSYM (Qwindow
, "window");
3557 DEFSYM (Qcompiled_function
, "compiled-function");
3558 DEFSYM (Qbuffer
, "buffer");
3559 DEFSYM (Qframe
, "frame");
3560 DEFSYM (Qvector
, "vector");
3561 DEFSYM (Qchar_table
, "char-table");
3562 DEFSYM (Qbool_vector
, "bool-vector");
3563 DEFSYM (Qhash_table
, "hash-table");
3565 DEFSYM (Qdefun
, "defun");
3567 DEFSYM (Qfont_spec
, "font-spec");
3568 DEFSYM (Qfont_entity
, "font-entity");
3569 DEFSYM (Qfont_object
, "font-object");
3571 DEFSYM (Qinteractive_form
, "interactive-form");
3572 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3574 defsubr (&Sindirect_variable
);
3575 defsubr (&Sinteractive_form
);
3578 defsubr (&Stype_of
);
3583 defsubr (&Sintegerp
);
3584 defsubr (&Sinteger_or_marker_p
);
3585 defsubr (&Snumberp
);
3586 defsubr (&Snumber_or_marker_p
);
3588 defsubr (&Snatnump
);
3589 defsubr (&Ssymbolp
);
3590 defsubr (&Skeywordp
);
3591 defsubr (&Sstringp
);
3592 defsubr (&Smultibyte_string_p
);
3593 defsubr (&Svectorp
);
3594 defsubr (&Schar_table_p
);
3595 defsubr (&Svector_or_char_table_p
);
3596 defsubr (&Sbool_vector_p
);
3598 defsubr (&Ssequencep
);
3599 defsubr (&Sbufferp
);
3600 defsubr (&Smarkerp
);
3602 defsubr (&Sbyte_code_function_p
);
3603 defsubr (&Schar_or_string_p
);
3606 defsubr (&Scar_safe
);
3607 defsubr (&Scdr_safe
);
3610 defsubr (&Ssymbol_function
);
3611 defsubr (&Sindirect_function
);
3612 defsubr (&Ssymbol_plist
);
3613 defsubr (&Ssymbol_name
);
3614 defsubr (&Smakunbound
);
3615 defsubr (&Sfmakunbound
);
3617 defsubr (&Sfboundp
);
3619 defsubr (&Sdefalias
);
3620 defsubr (&Ssetplist
);
3621 defsubr (&Ssymbol_value
);
3623 defsubr (&Sdefault_boundp
);
3624 defsubr (&Sdefault_value
);
3625 defsubr (&Sset_default
);
3626 defsubr (&Ssetq_default
);
3627 defsubr (&Smake_variable_buffer_local
);
3628 defsubr (&Smake_local_variable
);
3629 defsubr (&Skill_local_variable
);
3630 defsubr (&Smake_variable_frame_local
);
3631 defsubr (&Slocal_variable_p
);
3632 defsubr (&Slocal_variable_if_set_p
);
3633 defsubr (&Svariable_binding_locus
);
3634 #if 0 /* XXX Remove this. --lorentey */
3635 defsubr (&Sterminal_local_value
);
3636 defsubr (&Sset_terminal_local_value
);
3640 defsubr (&Snumber_to_string
);
3641 defsubr (&Sstring_to_number
);
3642 defsubr (&Seqlsign
);
3664 defsubr (&Sbyteorder
);
3665 defsubr (&Ssubr_arity
);
3666 defsubr (&Ssubr_name
);
3668 defsubr (&Sbool_vector_exclusive_or
);
3669 defsubr (&Sbool_vector_union
);
3670 defsubr (&Sbool_vector_intersection
);
3671 defsubr (&Sbool_vector_set_difference
);
3672 defsubr (&Sbool_vector_not
);
3673 defsubr (&Sbool_vector_subsetp
);
3674 defsubr (&Sbool_vector_count_consecutive
);
3675 defsubr (&Sbool_vector_count_population
);
3677 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3679 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3680 doc
: /* The largest value that is representable in a Lisp integer. */);
3681 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3682 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3684 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3685 doc
: /* The smallest value that is representable in a Lisp integer. */);
3686 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3687 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;