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. */
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
:
230 case Lisp_Vectorlike
:
231 if (WINDOW_CONFIGURATIONP (object
))
232 return Qwindow_configuration
;
233 if (PROCESSP (object
))
235 if (WINDOWP (object
))
239 if (COMPILEDP (object
))
240 return Qcompiled_function
;
241 if (BUFFERP (object
))
243 if (CHAR_TABLE_P (object
))
245 if (BOOL_VECTOR_P (object
))
249 if (HASH_TABLE_P (object
))
251 if (FONT_SPEC_P (object
))
253 if (FONT_ENTITY_P (object
))
255 if (FONT_OBJECT_P (object
))
267 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
268 doc
: /* Return t if OBJECT is a cons cell. */
277 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
278 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */
287 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
288 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
289 Otherwise, return nil. */
293 if (CONSP (object
) || NILP (object
))
298 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
299 doc
: /* Return t if OBJECT is not a list. Lists include nil. */
303 if (CONSP (object
) || NILP (object
))
308 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
309 doc
: /* Return t if OBJECT is a symbol. */
313 if (SYMBOLP (object
))
318 /* Define this in C to avoid unnecessarily consing up the symbol
320 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a keyword.
322 This means that it is a symbol with a print name beginning with `:'
323 interned in the initial obarray. */)
327 && SREF (SYMBOL_NAME (object
), 0) == ':'
328 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
333 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is a vector. */)
337 if (VECTORP (object
))
342 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
343 doc
: /* Return t if OBJECT is a string. */
347 if (STRINGP (object
))
352 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
354 doc
: /* Return t if OBJECT is a multibyte string.
355 Return nil if OBJECT is either a unibyte string, or not a string. */)
358 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
363 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
364 doc
: /* Return t if OBJECT is a char-table. */)
367 if (CHAR_TABLE_P (object
))
372 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
373 Svector_or_char_table_p
, 1, 1, 0,
374 doc
: /* Return t if OBJECT is a char-table or vector. */)
377 if (VECTORP (object
) || CHAR_TABLE_P (object
))
382 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is a bool-vector. */)
386 if (BOOL_VECTOR_P (object
))
391 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
392 doc
: /* Return t if OBJECT is an array (string or vector). */)
400 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
401 doc
: /* Return t if OBJECT is a sequence (list or array). */)
402 (register Lisp_Object object
)
404 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
409 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
410 doc
: /* Return t if OBJECT is an editor buffer. */)
413 if (BUFFERP (object
))
418 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
422 if (MARKERP (object
))
427 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
428 doc
: /* Return t if OBJECT is a built-in function. */)
436 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
438 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
441 if (COMPILEDP (object
))
446 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
447 doc
: /* Return t if OBJECT is a character or a string. */
449 (register Lisp_Object object
)
451 if (CHARACTERP (object
) || STRINGP (object
))
456 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
457 doc
: /* Return t if OBJECT is an integer. */
461 if (INTEGERP (object
))
466 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
467 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
468 (register Lisp_Object object
)
470 if (MARKERP (object
) || INTEGERP (object
))
475 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
476 doc
: /* Return t if OBJECT is a nonnegative integer. */
480 if (NATNUMP (object
))
485 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
486 doc
: /* Return t if OBJECT is a number (floating point or integer). */
490 if (NUMBERP (object
))
496 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
497 Snumber_or_marker_p
, 1, 1, 0,
498 doc
: /* Return t if OBJECT is a number or a marker. */)
501 if (NUMBERP (object
) || MARKERP (object
))
506 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
507 doc
: /* Return t if OBJECT is a floating point number. */
517 /* Extract and set components of lists. */
519 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
520 doc
: /* Return the car of LIST. If arg is nil, return nil.
521 Error if arg is not nil and not a cons cell. See also `car-safe'.
523 See Info node `(elisp)Cons Cells' for a discussion of related basic
524 Lisp concepts such as car, cdr, cons cell and list. */)
525 (register Lisp_Object list
)
530 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
531 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
534 return CAR_SAFE (object
);
537 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
538 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
539 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
541 See Info node `(elisp)Cons Cells' for a discussion of related basic
542 Lisp concepts such as cdr, car, cons cell and list. */)
543 (register Lisp_Object list
)
548 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
549 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
552 return CDR_SAFE (object
);
555 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
556 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
557 (register Lisp_Object cell
, Lisp_Object newcar
)
561 XSETCAR (cell
, newcar
);
565 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
566 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
567 (register Lisp_Object cell
, Lisp_Object newcdr
)
571 XSETCDR (cell
, newcdr
);
575 /* Extract and set components of symbols. */
577 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
578 doc
: /* Return t if SYMBOL's value is not void.
579 Note that if `lexical-binding' is in effect, this refers to the
580 global value outside of any lexical scope. */)
581 (register Lisp_Object symbol
)
583 Lisp_Object valcontents
;
584 struct Lisp_Symbol
*sym
;
585 CHECK_SYMBOL (symbol
);
586 sym
= XSYMBOL (symbol
);
589 switch (sym
->redirect
)
591 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
592 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
593 case SYMBOL_LOCALIZED
:
595 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
597 /* In set_internal, we un-forward vars when their value is
602 swap_in_symval_forwarding (sym
, blv
);
603 valcontents
= blv_value (blv
);
607 case SYMBOL_FORWARDED
:
608 /* In set_internal, we un-forward vars when their value is
611 default: emacs_abort ();
614 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
617 /* FIXME: Make it an alias for function-symbol! */
618 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
619 doc
: /* Return t if SYMBOL's function definition is not void. */)
620 (register Lisp_Object symbol
)
622 CHECK_SYMBOL (symbol
);
623 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
626 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
627 doc
: /* Make SYMBOL's value be void.
629 (register Lisp_Object symbol
)
631 CHECK_SYMBOL (symbol
);
632 if (SYMBOL_CONSTANT_P (symbol
))
633 xsignal1 (Qsetting_constant
, symbol
);
634 Fset (symbol
, Qunbound
);
638 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
639 doc
: /* Make SYMBOL's function definition be nil.
641 (register Lisp_Object symbol
)
643 CHECK_SYMBOL (symbol
);
644 if (NILP (symbol
) || EQ (symbol
, Qt
))
645 xsignal1 (Qsetting_constant
, symbol
);
646 set_symbol_function (symbol
, Qnil
);
650 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
651 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
652 (register Lisp_Object symbol
)
654 CHECK_SYMBOL (symbol
);
655 return XSYMBOL (symbol
)->function
;
658 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
659 doc
: /* Return SYMBOL's property list. */)
660 (register Lisp_Object symbol
)
662 CHECK_SYMBOL (symbol
);
663 return XSYMBOL (symbol
)->plist
;
666 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
667 doc
: /* Return SYMBOL's name, a string. */)
668 (register Lisp_Object symbol
)
670 register Lisp_Object name
;
672 CHECK_SYMBOL (symbol
);
673 name
= SYMBOL_NAME (symbol
);
677 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
678 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
679 (register Lisp_Object symbol
, Lisp_Object definition
)
681 register Lisp_Object function
;
682 CHECK_SYMBOL (symbol
);
684 function
= XSYMBOL (symbol
)->function
;
686 if (!NILP (Vautoload_queue
) && !NILP (function
))
687 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
689 if (AUTOLOADP (function
))
690 Fput (symbol
, Qautoload
, XCDR (function
));
692 /* Convert to eassert or remove after GC bug is found. In the
693 meantime, check unconditionally, at a slight perf hit. */
694 if (! valid_lisp_object_p (definition
))
697 set_symbol_function (symbol
, definition
);
702 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
703 doc
: /* Set SYMBOL's function definition to DEFINITION.
704 Associates the function with the current load file, if any.
705 The optional third argument DOCSTRING specifies the documentation string
706 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
707 determined by DEFINITION.
709 Internally, this normally uses `fset', but if SYMBOL has a
710 `defalias-fset-function' property, the associated value is used instead.
712 The return value is undefined. */)
713 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
715 CHECK_SYMBOL (symbol
);
716 if (!NILP (Vpurify_flag
)
717 /* If `definition' is a keymap, immutable (and copying) is wrong. */
718 && !KEYMAPP (definition
))
719 definition
= Fpurecopy (definition
);
722 bool autoload
= AUTOLOADP (definition
);
723 if (NILP (Vpurify_flag
) || !autoload
)
724 { /* Only add autoload entries after dumping, because the ones before are
725 not useful and else we get loads of them from the loaddefs.el. */
727 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
728 /* Remember that the function was already an autoload. */
729 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
730 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
734 { /* Handle automatic advice activation. */
735 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
737 call2 (hook
, symbol
, definition
);
739 Ffset (symbol
, definition
);
742 if (!NILP (docstring
))
743 Fput (symbol
, Qfunction_documentation
, docstring
);
744 /* We used to return `definition', but now that `defun' and `defmacro' expand
745 to a call to `defalias', we return `symbol' for backward compatibility
750 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
751 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
752 (register Lisp_Object symbol
, Lisp_Object newplist
)
754 CHECK_SYMBOL (symbol
);
755 set_symbol_plist (symbol
, newplist
);
759 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
760 doc
: /* Return minimum and maximum number of args allowed for SUBR.
761 SUBR must be a built-in function.
762 The returned value is a pair (MIN . MAX). MIN is the minimum number
763 of args. MAX is the maximum number or the symbol `many', for a
764 function with `&rest' args, or `unevalled' for a special form. */)
767 short minargs
, maxargs
;
769 minargs
= XSUBR (subr
)->min_args
;
770 maxargs
= XSUBR (subr
)->max_args
;
771 return Fcons (make_number (minargs
),
772 maxargs
== MANY
? Qmany
773 : maxargs
== UNEVALLED
? Qunevalled
774 : make_number (maxargs
));
777 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
778 doc
: /* Return name of subroutine SUBR.
779 SUBR must be a built-in function. */)
784 name
= XSUBR (subr
)->symbol_name
;
785 return build_string (name
);
788 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
789 doc
: /* Return the interactive form of CMD or nil if none.
790 If CMD is not a command, the return value is nil.
791 Value, if non-nil, is a list \(interactive SPEC). */)
794 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
799 /* Use an `interactive-form' property if present, analogous to the
800 function-documentation property. */
802 while (SYMBOLP (fun
))
804 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
808 fun
= Fsymbol_function (fun
);
813 const char *spec
= XSUBR (fun
)->intspec
;
815 return list2 (Qinteractive
,
816 (*spec
!= '(') ? build_string (spec
) :
817 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
819 else if (COMPILEDP (fun
))
821 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
822 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
824 else if (AUTOLOADP (fun
))
825 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
826 else if (CONSP (fun
))
828 Lisp_Object funcar
= XCAR (fun
);
829 if (EQ (funcar
, Qclosure
))
830 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
831 else if (EQ (funcar
, Qlambda
))
832 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
838 /***********************************************************************
839 Getting and Setting Values of Symbols
840 ***********************************************************************/
842 /* Return the symbol holding SYMBOL's value. Signal
843 `cyclic-variable-indirection' if SYMBOL's chain of variable
844 indirections contains a loop. */
847 indirect_variable (struct Lisp_Symbol
*symbol
)
849 struct Lisp_Symbol
*tortoise
, *hare
;
851 hare
= tortoise
= symbol
;
853 while (hare
->redirect
== SYMBOL_VARALIAS
)
855 hare
= SYMBOL_ALIAS (hare
);
856 if (hare
->redirect
!= SYMBOL_VARALIAS
)
859 hare
= SYMBOL_ALIAS (hare
);
860 tortoise
= SYMBOL_ALIAS (tortoise
);
862 if (hare
== tortoise
)
865 XSETSYMBOL (tem
, symbol
);
866 xsignal1 (Qcyclic_variable_indirection
, tem
);
874 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
875 doc
: /* Return the variable at the end of OBJECT's variable chain.
876 If OBJECT is a symbol, follow its variable indirections (if any), and
877 return the variable at the end of the chain of aliases. See Info node
878 `(elisp)Variable Aliases'.
880 If OBJECT is not a symbol, just return it. If there is a loop in the
881 chain of aliases, signal a `cyclic-variable-indirection' error. */)
884 if (SYMBOLP (object
))
886 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
887 XSETSYMBOL (object
, sym
);
893 /* Given the raw contents of a symbol value cell,
894 return the Lisp value of the symbol.
895 This does not handle buffer-local variables; use
896 swap_in_symval_forwarding for that. */
899 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
901 register Lisp_Object val
;
902 switch (XFWDTYPE (valcontents
))
905 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
909 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
912 return *XOBJFWD (valcontents
)->objvar
;
914 case Lisp_Fwd_Buffer_Obj
:
915 return per_buffer_value (current_buffer
,
916 XBUFFER_OBJFWD (valcontents
)->offset
);
918 case Lisp_Fwd_Kboard_Obj
:
919 /* We used to simply use current_kboard here, but from Lisp
920 code, its value is often unexpected. It seems nicer to
921 allow constructions like this to work as intuitively expected:
923 (with-selected-frame frame
924 (define-key local-function-map "\eOP" [f1]))
926 On the other hand, this affects the semantics of
927 last-command and real-last-command, and people may rely on
928 that. I took a quick look at the Lisp codebase, and I
929 don't think anything will break. --lorentey */
930 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
931 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
932 default: emacs_abort ();
936 /* Used to signal a user-friendly error when symbol WRONG is
937 not a member of CHOICE, which should be a list of symbols. */
940 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
942 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
943 Lisp_Object obj
, *args
;
944 AUTO_STRING (one_of
, "One of ");
945 AUTO_STRING (comma
, ", ");
946 AUTO_STRING (or, " or ");
947 AUTO_STRING (should_be_specified
, " should be specified");
950 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
954 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
956 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
957 args
[i
++] = (NILP (XCDR (obj
)) ? should_be_specified
958 : NILP (XCDR (XCDR (obj
))) ? or : comma
);
961 obj
= Fconcat (i
, args
);
963 xsignal2 (Qerror
, obj
, wrong
);
966 /* Used to signal a user-friendly error if WRONG is not a number or
967 integer/floating-point number outsize of inclusive MIN..MAX range. */
970 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
972 AUTO_STRING (value_should_be_from
, "Value should be from ");
973 AUTO_STRING (to
, " to ");
975 CALLN (Fconcat
, value_should_be_from
, Fnumber_to_string (min
),
976 to
, Fnumber_to_string (max
)),
980 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
981 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
982 buffer-independent contents of the value cell: forwarded just one
983 step past the buffer-localness.
985 BUF non-zero means set the value in buffer BUF instead of the
986 current buffer. This only plays a role for per-buffer variables. */
989 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
991 switch (XFWDTYPE (valcontents
))
994 CHECK_NUMBER (newval
);
995 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
999 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1003 *XOBJFWD (valcontents
)->objvar
= newval
;
1005 /* If this variable is a default for something stored
1006 in the buffer itself, such as default-fill-column,
1007 find the buffers that don't have local values for it
1009 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1010 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1012 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1013 - (char *) &buffer_defaults
);
1014 int idx
= PER_BUFFER_IDX (offset
);
1016 Lisp_Object tail
, buf
;
1021 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1023 struct buffer
*b
= XBUFFER (buf
);
1025 if (! PER_BUFFER_VALUE_P (b
, idx
))
1026 set_per_buffer_value (b
, offset
, newval
);
1031 case Lisp_Fwd_Buffer_Obj
:
1033 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1034 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1038 if (SYMBOLP (predicate
))
1042 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1044 if (NILP (Fmemq (newval
, prop
)))
1045 wrong_choice (prop
, newval
);
1047 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1049 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1051 if (!NUMBERP (newval
)
1052 || !NILP (arithcompare (newval
, min
, ARITH_LESS
))
1053 || !NILP (arithcompare (newval
, max
, ARITH_GRTR
)))
1054 wrong_range (min
, max
, newval
);
1056 else if (FUNCTIONP (predicate
))
1058 if (NILP (call1 (predicate
, newval
)))
1059 wrong_type_argument (predicate
, newval
);
1064 buf
= current_buffer
;
1065 set_per_buffer_value (buf
, offset
, newval
);
1069 case Lisp_Fwd_Kboard_Obj
:
1071 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1072 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1073 *(Lisp_Object
*) p
= newval
;
1078 emacs_abort (); /* goto def; */
1082 /* Set up SYMBOL to refer to its global binding. This makes it safe
1083 to alter the status of other bindings. BEWARE: this may be called
1084 during the mark phase of GC, where we assume that Lisp_Object slots
1085 of BLV are marked after this function has changed them. */
1088 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1090 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1092 /* Unload the previously loaded binding. */
1094 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1096 /* Select the global binding in the symbol. */
1097 set_blv_valcell (blv
, blv
->defcell
);
1099 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1101 /* Indicate that the global binding is set up now. */
1102 set_blv_where (blv
, Qnil
);
1103 set_blv_found (blv
, 0);
1106 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1107 VALCONTENTS is the contents of its value cell,
1108 which points to a struct Lisp_Buffer_Local_Value.
1110 Return the value forwarded one step past the buffer-local stage.
1111 This could be another forwarding pointer. */
1114 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1116 register Lisp_Object tem1
;
1118 eassert (blv
== SYMBOL_BLV (symbol
));
1123 || (blv
->frame_local
1124 ? !EQ (selected_frame
, tem1
)
1125 : current_buffer
!= XBUFFER (tem1
)))
1128 /* Unload the previously loaded binding. */
1129 tem1
= blv
->valcell
;
1131 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1132 /* Choose the new binding. */
1135 XSETSYMBOL (var
, symbol
);
1136 if (blv
->frame_local
)
1138 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1139 set_blv_where (blv
, selected_frame
);
1143 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1144 set_blv_where (blv
, Fcurrent_buffer ());
1147 if (!(blv
->found
= !NILP (tem1
)))
1148 tem1
= blv
->defcell
;
1150 /* Load the new binding. */
1151 set_blv_valcell (blv
, tem1
);
1153 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1157 /* Find the value of a symbol, returning Qunbound if it's not bound.
1158 This is helpful for code which just wants to get a variable's value
1159 if it has one, without signaling an error.
1160 Note that it must not be possible to quit
1161 within this function. Great care is required for this. */
1164 find_symbol_value (Lisp_Object symbol
)
1166 struct Lisp_Symbol
*sym
;
1168 CHECK_SYMBOL (symbol
);
1169 sym
= XSYMBOL (symbol
);
1172 switch (sym
->redirect
)
1174 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1175 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1176 case SYMBOL_LOCALIZED
:
1178 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1179 swap_in_symval_forwarding (sym
, blv
);
1180 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1183 case SYMBOL_FORWARDED
:
1184 return do_symval_forwarding (SYMBOL_FWD (sym
));
1185 default: emacs_abort ();
1189 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1190 doc
: /* Return SYMBOL's value. Error if that is void.
1191 Note that if `lexical-binding' is in effect, this returns the
1192 global value outside of any lexical scope. */)
1193 (Lisp_Object symbol
)
1197 val
= find_symbol_value (symbol
);
1198 if (!EQ (val
, Qunbound
))
1201 xsignal1 (Qvoid_variable
, symbol
);
1204 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1205 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1206 (register Lisp_Object symbol
, Lisp_Object newval
)
1208 set_internal (symbol
, newval
, Qnil
, 0);
1212 /* Store the value NEWVAL into SYMBOL.
1213 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1214 (nil stands for the current buffer/frame).
1216 If BINDFLAG is false, then if this symbol is supposed to become
1217 local in every buffer where it is set, then we make it local.
1218 If BINDFLAG is true, we don't do that. */
1221 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1224 bool voide
= EQ (newval
, Qunbound
);
1225 struct Lisp_Symbol
*sym
;
1228 /* If restoring in a dead buffer, do nothing. */
1229 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1232 CHECK_SYMBOL (symbol
);
1233 if (SYMBOL_CONSTANT_P (symbol
))
1235 if (NILP (Fkeywordp (symbol
))
1236 || !EQ (newval
, Fsymbol_value (symbol
)))
1237 xsignal1 (Qsetting_constant
, symbol
);
1239 /* Allow setting keywords to their own value. */
1243 sym
= XSYMBOL (symbol
);
1246 switch (sym
->redirect
)
1248 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1249 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1250 case SYMBOL_LOCALIZED
:
1252 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1255 if (blv
->frame_local
)
1256 where
= selected_frame
;
1258 XSETBUFFER (where
, current_buffer
);
1260 /* If the current buffer is not the buffer whose binding is
1261 loaded, or if there may be frame-local bindings and the frame
1262 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1263 the default binding is loaded, the loaded binding may be the
1265 if (!EQ (blv
->where
, where
)
1266 /* Also unload a global binding (if the var is local_if_set). */
1267 || (EQ (blv
->valcell
, blv
->defcell
)))
1269 /* The currently loaded binding is not necessarily valid.
1270 We need to unload it, and choose a new binding. */
1272 /* Write out `realvalue' to the old loaded binding. */
1274 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1276 /* Find the new binding. */
1277 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1278 tem1
= assq_no_quit (symbol
,
1280 ? XFRAME (where
)->param_alist
1281 : BVAR (XBUFFER (where
), local_var_alist
)));
1282 set_blv_where (blv
, where
);
1287 /* This buffer still sees the default value. */
1289 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1290 or if this is `let' rather than `set',
1291 make CURRENT-ALIST-ELEMENT point to itself,
1292 indicating that we're seeing the default value.
1293 Likewise if the variable has been let-bound
1294 in the current buffer. */
1295 if (bindflag
|| !blv
->local_if_set
1296 || let_shadows_buffer_binding_p (sym
))
1299 tem1
= blv
->defcell
;
1301 /* If it's a local_if_set, being set not bound,
1302 and we're not within a let that was made for this buffer,
1303 create a new buffer-local binding for the variable.
1304 That means, give this buffer a new assoc for a local value
1305 and load that binding. */
1308 /* local_if_set is only supported for buffer-local
1309 bindings, not for frame-local bindings. */
1310 eassert (!blv
->frame_local
);
1311 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1312 bset_local_var_alist
1314 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1318 /* Record which binding is now loaded. */
1319 set_blv_valcell (blv
, tem1
);
1322 /* Store the new value in the cons cell. */
1323 set_blv_value (blv
, newval
);
1328 /* If storing void (making the symbol void), forward only through
1329 buffer-local indicator, not through Lisp_Objfwd, etc. */
1332 store_symval_forwarding (blv
->fwd
, newval
,
1334 ? XBUFFER (where
) : current_buffer
);
1338 case SYMBOL_FORWARDED
:
1341 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1342 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1343 if (BUFFER_OBJFWDP (innercontents
))
1345 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1346 int idx
= PER_BUFFER_IDX (offset
);
1349 && !let_shadows_buffer_binding_p (sym
))
1350 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1354 { /* If storing void (making the symbol void), forward only through
1355 buffer-local indicator, not through Lisp_Objfwd, etc. */
1356 sym
->redirect
= SYMBOL_PLAINVAL
;
1357 SET_SYMBOL_VAL (sym
, newval
);
1360 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1363 default: emacs_abort ();
1368 /* Access or set a buffer-local symbol's default value. */
1370 /* Return the default value of SYMBOL, but don't check for voidness.
1371 Return Qunbound if it is void. */
1374 default_value (Lisp_Object symbol
)
1376 struct Lisp_Symbol
*sym
;
1378 CHECK_SYMBOL (symbol
);
1379 sym
= XSYMBOL (symbol
);
1382 switch (sym
->redirect
)
1384 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1385 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1386 case SYMBOL_LOCALIZED
:
1388 /* If var is set up for a buffer that lacks a local value for it,
1389 the current value is nominally the default value.
1390 But the `realvalue' slot may be more up to date, since
1391 ordinary setq stores just that slot. So use that. */
1392 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1393 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1394 return do_symval_forwarding (blv
->fwd
);
1396 return XCDR (blv
->defcell
);
1398 case SYMBOL_FORWARDED
:
1400 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1402 /* For a built-in buffer-local variable, get the default value
1403 rather than letting do_symval_forwarding get the current value. */
1404 if (BUFFER_OBJFWDP (valcontents
))
1406 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1407 if (PER_BUFFER_IDX (offset
) != 0)
1408 return per_buffer_default (offset
);
1411 /* For other variables, get the current value. */
1412 return do_symval_forwarding (valcontents
);
1414 default: emacs_abort ();
1418 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1419 doc
: /* Return t if SYMBOL has a non-void default value.
1420 This is the value that is seen in buffers that do not have their own values
1421 for this variable. */)
1422 (Lisp_Object symbol
)
1424 register Lisp_Object value
;
1426 value
= default_value (symbol
);
1427 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1430 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1431 doc
: /* Return SYMBOL's default value.
1432 This is the value that is seen in buffers that do not have their own values
1433 for this variable. The default value is meaningful for variables with
1434 local bindings in certain buffers. */)
1435 (Lisp_Object symbol
)
1437 Lisp_Object value
= default_value (symbol
);
1438 if (!EQ (value
, Qunbound
))
1441 xsignal1 (Qvoid_variable
, symbol
);
1444 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1445 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1446 The default value is seen in buffers that do not have their own values
1447 for this variable. */)
1448 (Lisp_Object symbol
, Lisp_Object value
)
1450 struct Lisp_Symbol
*sym
;
1452 CHECK_SYMBOL (symbol
);
1453 if (SYMBOL_CONSTANT_P (symbol
))
1455 if (NILP (Fkeywordp (symbol
))
1456 || !EQ (value
, Fdefault_value (symbol
)))
1457 xsignal1 (Qsetting_constant
, symbol
);
1459 /* Allow setting keywords to their own value. */
1462 sym
= XSYMBOL (symbol
);
1465 switch (sym
->redirect
)
1467 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1468 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1469 case SYMBOL_LOCALIZED
:
1471 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1473 /* Store new value into the DEFAULT-VALUE slot. */
1474 XSETCDR (blv
->defcell
, value
);
1476 /* If the default binding is now loaded, set the REALVALUE slot too. */
1477 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1478 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1481 case SYMBOL_FORWARDED
:
1483 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1485 /* Handle variables like case-fold-search that have special slots
1487 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1488 if (BUFFER_OBJFWDP (valcontents
))
1490 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1491 int idx
= PER_BUFFER_IDX (offset
);
1493 set_per_buffer_default (offset
, value
);
1495 /* If this variable is not always local in all buffers,
1496 set it in the buffers that don't nominally have a local value. */
1502 if (!PER_BUFFER_VALUE_P (b
, idx
))
1503 set_per_buffer_value (b
, offset
, value
);
1508 return Fset (symbol
, value
);
1510 default: emacs_abort ();
1514 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1515 doc
: /* Set the default value of variable VAR to VALUE.
1516 VAR, the variable name, is literal (not evaluated);
1517 VALUE is an expression: it is evaluated and its value returned.
1518 The default value of a variable is seen in buffers
1519 that do not have their own values for the variable.
1521 More generally, you can use multiple variables and values, as in
1522 (setq-default VAR VALUE VAR VALUE...)
1523 This sets each VAR's default value to the corresponding VALUE.
1524 The VALUE for the Nth VAR can refer to the new default values
1526 usage: (setq-default [VAR VALUE]...) */)
1529 Lisp_Object args_left
, symbol
, val
;
1530 struct gcpro gcpro1
;
1532 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
));
1547 /* Lisp functions for creating and removing buffer-local variables. */
1552 union Lisp_Fwd
*fwd
;
1555 static struct Lisp_Buffer_Local_Value
*
1556 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1557 union Lisp_Val_Fwd valcontents
)
1559 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1563 XSETSYMBOL (symbol
, sym
);
1564 tem
= Fcons (symbol
, (forwarded
1565 ? do_symval_forwarding (valcontents
.fwd
)
1566 : valcontents
.value
));
1568 /* Buffer_Local_Values cannot have as realval a buffer-local
1569 or keyboard-local forwarding. */
1570 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1571 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1572 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1573 set_blv_where (blv
, Qnil
);
1574 blv
->frame_local
= 0;
1575 blv
->local_if_set
= 0;
1576 set_blv_defcell (blv
, tem
);
1577 set_blv_valcell (blv
, tem
);
1578 set_blv_found (blv
, 0);
1582 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1583 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1584 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1585 At any time, the value for the current buffer is in effect,
1586 unless the variable has never been set in this buffer,
1587 in which case the default value is in effect.
1588 Note that binding the variable with `let', or setting it while
1589 a `let'-style binding made in this buffer is in effect,
1590 does not make the variable buffer-local. Return VARIABLE.
1592 This globally affects all uses of this variable, so it belongs together with
1593 the variable declaration, rather than with its uses (if you just want to make
1594 a variable local to the current buffer for one particular use, use
1595 `make-local-variable'). Buffer-local bindings are normally cleared
1596 while setting up a new major mode, unless they have a `permanent-local'
1599 The function `default-value' gets the default value and `set-default' sets it. */)
1600 (register Lisp_Object variable
)
1602 struct Lisp_Symbol
*sym
;
1603 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1604 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1605 bool forwarded
IF_LINT (= 0);
1607 CHECK_SYMBOL (variable
);
1608 sym
= XSYMBOL (variable
);
1611 switch (sym
->redirect
)
1613 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1614 case SYMBOL_PLAINVAL
:
1615 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1616 if (EQ (valcontents
.value
, Qunbound
))
1617 valcontents
.value
= Qnil
;
1619 case SYMBOL_LOCALIZED
:
1620 blv
= SYMBOL_BLV (sym
);
1621 if (blv
->frame_local
)
1622 error ("Symbol %s may not be buffer-local",
1623 SDATA (SYMBOL_NAME (variable
)));
1625 case SYMBOL_FORWARDED
:
1626 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1627 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1628 error ("Symbol %s may not be buffer-local",
1629 SDATA (SYMBOL_NAME (variable
)));
1630 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1633 default: emacs_abort ();
1637 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1641 blv
= make_blv (sym
, forwarded
, valcontents
);
1642 sym
->redirect
= SYMBOL_LOCALIZED
;
1643 SET_SYMBOL_BLV (sym
, blv
);
1646 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1647 if (let_shadows_global_binding_p (symbol
))
1648 message ("Making %s buffer-local while let-bound!",
1649 SDATA (SYMBOL_NAME (variable
)));
1653 blv
->local_if_set
= 1;
1657 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1658 1, 1, "vMake Local Variable: ",
1659 doc
: /* Make VARIABLE have a separate value in the current buffer.
1660 Other buffers will continue to share a common default value.
1661 \(The buffer-local value of VARIABLE starts out as the same value
1662 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1665 If the variable is already arranged to become local when set,
1666 this function causes a local value to exist for this buffer,
1667 just as setting the variable would do.
1669 This function returns VARIABLE, and therefore
1670 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1673 See also `make-variable-buffer-local'.
1675 Do not use `make-local-variable' to make a hook variable buffer-local.
1676 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1677 (Lisp_Object variable
)
1680 bool forwarded
IF_LINT (= 0);
1681 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1682 struct Lisp_Symbol
*sym
;
1683 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1685 CHECK_SYMBOL (variable
);
1686 sym
= XSYMBOL (variable
);
1689 switch (sym
->redirect
)
1691 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1692 case SYMBOL_PLAINVAL
:
1693 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1694 case SYMBOL_LOCALIZED
:
1695 blv
= SYMBOL_BLV (sym
);
1696 if (blv
->frame_local
)
1697 error ("Symbol %s may not be buffer-local",
1698 SDATA (SYMBOL_NAME (variable
)));
1700 case SYMBOL_FORWARDED
:
1701 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1702 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1703 error ("Symbol %s may not be buffer-local",
1704 SDATA (SYMBOL_NAME (variable
)));
1706 default: emacs_abort ();
1710 error ("Symbol %s may not be buffer-local",
1711 SDATA (SYMBOL_NAME (variable
)));
1713 if (blv
? blv
->local_if_set
1714 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1716 tem
= Fboundp (variable
);
1717 /* Make sure the symbol has a local value in this particular buffer,
1718 by setting it to the same value it already has. */
1719 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1724 blv
= make_blv (sym
, forwarded
, valcontents
);
1725 sym
->redirect
= SYMBOL_LOCALIZED
;
1726 SET_SYMBOL_BLV (sym
, blv
);
1729 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1730 if (let_shadows_global_binding_p (symbol
))
1731 message ("Making %s local to %s while let-bound!",
1732 SDATA (SYMBOL_NAME (variable
)),
1733 SDATA (BVAR (current_buffer
, name
)));
1737 /* Make sure this buffer has its own value of symbol. */
1738 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1739 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1742 if (let_shadows_buffer_binding_p (sym
))
1743 message ("Making %s buffer-local while locally let-bound!",
1744 SDATA (SYMBOL_NAME (variable
)));
1746 /* Swap out any local binding for some other buffer, and make
1747 sure the current value is permanently recorded, if it's the
1749 find_symbol_value (variable
);
1751 bset_local_var_alist
1753 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1754 BVAR (current_buffer
, local_var_alist
)));
1756 /* Make sure symbol does not think it is set up for this buffer;
1757 force it to look once again for this buffer's value. */
1758 if (current_buffer
== XBUFFER (blv
->where
))
1759 set_blv_where (blv
, Qnil
);
1760 set_blv_found (blv
, 0);
1763 /* If the symbol forwards into a C variable, then load the binding
1764 for this buffer now. If C code modifies the variable before we
1765 load the binding in, then that new value will clobber the default
1766 binding the next time we unload it. */
1768 swap_in_symval_forwarding (sym
, blv
);
1773 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1774 1, 1, "vKill Local Variable: ",
1775 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1776 From now on the default value will apply in this buffer. Return VARIABLE. */)
1777 (register Lisp_Object variable
)
1779 register Lisp_Object tem
;
1780 struct Lisp_Buffer_Local_Value
*blv
;
1781 struct Lisp_Symbol
*sym
;
1783 CHECK_SYMBOL (variable
);
1784 sym
= XSYMBOL (variable
);
1787 switch (sym
->redirect
)
1789 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1790 case SYMBOL_PLAINVAL
: return variable
;
1791 case SYMBOL_FORWARDED
:
1793 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1794 if (BUFFER_OBJFWDP (valcontents
))
1796 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1797 int idx
= PER_BUFFER_IDX (offset
);
1801 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1802 set_per_buffer_value (current_buffer
, offset
,
1803 per_buffer_default (offset
));
1808 case SYMBOL_LOCALIZED
:
1809 blv
= SYMBOL_BLV (sym
);
1810 if (blv
->frame_local
)
1813 default: emacs_abort ();
1816 /* Get rid of this buffer's alist element, if any. */
1817 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1818 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1820 bset_local_var_alist
1822 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1824 /* If the symbol is set up with the current buffer's binding
1825 loaded, recompute its value. We have to do it now, or else
1826 forwarded objects won't work right. */
1828 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1829 if (EQ (buf
, blv
->where
))
1831 set_blv_where (blv
, Qnil
);
1833 find_symbol_value (variable
);
1840 /* Lisp functions for creating and removing buffer-local variables. */
1842 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1843 when/if this is removed. */
1845 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1846 1, 1, "vMake Variable Frame Local: ",
1847 doc
: /* Enable VARIABLE to have frame-local bindings.
1848 This does not create any frame-local bindings for VARIABLE,
1849 it just makes them possible.
1851 A frame-local binding is actually a frame parameter value.
1852 If a frame F has a value for the frame parameter named VARIABLE,
1853 that also acts as a frame-local binding for VARIABLE in F--
1854 provided this function has been called to enable VARIABLE
1855 to have frame-local bindings at all.
1857 The only way to create a frame-local binding for VARIABLE in a frame
1858 is to set the VARIABLE frame parameter of that frame. See
1859 `modify-frame-parameters' for how to set frame parameters.
1861 Note that since Emacs 23.1, variables cannot be both buffer-local and
1862 frame-local any more (buffer-local bindings used to take precedence over
1863 frame-local bindings). */)
1864 (Lisp_Object variable
)
1867 union Lisp_Val_Fwd valcontents
;
1868 struct Lisp_Symbol
*sym
;
1869 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1871 CHECK_SYMBOL (variable
);
1872 sym
= XSYMBOL (variable
);
1875 switch (sym
->redirect
)
1877 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1878 case SYMBOL_PLAINVAL
:
1879 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1880 if (EQ (valcontents
.value
, Qunbound
))
1881 valcontents
.value
= Qnil
;
1883 case SYMBOL_LOCALIZED
:
1884 if (SYMBOL_BLV (sym
)->frame_local
)
1887 error ("Symbol %s may not be frame-local",
1888 SDATA (SYMBOL_NAME (variable
)));
1889 case SYMBOL_FORWARDED
:
1890 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1891 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1892 error ("Symbol %s may not be frame-local",
1893 SDATA (SYMBOL_NAME (variable
)));
1895 default: emacs_abort ();
1899 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1901 blv
= make_blv (sym
, forwarded
, valcontents
);
1902 blv
->frame_local
= 1;
1903 sym
->redirect
= SYMBOL_LOCALIZED
;
1904 SET_SYMBOL_BLV (sym
, blv
);
1907 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1908 if (let_shadows_global_binding_p (symbol
))
1909 message ("Making %s frame-local while let-bound!",
1910 SDATA (SYMBOL_NAME (variable
)));
1915 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1917 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1918 BUFFER defaults to the current buffer. */)
1919 (Lisp_Object variable
, Lisp_Object buffer
)
1921 struct buffer
*buf
= decode_buffer (buffer
);
1922 struct Lisp_Symbol
*sym
;
1924 CHECK_SYMBOL (variable
);
1925 sym
= XSYMBOL (variable
);
1928 switch (sym
->redirect
)
1930 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1931 case SYMBOL_PLAINVAL
: return Qnil
;
1932 case SYMBOL_LOCALIZED
:
1934 Lisp_Object tail
, elt
, tmp
;
1935 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1936 XSETBUFFER (tmp
, buf
);
1937 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1939 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1940 return blv_found (blv
) ? Qt
: Qnil
;
1942 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1945 if (EQ (variable
, XCAR (elt
)))
1947 eassert (!blv
->frame_local
);
1953 case SYMBOL_FORWARDED
:
1955 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1956 if (BUFFER_OBJFWDP (valcontents
))
1958 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1959 int idx
= PER_BUFFER_IDX (offset
);
1960 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1965 default: emacs_abort ();
1969 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1971 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1972 BUFFER defaults to the current buffer.
1974 More precisely, return non-nil if either VARIABLE already has a local
1975 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1976 `make-variable-buffer-local'). */)
1977 (register Lisp_Object variable
, Lisp_Object buffer
)
1979 struct Lisp_Symbol
*sym
;
1981 CHECK_SYMBOL (variable
);
1982 sym
= XSYMBOL (variable
);
1985 switch (sym
->redirect
)
1987 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1988 case SYMBOL_PLAINVAL
: return Qnil
;
1989 case SYMBOL_LOCALIZED
:
1991 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1992 if (blv
->local_if_set
)
1994 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1995 return Flocal_variable_p (variable
, buffer
);
1997 case SYMBOL_FORWARDED
:
1998 /* All BUFFER_OBJFWD slots become local if they are set. */
1999 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2000 default: emacs_abort ();
2004 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2006 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2007 If the current binding is buffer-local, the value is the current buffer.
2008 If the current binding is frame-local, the value is the selected frame.
2009 If the current binding is global (the default), the value is nil. */)
2010 (register Lisp_Object variable
)
2012 struct Lisp_Symbol
*sym
;
2014 CHECK_SYMBOL (variable
);
2015 sym
= XSYMBOL (variable
);
2017 /* Make sure the current binding is actually swapped in. */
2018 find_symbol_value (variable
);
2021 switch (sym
->redirect
)
2023 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2024 case SYMBOL_PLAINVAL
: return Qnil
;
2025 case SYMBOL_FORWARDED
:
2027 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2028 if (KBOARD_OBJFWDP (valcontents
))
2029 return Fframe_terminal (selected_frame
);
2030 else if (!BUFFER_OBJFWDP (valcontents
))
2034 case SYMBOL_LOCALIZED
:
2035 /* For a local variable, record both the symbol and which
2036 buffer's or frame's value we are saving. */
2037 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2038 return Fcurrent_buffer ();
2039 else if (sym
->redirect
== SYMBOL_LOCALIZED
2040 && blv_found (SYMBOL_BLV (sym
)))
2041 return SYMBOL_BLV (sym
)->where
;
2044 default: emacs_abort ();
2048 /* This code is disabled now that we use the selected frame to return
2049 keyboard-local-values. */
2051 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2053 DEFUN ("terminal-local-value", Fterminal_local_value
,
2054 Sterminal_local_value
, 2, 2, 0,
2055 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2056 If SYMBOL is not a terminal-local variable, then return its normal
2057 value, like `symbol-value'.
2059 TERMINAL may be a terminal object, a frame, or nil (meaning the
2060 selected frame's terminal device). */)
2061 (Lisp_Object symbol
, Lisp_Object terminal
)
2064 struct terminal
*t
= get_terminal (terminal
, 1);
2065 push_kboard (t
->kboard
);
2066 result
= Fsymbol_value (symbol
);
2071 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2072 Sset_terminal_local_value
, 3, 3, 0,
2073 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2074 If VARIABLE is not a terminal-local variable, then set its normal
2075 binding, like `set'.
2077 TERMINAL may be a terminal object, a frame, or nil (meaning the
2078 selected frame's terminal device). */)
2079 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2082 struct terminal
*t
= get_terminal (terminal
, 1);
2083 push_kboard (d
->kboard
);
2084 result
= Fset (symbol
, value
);
2090 /* Find the function at the end of a chain of symbol function indirections. */
2092 /* If OBJECT is a symbol, find the end of its function chain and
2093 return the value found there. If OBJECT is not a symbol, just
2094 return it. If there is a cycle in the function chain, signal a
2095 cyclic-function-indirection error.
2097 This is like Findirect_function, except that it doesn't signal an
2098 error if the chain ends up unbound. */
2100 indirect_function (register Lisp_Object object
)
2102 Lisp_Object tortoise
, hare
;
2104 hare
= tortoise
= object
;
2108 if (!SYMBOLP (hare
) || NILP (hare
))
2110 hare
= XSYMBOL (hare
)->function
;
2111 if (!SYMBOLP (hare
) || NILP (hare
))
2113 hare
= XSYMBOL (hare
)->function
;
2115 tortoise
= XSYMBOL (tortoise
)->function
;
2117 if (EQ (hare
, tortoise
))
2118 xsignal1 (Qcyclic_function_indirection
, object
);
2124 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2125 doc
: /* Return the function at the end of OBJECT's function chain.
2126 If OBJECT is not a symbol, just return it. Otherwise, follow all
2127 function indirections to find the final function binding and return it.
2128 Signal a cyclic-function-indirection error if there is a loop in the
2129 function chain of symbols. */)
2130 (register Lisp_Object object
, Lisp_Object noerror
)
2134 /* Optimize for no indirection. */
2136 if (SYMBOLP (result
) && !NILP (result
)
2137 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2138 result
= indirect_function (result
);
2145 /* Extract and set vector and string elements. */
2147 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2148 doc
: /* Return the element of ARRAY at index IDX.
2149 ARRAY may be a vector, a string, a char-table, a bool-vector,
2150 or a byte-code object. IDX starts at 0. */)
2151 (register Lisp_Object array
, Lisp_Object idx
)
2153 register EMACS_INT idxval
;
2156 idxval
= XINT (idx
);
2157 if (STRINGP (array
))
2160 ptrdiff_t idxval_byte
;
2162 if (idxval
< 0 || idxval
>= SCHARS (array
))
2163 args_out_of_range (array
, idx
);
2164 if (! STRING_MULTIBYTE (array
))
2165 return make_number ((unsigned char) SREF (array
, idxval
));
2166 idxval_byte
= string_char_to_byte (array
, idxval
);
2168 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2169 return make_number (c
);
2171 else if (BOOL_VECTOR_P (array
))
2173 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2174 args_out_of_range (array
, idx
);
2175 return bool_vector_ref (array
, idxval
);
2177 else if (CHAR_TABLE_P (array
))
2179 CHECK_CHARACTER (idx
);
2180 return CHAR_TABLE_REF (array
, idxval
);
2185 if (VECTORP (array
))
2186 size
= ASIZE (array
);
2187 else if (COMPILEDP (array
))
2188 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2190 wrong_type_argument (Qarrayp
, array
);
2192 if (idxval
< 0 || idxval
>= size
)
2193 args_out_of_range (array
, idx
);
2194 return AREF (array
, idxval
);
2198 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2199 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2200 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2201 bool-vector. IDX starts at 0. */)
2202 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2204 register EMACS_INT idxval
;
2207 idxval
= XINT (idx
);
2208 CHECK_ARRAY (array
, Qarrayp
);
2209 CHECK_IMPURE (array
);
2211 if (VECTORP (array
))
2213 if (idxval
< 0 || idxval
>= ASIZE (array
))
2214 args_out_of_range (array
, idx
);
2215 ASET (array
, idxval
, newelt
);
2217 else if (BOOL_VECTOR_P (array
))
2219 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2220 args_out_of_range (array
, idx
);
2221 bool_vector_set (array
, idxval
, !NILP (newelt
));
2223 else if (CHAR_TABLE_P (array
))
2225 CHECK_CHARACTER (idx
);
2226 CHAR_TABLE_SET (array
, idxval
, newelt
);
2232 if (idxval
< 0 || idxval
>= SCHARS (array
))
2233 args_out_of_range (array
, idx
);
2234 CHECK_CHARACTER (newelt
);
2235 c
= XFASTINT (newelt
);
2237 if (STRING_MULTIBYTE (array
))
2239 ptrdiff_t idxval_byte
, nbytes
;
2240 int prev_bytes
, new_bytes
;
2241 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2243 nbytes
= SBYTES (array
);
2244 idxval_byte
= string_char_to_byte (array
, idxval
);
2245 p1
= SDATA (array
) + idxval_byte
;
2246 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2247 new_bytes
= CHAR_STRING (c
, p0
);
2248 if (prev_bytes
!= new_bytes
)
2250 /* We must relocate the string data. */
2251 ptrdiff_t nchars
= SCHARS (array
);
2253 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2255 memcpy (str
, SDATA (array
), nbytes
);
2256 allocate_string_data (XSTRING (array
), nchars
,
2257 nbytes
+ new_bytes
- prev_bytes
);
2258 memcpy (SDATA (array
), str
, idxval_byte
);
2259 p1
= SDATA (array
) + idxval_byte
;
2260 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2261 nbytes
- (idxval_byte
+ prev_bytes
));
2263 clear_string_char_byte_cache ();
2270 if (! SINGLE_BYTE_CHAR_P (c
))
2274 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2275 if (SREF (array
, i
) >= 0x80)
2276 args_out_of_range (array
, newelt
);
2277 /* ARRAY is an ASCII string. Convert it to a multibyte
2278 string, and try `aset' again. */
2279 STRING_SET_MULTIBYTE (array
);
2280 return Faset (array
, idx
, newelt
);
2282 SSET (array
, idxval
, c
);
2289 /* Arithmetic functions */
2292 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2294 double f1
= 0, f2
= 0;
2297 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2298 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2300 if (FLOATP (num1
) || FLOATP (num2
))
2303 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2304 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2310 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2314 case ARITH_NOTEQUAL
:
2315 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2320 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2324 case ARITH_LESS_OR_EQUAL
:
2325 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2330 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2334 case ARITH_GRTR_OR_EQUAL
:
2335 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2345 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2346 enum Arith_Comparison comparison
)
2349 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2351 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2357 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2358 doc
: /* Return t if args, all numbers or markers, are equal.
2359 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2360 (ptrdiff_t nargs
, Lisp_Object
*args
)
2362 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2365 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2366 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2367 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2368 (ptrdiff_t nargs
, Lisp_Object
*args
)
2370 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2373 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2374 doc
: /* Return t if each arg (a number or marker) is greater 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_GRTR
);
2381 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2382 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2383 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2384 (ptrdiff_t nargs
, Lisp_Object
*args
)
2386 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2389 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2390 doc
: /* Return t if each arg (a number or marker) is greater 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_GRTR_OR_EQUAL
);
2397 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2398 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2399 (register Lisp_Object num1
, Lisp_Object num2
)
2401 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2404 /* Convert the cons-of-integers, integer, or float value C to an
2405 unsigned value with maximum value MAX. Signal an error if C does not
2406 have a valid format or is out of range. */
2408 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2411 uintmax_t val
IF_LINT (= 0);
2414 valid
= 0 <= XINT (c
);
2417 else if (FLOATP (c
))
2419 double d
= XFLOAT_DATA (c
);
2421 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2427 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2429 uintmax_t top
= XFASTINT (XCAR (c
));
2430 Lisp_Object rest
= XCDR (c
);
2431 if (top
<= UINTMAX_MAX
>> 24 >> 16
2433 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2434 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2436 uintmax_t mid
= XFASTINT (XCAR (rest
));
2437 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2440 else if (top
<= UINTMAX_MAX
>> 16)
2444 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2446 val
= top
<< 16 | XFASTINT (rest
);
2452 if (! (valid
&& val
<= max
))
2453 error ("Not an in-range integer, float, or cons of integers");
2457 /* Convert the cons-of-integers, integer, or float value C to a signed
2458 value with extrema MIN and MAX. Signal an error if C does not have
2459 a valid format or is out of range. */
2461 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2464 intmax_t val
IF_LINT (= 0);
2470 else if (FLOATP (c
))
2472 double d
= XFLOAT_DATA (c
);
2474 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2480 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2482 intmax_t top
= XINT (XCAR (c
));
2483 Lisp_Object rest
= XCDR (c
);
2484 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2486 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2487 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2489 intmax_t mid
= XFASTINT (XCAR (rest
));
2490 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2493 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2497 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2499 val
= top
<< 16 | XFASTINT (rest
);
2505 if (! (valid
&& min
<= val
&& val
<= max
))
2506 error ("Not an in-range integer, float, or cons of integers");
2510 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2511 doc
: /* Return the decimal representation of NUMBER as a string.
2512 Uses a minus sign if negative.
2513 NUMBER may be an integer or a floating point number. */)
2514 (Lisp_Object number
)
2516 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2519 CHECK_NUMBER_OR_FLOAT (number
);
2521 if (FLOATP (number
))
2522 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2524 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2526 return make_unibyte_string (buffer
, len
);
2529 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2530 doc
: /* Parse STRING as a decimal number and return the number.
2531 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2532 STRING cannot be parsed as an integer or floating point number.
2534 If BASE, interpret STRING as a number in that base. If BASE isn't
2535 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2536 If the base used is not 10, STRING is always parsed as an integer. */)
2537 (register Lisp_Object string
, Lisp_Object base
)
2543 CHECK_STRING (string
);
2549 CHECK_NUMBER (base
);
2550 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2551 xsignal1 (Qargs_out_of_range
, base
);
2555 p
= SSDATA (string
);
2556 while (*p
== ' ' || *p
== '\t')
2559 val
= string_to_number (p
, b
, 1);
2560 return NILP (val
) ? make_number (0) : val
;
2576 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2577 ptrdiff_t, Lisp_Object
*);
2579 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2582 ptrdiff_t argnum
, ok_args
;
2583 EMACS_INT accum
= 0;
2584 EMACS_INT next
, ok_accum
;
2605 for (argnum
= 0; argnum
< nargs
; argnum
++)
2613 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2615 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2618 return float_arith_driver (ok_accum
, ok_args
, code
,
2621 next
= XINT (args
[argnum
]);
2625 if (INT_ADD_OVERFLOW (accum
, next
))
2633 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2638 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2641 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2643 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2645 accum
= ab
& INTMASK
;
2656 xsignal0 (Qarith_error
);
2670 if (!argnum
|| next
> accum
)
2674 if (!argnum
|| next
< accum
)
2680 XSETINT (val
, accum
);
2685 #define isnan(x) ((x) != (x))
2688 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2689 ptrdiff_t nargs
, Lisp_Object
*args
)
2691 register Lisp_Object val
;
2694 for (; argnum
< nargs
; argnum
++)
2696 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2697 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2701 next
= XFLOAT_DATA (val
);
2705 args
[argnum
] = val
; /* runs into a compiler bug. */
2706 next
= XINT (args
[argnum
]);
2714 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2724 if (! IEEE_FLOATING_POINT
&& next
== 0)
2725 xsignal0 (Qarith_error
);
2732 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2734 if (!argnum
|| isnan (next
) || next
> accum
)
2738 if (!argnum
|| isnan (next
) || next
< accum
)
2744 return make_float (accum
);
2748 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2749 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2750 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2751 (ptrdiff_t nargs
, Lisp_Object
*args
)
2753 return arith_driver (Aadd
, nargs
, args
);
2756 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2757 doc
: /* Negate number or subtract numbers or markers and return the result.
2758 With one arg, negates it. With more than one arg,
2759 subtracts all but the first from the first.
2760 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2761 (ptrdiff_t nargs
, Lisp_Object
*args
)
2763 return arith_driver (Asub
, nargs
, args
);
2766 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2767 doc
: /* Return product of any number of arguments, which are numbers or markers.
2768 usage: (* &rest NUMBERS-OR-MARKERS) */)
2769 (ptrdiff_t nargs
, Lisp_Object
*args
)
2771 return arith_driver (Amult
, nargs
, args
);
2774 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2775 doc
: /* Return first argument divided by all the remaining arguments.
2776 The arguments must be numbers or markers.
2777 usage: (/ DIVIDEND &rest DIVISORS) */)
2778 (ptrdiff_t nargs
, Lisp_Object
*args
)
2781 for (argnum
= 2; argnum
< nargs
; argnum
++)
2782 if (FLOATP (args
[argnum
]))
2783 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2784 return arith_driver (Adiv
, nargs
, args
);
2787 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2788 doc
: /* Return remainder of X divided by Y.
2789 Both must be integers or markers. */)
2790 (register Lisp_Object x
, Lisp_Object y
)
2794 CHECK_NUMBER_COERCE_MARKER (x
);
2795 CHECK_NUMBER_COERCE_MARKER (y
);
2798 xsignal0 (Qarith_error
);
2800 XSETINT (val
, XINT (x
) % XINT (y
));
2804 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2805 doc
: /* Return X modulo Y.
2806 The result falls between zero (inclusive) and Y (exclusive).
2807 Both X and Y must be numbers or markers. */)
2808 (register Lisp_Object x
, Lisp_Object y
)
2813 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2814 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2816 if (FLOATP (x
) || FLOATP (y
))
2817 return fmod_float (x
, y
);
2823 xsignal0 (Qarith_error
);
2827 /* If the "remainder" comes out with the wrong sign, fix it. */
2828 if (i2
< 0 ? i1
> 0 : i1
< 0)
2835 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2836 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2837 The value is always a number; markers are converted to numbers.
2838 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2839 (ptrdiff_t nargs
, Lisp_Object
*args
)
2841 return arith_driver (Amax
, nargs
, args
);
2844 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2845 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2846 The value is always a number; markers are converted to numbers.
2847 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2848 (ptrdiff_t nargs
, Lisp_Object
*args
)
2850 return arith_driver (Amin
, nargs
, args
);
2853 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2854 doc
: /* Return bitwise-and of all the arguments.
2855 Arguments may be integers, or markers converted to integers.
2856 usage: (logand &rest INTS-OR-MARKERS) */)
2857 (ptrdiff_t nargs
, Lisp_Object
*args
)
2859 return arith_driver (Alogand
, nargs
, args
);
2862 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2863 doc
: /* Return bitwise-or of all the arguments.
2864 Arguments may be integers, or markers converted to integers.
2865 usage: (logior &rest INTS-OR-MARKERS) */)
2866 (ptrdiff_t nargs
, Lisp_Object
*args
)
2868 return arith_driver (Alogior
, nargs
, args
);
2871 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2872 doc
: /* Return bitwise-exclusive-or of all the arguments.
2873 Arguments may be integers, or markers converted to integers.
2874 usage: (logxor &rest INTS-OR-MARKERS) */)
2875 (ptrdiff_t nargs
, Lisp_Object
*args
)
2877 return arith_driver (Alogxor
, nargs
, args
);
2880 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2881 doc
: /* Return VALUE with its bits shifted left by COUNT.
2882 If COUNT is negative, shifting is actually to the right.
2883 In this case, the sign bit is duplicated. */)
2884 (register Lisp_Object value
, Lisp_Object count
)
2886 register Lisp_Object val
;
2888 CHECK_NUMBER (value
);
2889 CHECK_NUMBER (count
);
2891 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2893 else if (XINT (count
) > 0)
2894 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2895 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2896 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2898 XSETINT (val
, XINT (value
) >> -XINT (count
));
2902 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2903 doc
: /* Return VALUE with its bits shifted left by COUNT.
2904 If COUNT is negative, shifting is actually to the right.
2905 In this case, zeros are shifted in on the left. */)
2906 (register Lisp_Object value
, Lisp_Object count
)
2908 register Lisp_Object val
;
2910 CHECK_NUMBER (value
);
2911 CHECK_NUMBER (count
);
2913 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2915 else if (XINT (count
) > 0)
2916 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2917 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2920 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2924 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2925 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2926 Markers are converted to integers. */)
2927 (register Lisp_Object number
)
2929 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2931 if (FLOATP (number
))
2932 return (make_float (1.0 + XFLOAT_DATA (number
)));
2934 XSETINT (number
, XINT (number
) + 1);
2938 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2939 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2940 Markers are converted to integers. */)
2941 (register Lisp_Object number
)
2943 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2945 if (FLOATP (number
))
2946 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2948 XSETINT (number
, XINT (number
) - 1);
2952 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2953 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2954 (register Lisp_Object number
)
2956 CHECK_NUMBER (number
);
2957 XSETINT (number
, ~XINT (number
));
2961 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2962 doc
: /* Return the byteorder for the machine.
2963 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2964 lowercase l) for small endian machines. */
2968 unsigned i
= 0x04030201;
2969 int order
= *(char *)&i
== 1 ? 108 : 66;
2971 return make_number (order
);
2974 /* Because we round up the bool vector allocate size to word_size
2975 units, we can safely read past the "end" of the vector in the
2976 operations below. These extra bits are always zero. */
2979 bool_vector_spare_mask (EMACS_INT nr_bits
)
2981 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2984 /* Info about unsigned long long, falling back on unsigned long
2985 if unsigned long long is not available. */
2987 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2988 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2989 # define ULL_MAX ULLONG_MAX
2991 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
2992 # define ULL_MAX ULONG_MAX
2993 # define count_one_bits_ll count_one_bits_l
2994 # define count_trailing_zeros_ll count_trailing_zeros_l
2997 /* Shift VAL right by the width of an unsigned long long.
2998 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3001 shift_right_ull (bits_word w
)
3003 /* Pacify bogus GCC warning about shift count exceeding type width. */
3004 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3008 /* Return the number of 1 bits in W. */
3011 count_one_bits_word (bits_word w
)
3013 if (BITS_WORD_MAX
<= UINT_MAX
)
3014 return count_one_bits (w
);
3015 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3016 return count_one_bits_l (w
);
3019 int i
= 0, count
= 0;
3020 while (count
+= count_one_bits_ll (w
),
3021 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3022 w
= shift_right_ull (w
);
3027 enum bool_vector_op
{ bool_vector_exclusive_or
,
3029 bool_vector_intersection
,
3030 bool_vector_set_difference
,
3031 bool_vector_subsetp
};
3034 bool_vector_binop_driver (Lisp_Object a
,
3037 enum bool_vector_op op
)
3040 bits_word
*adata
, *bdata
, *destdata
;
3044 CHECK_BOOL_VECTOR (a
);
3045 CHECK_BOOL_VECTOR (b
);
3047 nr_bits
= bool_vector_size (a
);
3048 if (bool_vector_size (b
) != nr_bits
)
3049 wrong_length_argument (a
, b
, dest
);
3051 nr_words
= bool_vector_words (nr_bits
);
3052 adata
= bool_vector_data (a
);
3053 bdata
= bool_vector_data (b
);
3057 dest
= make_uninit_bool_vector (nr_bits
);
3058 destdata
= bool_vector_data (dest
);
3062 CHECK_BOOL_VECTOR (dest
);
3063 destdata
= bool_vector_data (dest
);
3064 if (bool_vector_size (dest
) != nr_bits
)
3065 wrong_length_argument (a
, b
, dest
);
3069 case bool_vector_exclusive_or
:
3070 for (; i
< nr_words
; i
++)
3071 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3075 case bool_vector_subsetp
:
3076 for (; i
< nr_words
; i
++)
3077 if (adata
[i
] &~ bdata
[i
])
3081 case bool_vector_union
:
3082 for (; i
< nr_words
; i
++)
3083 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3087 case bool_vector_intersection
:
3088 for (; i
< nr_words
; i
++)
3089 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3093 case bool_vector_set_difference
:
3094 for (; i
< nr_words
; i
++)
3095 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3106 case bool_vector_exclusive_or
:
3107 for (; i
< nr_words
; i
++)
3108 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3111 case bool_vector_union
:
3112 for (; i
< nr_words
; i
++)
3113 destdata
[i
] = adata
[i
] | bdata
[i
];
3116 case bool_vector_intersection
:
3117 for (; i
< nr_words
; i
++)
3118 destdata
[i
] = adata
[i
] & bdata
[i
];
3121 case bool_vector_set_difference
:
3122 for (; i
< nr_words
; i
++)
3123 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3133 /* PRECONDITION must be true. Return VALUE. This odd construction
3134 works around a bogus GCC diagnostic "shift count >= width of type". */
3137 pre_value (bool precondition
, int value
)
3139 eassume (precondition
);
3140 return precondition
? value
: 0;
3143 /* Compute the number of trailing zero bits in val. If val is zero,
3144 return the number of bits in val. */
3146 count_trailing_zero_bits (bits_word val
)
3148 if (BITS_WORD_MAX
== UINT_MAX
)
3149 return count_trailing_zeros (val
);
3150 if (BITS_WORD_MAX
== ULONG_MAX
)
3151 return count_trailing_zeros_l (val
);
3152 if (BITS_WORD_MAX
== ULL_MAX
)
3153 return count_trailing_zeros_ll (val
);
3155 /* The rest of this code is for the unlikely platform where bits_word differs
3156 in width from unsigned int, unsigned long, and unsigned long long. */
3157 val
|= ~ BITS_WORD_MAX
;
3158 if (BITS_WORD_MAX
<= UINT_MAX
)
3159 return count_trailing_zeros (val
);
3160 if (BITS_WORD_MAX
<= ULONG_MAX
)
3161 return count_trailing_zeros_l (val
);
3166 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3167 count
+= BITS_PER_ULL
)
3170 return count
+ count_trailing_zeros_ll (val
);
3171 val
= shift_right_ull (val
);
3174 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3175 && BITS_WORD_MAX
== (bits_word
) -1)
3176 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3177 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3178 return count
+ count_trailing_zeros_ll (val
);
3183 bits_word_to_host_endian (bits_word val
)
3185 #ifndef WORDS_BIGENDIAN
3188 if (BITS_WORD_MAX
>> 31 == 1)
3189 return bswap_32 (val
);
3190 # if HAVE_UNSIGNED_LONG_LONG
3191 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3192 return bswap_64 (val
);
3197 for (i
= 0; i
< sizeof val
; i
++)
3199 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3200 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3201 val
= val
>> 1 >> (CHAR_BIT
- 1);
3208 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3209 Sbool_vector_exclusive_or
, 2, 3, 0,
3210 doc
: /* Return A ^ B, bitwise exclusive or.
3211 If optional third argument C is given, store result into C.
3212 A, B, and C must be bool vectors of the same length.
3213 Return the destination vector if it changed or nil otherwise. */)
3214 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3216 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3219 DEFUN ("bool-vector-union", Fbool_vector_union
,
3220 Sbool_vector_union
, 2, 3, 0,
3221 doc
: /* Return A | B, bitwise or.
3222 If optional third argument C is given, store result into C.
3223 A, B, and C must be bool vectors of the same length.
3224 Return the destination vector if it changed or nil otherwise. */)
3225 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3227 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3230 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3231 Sbool_vector_intersection
, 2, 3, 0,
3232 doc
: /* Return A & B, bitwise and.
3233 If optional third argument C is given, store result into C.
3234 A, B, and C must be bool vectors of the same length.
3235 Return the destination vector if it changed or nil otherwise. */)
3236 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3238 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3241 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3242 Sbool_vector_set_difference
, 2, 3, 0,
3243 doc
: /* Return A &~ B, set difference.
3244 If optional third argument C is given, store result into C.
3245 A, B, and C must be bool vectors of the same length.
3246 Return the destination vector if it changed or nil otherwise. */)
3247 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3249 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3252 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3253 Sbool_vector_subsetp
, 2, 2, 0,
3254 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3255 A and B must be bool vectors of the same length. */)
3256 (Lisp_Object a
, Lisp_Object b
)
3258 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3261 DEFUN ("bool-vector-not", Fbool_vector_not
,
3262 Sbool_vector_not
, 1, 2, 0,
3263 doc
: /* Compute ~A, set complement.
3264 If optional second argument B is given, store result into B.
3265 A and B must be bool vectors of the same length.
3266 Return the destination vector. */)
3267 (Lisp_Object a
, Lisp_Object b
)
3270 bits_word
*bdata
, *adata
;
3273 CHECK_BOOL_VECTOR (a
);
3274 nr_bits
= bool_vector_size (a
);
3277 b
= make_uninit_bool_vector (nr_bits
);
3280 CHECK_BOOL_VECTOR (b
);
3281 if (bool_vector_size (b
) != nr_bits
)
3282 wrong_length_argument (a
, b
, Qnil
);
3285 bdata
= bool_vector_data (b
);
3286 adata
= bool_vector_data (a
);
3288 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3289 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3291 if (nr_bits
% BITS_PER_BITS_WORD
)
3293 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3295 mword
&= bool_vector_spare_mask (nr_bits
);
3296 bdata
[i
] = bits_word_to_host_endian (mword
);
3302 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3303 Sbool_vector_count_population
, 1, 1, 0,
3304 doc
: /* Count how many elements in A are t.
3305 A is a bool vector. To count A's nil elements, subtract the return
3306 value from A's length. */)
3312 ptrdiff_t i
, nwords
;
3314 CHECK_BOOL_VECTOR (a
);
3316 nr_bits
= bool_vector_size (a
);
3317 nwords
= bool_vector_words (nr_bits
);
3319 adata
= bool_vector_data (a
);
3321 for (i
= 0; i
< nwords
; i
++)
3322 count
+= count_one_bits_word (adata
[i
]);
3324 return make_number (count
);
3327 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3328 Sbool_vector_count_consecutive
, 3, 3, 0,
3329 doc
: /* Count how many consecutive elements in A equal B starting at I.
3330 A is a bool vector, B is t or nil, and I is an index into A. */)
3331 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3338 bits_word mword
; /* Machine word. */
3339 ptrdiff_t pos
, pos0
;
3342 CHECK_BOOL_VECTOR (a
);
3345 nr_bits
= bool_vector_size (a
);
3346 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3347 args_out_of_range (a
, i
);
3349 adata
= bool_vector_data (a
);
3350 nr_words
= bool_vector_words (nr_bits
);
3351 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3352 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3355 /* By XORing with twiddle, we transform the problem of "count
3356 consecutive equal values" into "count the zero bits". The latter
3357 operation usually has hardware support. */
3358 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3360 /* Scan the remainder of the mword at the current offset. */
3361 if (pos
< nr_words
&& offset
!= 0)
3363 mword
= bits_word_to_host_endian (adata
[pos
]);
3367 /* Do not count the pad bits. */
3368 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3370 count
= count_trailing_zero_bits (mword
);
3372 if (count
+ offset
< BITS_PER_BITS_WORD
)
3373 return make_number (count
);
3376 /* Scan whole words until we either reach the end of the vector or
3377 find an mword that doesn't completely match. twiddle is
3378 endian-independent. */
3380 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3382 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3386 /* If we stopped because of a mismatch, see how many bits match
3387 in the current mword. */
3388 mword
= bits_word_to_host_endian (adata
[pos
]);
3390 count
+= count_trailing_zero_bits (mword
);
3392 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3394 /* If we hit the end, we might have overshot our count. Reduce
3395 the total by the number of spare bits at the end of the
3397 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3400 return make_number (count
);
3407 Lisp_Object error_tail
, arith_tail
;
3409 DEFSYM (Qquote
, "quote");
3410 DEFSYM (Qlambda
, "lambda");
3411 DEFSYM (Qsubr
, "subr");
3412 DEFSYM (Qerror_conditions
, "error-conditions");
3413 DEFSYM (Qerror_message
, "error-message");
3414 DEFSYM (Qtop_level
, "top-level");
3416 DEFSYM (Qerror
, "error");
3417 DEFSYM (Quser_error
, "user-error");
3418 DEFSYM (Qquit
, "quit");
3419 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3420 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3421 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3422 DEFSYM (Qvoid_function
, "void-function");
3423 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3424 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3425 DEFSYM (Qvoid_variable
, "void-variable");
3426 DEFSYM (Qsetting_constant
, "setting-constant");
3427 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3429 DEFSYM (Qinvalid_function
, "invalid-function");
3430 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3431 DEFSYM (Qno_catch
, "no-catch");
3432 DEFSYM (Qend_of_file
, "end-of-file");
3433 DEFSYM (Qarith_error
, "arith-error");
3434 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3435 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3436 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3437 DEFSYM (Qtext_read_only
, "text-read-only");
3438 DEFSYM (Qmark_inactive
, "mark-inactive");
3440 DEFSYM (Qlistp
, "listp");
3441 DEFSYM (Qconsp
, "consp");
3442 DEFSYM (Qsymbolp
, "symbolp");
3443 DEFSYM (Qkeywordp
, "keywordp");
3444 DEFSYM (Qintegerp
, "integerp");
3445 DEFSYM (Qnatnump
, "natnump");
3446 DEFSYM (Qwholenump
, "wholenump");
3447 DEFSYM (Qstringp
, "stringp");
3448 DEFSYM (Qarrayp
, "arrayp");
3449 DEFSYM (Qsequencep
, "sequencep");
3450 DEFSYM (Qbufferp
, "bufferp");
3451 DEFSYM (Qvectorp
, "vectorp");
3452 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3453 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3454 DEFSYM (Qmarkerp
, "markerp");
3455 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3456 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3457 DEFSYM (Qboundp
, "boundp");
3458 DEFSYM (Qfboundp
, "fboundp");
3460 DEFSYM (Qfloatp
, "floatp");
3461 DEFSYM (Qnumberp
, "numberp");
3462 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3464 DEFSYM (Qchar_table_p
, "char-table-p");
3465 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3467 DEFSYM (Qsubrp
, "subrp");
3468 DEFSYM (Qunevalled
, "unevalled");
3469 DEFSYM (Qmany
, "many");
3471 DEFSYM (Qcdr
, "cdr");
3473 /* Handle automatic advice activation. */
3474 DEFSYM (Qad_advice_info
, "ad-advice-info");
3475 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3477 error_tail
= pure_cons (Qerror
, Qnil
);
3479 /* ERROR is used as a signaler for random errors for which nothing else is
3482 Fput (Qerror
, Qerror_conditions
,
3484 Fput (Qerror
, Qerror_message
,
3485 build_pure_c_string ("error"));
3487 #define PUT_ERROR(sym, tail, msg) \
3488 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3489 Fput (sym, Qerror_message, build_pure_c_string (msg))
3491 PUT_ERROR (Qquit
, Qnil
, "Quit");
3493 PUT_ERROR (Quser_error
, error_tail
, "");
3494 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3495 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3496 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3497 PUT_ERROR (Qvoid_function
, error_tail
,
3498 "Symbol's function definition is void");
3499 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3500 "Symbol's chain of function indirections contains a loop");
3501 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3502 "Symbol's chain of variable indirections contains a loop");
3503 DEFSYM (Qcircular_list
, "circular-list");
3504 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3505 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3506 PUT_ERROR (Qsetting_constant
, error_tail
,
3507 "Attempt to set a constant symbol");
3508 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3509 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3510 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3511 "Wrong number of arguments");
3512 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3513 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3515 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3516 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3517 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3519 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3520 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3521 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3522 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3523 "Text is read-only");
3525 DEFSYM (Qrange_error
, "range-error");
3526 DEFSYM (Qdomain_error
, "domain-error");
3527 DEFSYM (Qsingularity_error
, "singularity-error");
3528 DEFSYM (Qoverflow_error
, "overflow-error");
3529 DEFSYM (Qunderflow_error
, "underflow-error");
3531 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3533 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3535 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3536 "Arithmetic singularity error");
3538 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3539 "Arithmetic overflow error");
3540 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3541 "Arithmetic underflow error");
3543 /* Types that type-of returns. */
3544 DEFSYM (Qinteger
, "integer");
3545 DEFSYM (Qsymbol
, "symbol");
3546 DEFSYM (Qstring
, "string");
3547 DEFSYM (Qcons
, "cons");
3548 DEFSYM (Qmarker
, "marker");
3549 DEFSYM (Qoverlay
, "overlay");
3550 DEFSYM (Qfloat
, "float");
3551 DEFSYM (Qwindow_configuration
, "window-configuration");
3552 DEFSYM (Qprocess
, "process");
3553 DEFSYM (Qwindow
, "window");
3554 DEFSYM (Qcompiled_function
, "compiled-function");
3555 DEFSYM (Qbuffer
, "buffer");
3556 DEFSYM (Qframe
, "frame");
3557 DEFSYM (Qvector
, "vector");
3558 DEFSYM (Qchar_table
, "char-table");
3559 DEFSYM (Qbool_vector
, "bool-vector");
3560 DEFSYM (Qhash_table
, "hash-table");
3561 DEFSYM (Qmisc
, "misc");
3563 DEFSYM (Qdefun
, "defun");
3565 DEFSYM (Qfont_spec
, "font-spec");
3566 DEFSYM (Qfont_entity
, "font-entity");
3567 DEFSYM (Qfont_object
, "font-object");
3569 DEFSYM (Qinteractive_form
, "interactive-form");
3570 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3572 defsubr (&Sindirect_variable
);
3573 defsubr (&Sinteractive_form
);
3576 defsubr (&Stype_of
);
3581 defsubr (&Sintegerp
);
3582 defsubr (&Sinteger_or_marker_p
);
3583 defsubr (&Snumberp
);
3584 defsubr (&Snumber_or_marker_p
);
3586 defsubr (&Snatnump
);
3587 defsubr (&Ssymbolp
);
3588 defsubr (&Skeywordp
);
3589 defsubr (&Sstringp
);
3590 defsubr (&Smultibyte_string_p
);
3591 defsubr (&Svectorp
);
3592 defsubr (&Schar_table_p
);
3593 defsubr (&Svector_or_char_table_p
);
3594 defsubr (&Sbool_vector_p
);
3596 defsubr (&Ssequencep
);
3597 defsubr (&Sbufferp
);
3598 defsubr (&Smarkerp
);
3600 defsubr (&Sbyte_code_function_p
);
3601 defsubr (&Schar_or_string_p
);
3604 defsubr (&Scar_safe
);
3605 defsubr (&Scdr_safe
);
3608 defsubr (&Ssymbol_function
);
3609 defsubr (&Sindirect_function
);
3610 defsubr (&Ssymbol_plist
);
3611 defsubr (&Ssymbol_name
);
3612 defsubr (&Smakunbound
);
3613 defsubr (&Sfmakunbound
);
3615 defsubr (&Sfboundp
);
3617 defsubr (&Sdefalias
);
3618 defsubr (&Ssetplist
);
3619 defsubr (&Ssymbol_value
);
3621 defsubr (&Sdefault_boundp
);
3622 defsubr (&Sdefault_value
);
3623 defsubr (&Sset_default
);
3624 defsubr (&Ssetq_default
);
3625 defsubr (&Smake_variable_buffer_local
);
3626 defsubr (&Smake_local_variable
);
3627 defsubr (&Skill_local_variable
);
3628 defsubr (&Smake_variable_frame_local
);
3629 defsubr (&Slocal_variable_p
);
3630 defsubr (&Slocal_variable_if_set_p
);
3631 defsubr (&Svariable_binding_locus
);
3632 #if 0 /* XXX Remove this. --lorentey */
3633 defsubr (&Sterminal_local_value
);
3634 defsubr (&Sset_terminal_local_value
);
3638 defsubr (&Snumber_to_string
);
3639 defsubr (&Sstring_to_number
);
3640 defsubr (&Seqlsign
);
3662 defsubr (&Sbyteorder
);
3663 defsubr (&Ssubr_arity
);
3664 defsubr (&Ssubr_name
);
3666 defsubr (&Sbool_vector_exclusive_or
);
3667 defsubr (&Sbool_vector_union
);
3668 defsubr (&Sbool_vector_intersection
);
3669 defsubr (&Sbool_vector_set_difference
);
3670 defsubr (&Sbool_vector_not
);
3671 defsubr (&Sbool_vector_subsetp
);
3672 defsubr (&Sbool_vector_count_consecutive
);
3673 defsubr (&Sbool_vector_count_population
);
3675 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3677 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3678 doc
: /* The largest value that is representable in a Lisp integer. */);
3679 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3680 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3682 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3683 doc
: /* The smallest value that is representable in a Lisp integer. */);
3684 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3685 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;