1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 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 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
41 static Lisp_Object Qsubr
;
42 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
43 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
44 static Lisp_Object Qwrong_length_argument
;
45 static Lisp_Object Qwrong_type_argument
;
46 Lisp_Object Qvoid_variable
, Qvoid_function
;
47 static Lisp_Object Qcyclic_function_indirection
;
48 static Lisp_Object Qcyclic_variable_indirection
;
49 Lisp_Object Qcircular_list
;
50 static Lisp_Object Qsetting_constant
;
51 Lisp_Object Qinvalid_read_syntax
;
52 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
53 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
54 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
55 Lisp_Object Qtext_read_only
;
57 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
58 static Lisp_Object Qnatnump
;
59 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
60 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
61 Lisp_Object Qbool_vector_p
;
62 Lisp_Object Qbuffer_or_string_p
;
63 static Lisp_Object Qkeywordp
, Qboundp
;
65 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
68 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
70 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
71 Lisp_Object Qrange_error
, Qoverflow_error
;
74 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
76 Lisp_Object Qinteger
, Qsymbol
;
77 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
79 static Lisp_Object Qoverlay
, Qwindow_configuration
;
80 static Lisp_Object Qprocess
, Qmarker
;
81 static Lisp_Object Qcompiled_function
, Qframe
;
83 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
84 static Lisp_Object Qsubrp
;
85 static Lisp_Object Qmany
, Qunevalled
;
86 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
87 static Lisp_Object Qdefun
;
89 Lisp_Object Qinteractive_form
;
90 static Lisp_Object Qdefalias_fset_function
;
92 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
95 BOOLFWDP (union Lisp_Fwd
*a
)
97 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
100 INTFWDP (union Lisp_Fwd
*a
)
102 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
105 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
107 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
110 OBJFWDP (union Lisp_Fwd
*a
)
112 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
115 static struct Lisp_Boolfwd
*
116 XBOOLFWD (union Lisp_Fwd
*a
)
118 eassert (BOOLFWDP (a
));
119 return &a
->u_boolfwd
;
121 static struct Lisp_Kboard_Objfwd
*
122 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
124 eassert (KBOARD_OBJFWDP (a
));
125 return &a
->u_kboard_objfwd
;
127 static struct Lisp_Intfwd
*
128 XINTFWD (union Lisp_Fwd
*a
)
130 eassert (INTFWDP (a
));
133 static struct Lisp_Objfwd
*
134 XOBJFWD (union Lisp_Fwd
*a
)
136 eassert (OBJFWDP (a
));
141 CHECK_SUBR (Lisp_Object x
)
143 CHECK_TYPE (SUBRP (x
), Qsubrp
, x
);
147 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
149 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
154 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
156 return XCDR (blv
->valcell
);
160 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
162 XSETCDR (blv
->valcell
, val
);
166 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
172 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
178 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
183 static _Noreturn
void
184 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
186 Lisp_Object size1
= make_number (bool_vector_size (a1
));
187 Lisp_Object size2
= make_number (bool_vector_size (a2
));
189 xsignal2 (Qwrong_length_argument
, size1
, size2
);
191 xsignal3 (Qwrong_length_argument
, size1
, size2
,
192 make_number (bool_vector_size (a3
)));
196 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
198 /* If VALUE is not even a valid Lisp object, we'd want to abort here
199 where we can get a backtrace showing where it came from. We used
200 to try and do that by checking the tagbits, but nowadays all
201 tagbits are potentially valid. */
202 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
205 xsignal2 (Qwrong_type_argument
, predicate
, value
);
209 pure_write_error (Lisp_Object obj
)
211 xsignal2 (Qerror
, build_string ("Attempt to modify read-only object"), obj
);
215 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
217 xsignal2 (Qargs_out_of_range
, a1
, a2
);
221 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
223 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
227 /* Data type predicates. */
229 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
230 doc
: /* Return t if the two args are the same Lisp object. */)
231 (Lisp_Object obj1
, Lisp_Object obj2
)
238 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
239 doc
: /* Return t if OBJECT is nil. */)
247 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
248 doc
: /* Return a symbol representing the type of OBJECT.
249 The symbol returned names the object's basic type;
250 for example, (type-of 1) returns `integer'. */)
253 switch (XTYPE (object
))
268 switch (XMISCTYPE (object
))
270 case Lisp_Misc_Marker
:
272 case Lisp_Misc_Overlay
:
274 case Lisp_Misc_Float
:
279 case Lisp_Vectorlike
:
280 if (WINDOW_CONFIGURATIONP (object
))
281 return Qwindow_configuration
;
282 if (PROCESSP (object
))
284 if (WINDOWP (object
))
288 if (COMPILEDP (object
))
289 return Qcompiled_function
;
290 if (BUFFERP (object
))
292 if (CHAR_TABLE_P (object
))
294 if (BOOL_VECTOR_P (object
))
298 if (HASH_TABLE_P (object
))
300 if (FONT_SPEC_P (object
))
302 if (FONT_ENTITY_P (object
))
304 if (FONT_OBJECT_P (object
))
316 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
317 doc
: /* Return t if OBJECT is a cons cell. */)
325 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
326 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
334 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
335 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
336 Otherwise, return nil. */)
339 if (CONSP (object
) || NILP (object
))
344 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
345 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
348 if (CONSP (object
) || NILP (object
))
353 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
354 doc
: /* Return t if OBJECT is a symbol. */)
357 if (SYMBOLP (object
))
362 /* Define this in C to avoid unnecessarily consing up the symbol
364 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
365 doc
: /* Return t if OBJECT is a keyword.
366 This means that it is a symbol with a print name beginning with `:'
367 interned in the initial obarray. */)
371 && SREF (SYMBOL_NAME (object
), 0) == ':'
372 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
377 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is a vector. */)
381 if (VECTORP (object
))
386 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is a string. */)
390 if (STRINGP (object
))
395 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
397 doc
: /* Return t if OBJECT is a multibyte string.
398 Return nil if OBJECT is either a unibyte string, or not a string. */)
401 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
406 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is a char-table. */)
410 if (CHAR_TABLE_P (object
))
415 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
416 Svector_or_char_table_p
, 1, 1, 0,
417 doc
: /* Return t if OBJECT is a char-table or vector. */)
420 if (VECTORP (object
) || CHAR_TABLE_P (object
))
425 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
426 doc
: /* Return t if OBJECT is a bool-vector. */)
429 if (BOOL_VECTOR_P (object
))
434 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
435 doc
: /* Return t if OBJECT is an array (string or vector). */)
443 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
444 doc
: /* Return t if OBJECT is a sequence (list or array). */)
445 (register Lisp_Object object
)
447 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
452 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
453 doc
: /* Return t if OBJECT is an editor buffer. */)
456 if (BUFFERP (object
))
461 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
462 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
465 if (MARKERP (object
))
470 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
471 doc
: /* Return t if OBJECT is a built-in function. */)
479 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
481 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
484 if (COMPILEDP (object
))
489 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
490 doc
: /* Return t if OBJECT is a character or a string. */)
491 (register Lisp_Object object
)
493 if (CHARACTERP (object
) || STRINGP (object
))
498 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
499 doc
: /* Return t if OBJECT is an integer. */)
502 if (INTEGERP (object
))
507 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
508 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
509 (register Lisp_Object object
)
511 if (MARKERP (object
) || INTEGERP (object
))
516 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
517 doc
: /* Return t if OBJECT is a nonnegative integer. */)
520 if (NATNUMP (object
))
525 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
526 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
529 if (NUMBERP (object
))
535 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
536 Snumber_or_marker_p
, 1, 1, 0,
537 doc
: /* Return t if OBJECT is a number or a marker. */)
540 if (NUMBERP (object
) || MARKERP (object
))
545 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
546 doc
: /* Return t if OBJECT is a floating point number. */)
555 /* Extract and set components of lists. */
557 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
558 doc
: /* Return the car of LIST. If arg is nil, return nil.
559 Error if arg is not nil and not a cons cell. See also `car-safe'.
561 See Info node `(elisp)Cons Cells' for a discussion of related basic
562 Lisp concepts such as car, cdr, cons cell and list. */)
563 (register Lisp_Object list
)
568 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
569 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
572 return CAR_SAFE (object
);
575 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
576 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
577 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
579 See Info node `(elisp)Cons Cells' for a discussion of related basic
580 Lisp concepts such as cdr, car, cons cell and list. */)
581 (register Lisp_Object list
)
586 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
587 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
590 return CDR_SAFE (object
);
593 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
594 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
595 (register Lisp_Object cell
, Lisp_Object newcar
)
599 XSETCAR (cell
, newcar
);
603 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
604 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
605 (register Lisp_Object cell
, Lisp_Object newcdr
)
609 XSETCDR (cell
, newcdr
);
613 /* Extract and set components of symbols. */
615 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
616 doc
: /* Return t if SYMBOL's value is not void.
617 Note that if `lexical-binding' is in effect, this refers to the
618 global value outside of any lexical scope. */)
619 (register Lisp_Object symbol
)
621 Lisp_Object valcontents
;
622 struct Lisp_Symbol
*sym
;
623 CHECK_SYMBOL (symbol
);
624 sym
= XSYMBOL (symbol
);
627 switch (sym
->redirect
)
629 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
630 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
631 case SYMBOL_LOCALIZED
:
633 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
635 /* In set_internal, we un-forward vars when their value is
640 swap_in_symval_forwarding (sym
, blv
);
641 valcontents
= blv_value (blv
);
645 case SYMBOL_FORWARDED
:
646 /* In set_internal, we un-forward vars when their value is
649 default: emacs_abort ();
652 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
655 /* FIXME: Make it an alias for function-symbol! */
656 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
657 doc
: /* Return t if SYMBOL's function definition is not void. */)
658 (register Lisp_Object symbol
)
660 CHECK_SYMBOL (symbol
);
661 return NILP (XSYMBOL (symbol
)->function
) ? Qnil
: Qt
;
664 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
665 doc
: /* Make SYMBOL's value be void.
667 (register Lisp_Object symbol
)
669 CHECK_SYMBOL (symbol
);
670 if (SYMBOL_CONSTANT_P (symbol
))
671 xsignal1 (Qsetting_constant
, symbol
);
672 Fset (symbol
, Qunbound
);
676 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
677 doc
: /* Make SYMBOL's function definition be nil.
679 (register Lisp_Object symbol
)
681 CHECK_SYMBOL (symbol
);
682 if (NILP (symbol
) || EQ (symbol
, Qt
))
683 xsignal1 (Qsetting_constant
, symbol
);
684 set_symbol_function (symbol
, Qnil
);
688 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
689 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
690 (register Lisp_Object symbol
)
692 CHECK_SYMBOL (symbol
);
693 return XSYMBOL (symbol
)->function
;
696 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
697 doc
: /* Return SYMBOL's property list. */)
698 (register Lisp_Object symbol
)
700 CHECK_SYMBOL (symbol
);
701 return XSYMBOL (symbol
)->plist
;
704 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
705 doc
: /* Return SYMBOL's name, a string. */)
706 (register Lisp_Object symbol
)
708 register Lisp_Object name
;
710 CHECK_SYMBOL (symbol
);
711 name
= SYMBOL_NAME (symbol
);
715 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
716 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
717 (register Lisp_Object symbol
, Lisp_Object definition
)
719 register Lisp_Object function
;
720 CHECK_SYMBOL (symbol
);
722 function
= XSYMBOL (symbol
)->function
;
724 if (!NILP (Vautoload_queue
) && !NILP (function
))
725 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
727 if (AUTOLOADP (function
))
728 Fput (symbol
, Qautoload
, XCDR (function
));
730 /* Convert to eassert or remove after GC bug is found. In the
731 meantime, check unconditionally, at a slight perf hit. */
732 if (valid_lisp_object_p (definition
) < 1)
735 set_symbol_function (symbol
, definition
);
740 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
741 doc
: /* Set SYMBOL's function definition to DEFINITION.
742 Associates the function with the current load file, if any.
743 The optional third argument DOCSTRING specifies the documentation string
744 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
745 determined by DEFINITION.
747 Internally, this normally uses `fset', but if SYMBOL has a
748 `defalias-fset-function' property, the associated value is used instead.
750 The return value is undefined. */)
751 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
753 CHECK_SYMBOL (symbol
);
754 if (!NILP (Vpurify_flag
)
755 /* If `definition' is a keymap, immutable (and copying) is wrong. */
756 && !KEYMAPP (definition
))
757 definition
= Fpurecopy (definition
);
760 bool autoload
= AUTOLOADP (definition
);
761 if (NILP (Vpurify_flag
) || !autoload
)
762 { /* Only add autoload entries after dumping, because the ones before are
763 not useful and else we get loads of them from the loaddefs.el. */
765 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
766 /* Remember that the function was already an autoload. */
767 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
768 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
772 { /* Handle automatic advice activation. */
773 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
775 call2 (hook
, symbol
, definition
);
777 Ffset (symbol
, definition
);
780 if (!NILP (docstring
))
781 Fput (symbol
, Qfunction_documentation
, docstring
);
782 /* We used to return `definition', but now that `defun' and `defmacro' expand
783 to a call to `defalias', we return `symbol' for backward compatibility
788 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
789 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
790 (register Lisp_Object symbol
, Lisp_Object newplist
)
792 CHECK_SYMBOL (symbol
);
793 set_symbol_plist (symbol
, newplist
);
797 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
798 doc
: /* Return minimum and maximum number of args allowed for SUBR.
799 SUBR must be a built-in function.
800 The returned value is a pair (MIN . MAX). MIN is the minimum number
801 of args. MAX is the maximum number or the symbol `many', for a
802 function with `&rest' args, or `unevalled' for a special form. */)
805 short minargs
, maxargs
;
807 minargs
= XSUBR (subr
)->min_args
;
808 maxargs
= XSUBR (subr
)->max_args
;
809 return Fcons (make_number (minargs
),
810 maxargs
== MANY
? Qmany
811 : maxargs
== UNEVALLED
? Qunevalled
812 : make_number (maxargs
));
815 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
816 doc
: /* Return name of subroutine SUBR.
817 SUBR must be a built-in function. */)
822 name
= XSUBR (subr
)->symbol_name
;
823 return build_string (name
);
826 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
827 doc
: /* Return the interactive form of CMD or nil if none.
828 If CMD is not a command, the return value is nil.
829 Value, if non-nil, is a list \(interactive SPEC). */)
832 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
837 /* Use an `interactive-form' property if present, analogous to the
838 function-documentation property. */
840 while (SYMBOLP (fun
))
842 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
846 fun
= Fsymbol_function (fun
);
851 const char *spec
= XSUBR (fun
)->intspec
;
853 return list2 (Qinteractive
,
854 (*spec
!= '(') ? build_string (spec
) :
855 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
857 else if (COMPILEDP (fun
))
859 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
860 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
862 else if (AUTOLOADP (fun
))
863 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
864 else if (CONSP (fun
))
866 Lisp_Object funcar
= XCAR (fun
);
867 if (EQ (funcar
, Qclosure
))
868 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
869 else if (EQ (funcar
, Qlambda
))
870 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
876 /***********************************************************************
877 Getting and Setting Values of Symbols
878 ***********************************************************************/
880 /* Return the symbol holding SYMBOL's value. Signal
881 `cyclic-variable-indirection' if SYMBOL's chain of variable
882 indirections contains a loop. */
885 indirect_variable (struct Lisp_Symbol
*symbol
)
887 struct Lisp_Symbol
*tortoise
, *hare
;
889 hare
= tortoise
= symbol
;
891 while (hare
->redirect
== SYMBOL_VARALIAS
)
893 hare
= SYMBOL_ALIAS (hare
);
894 if (hare
->redirect
!= SYMBOL_VARALIAS
)
897 hare
= SYMBOL_ALIAS (hare
);
898 tortoise
= SYMBOL_ALIAS (tortoise
);
900 if (hare
== tortoise
)
903 XSETSYMBOL (tem
, symbol
);
904 xsignal1 (Qcyclic_variable_indirection
, tem
);
912 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
913 doc
: /* Return the variable at the end of OBJECT's variable chain.
914 If OBJECT is a symbol, follow its variable indirections (if any), and
915 return the variable at the end of the chain of aliases. See Info node
916 `(elisp)Variable Aliases'.
918 If OBJECT is not a symbol, just return it. If there is a loop in the
919 chain of aliases, signal a `cyclic-variable-indirection' error. */)
922 if (SYMBOLP (object
))
924 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
925 XSETSYMBOL (object
, sym
);
931 /* Given the raw contents of a symbol value cell,
932 return the Lisp value of the symbol.
933 This does not handle buffer-local variables; use
934 swap_in_symval_forwarding for that. */
937 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
939 register Lisp_Object val
;
940 switch (XFWDTYPE (valcontents
))
943 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
947 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
950 return *XOBJFWD (valcontents
)->objvar
;
952 case Lisp_Fwd_Buffer_Obj
:
953 return per_buffer_value (current_buffer
,
954 XBUFFER_OBJFWD (valcontents
)->offset
);
956 case Lisp_Fwd_Kboard_Obj
:
957 /* We used to simply use current_kboard here, but from Lisp
958 code, its value is often unexpected. It seems nicer to
959 allow constructions like this to work as intuitively expected:
961 (with-selected-frame frame
962 (define-key local-function-map "\eOP" [f1]))
964 On the other hand, this affects the semantics of
965 last-command and real-last-command, and people may rely on
966 that. I took a quick look at the Lisp codebase, and I
967 don't think anything will break. --lorentey */
968 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
969 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
970 default: emacs_abort ();
974 /* Used to signal a user-friendly error when symbol WRONG is
975 not a member of CHOICE, which should be a list of symbols. */
978 wrong_choice (Lisp_Object choice
, Lisp_Object wrong
)
980 ptrdiff_t i
= 0, len
= XINT (Flength (choice
));
981 Lisp_Object obj
, *args
;
984 SAFE_ALLOCA_LISP (args
, len
* 2 + 1);
986 args
[i
++] = build_string ("One of ");
988 for (obj
= choice
; !NILP (obj
); obj
= XCDR (obj
))
990 args
[i
++] = SYMBOL_NAME (XCAR (obj
));
991 args
[i
++] = build_string (NILP (XCDR (obj
)) ? " should be specified"
992 : (NILP (XCDR (XCDR (obj
))) ? " or " : ", "));
995 obj
= Fconcat (i
, args
);
997 xsignal2 (Qerror
, obj
, wrong
);
1000 /* Used to signal a user-friendly error if WRONG is not a number or
1001 integer/floating-point number outsize of inclusive MIN..MAX range. */
1004 wrong_range (Lisp_Object min
, Lisp_Object max
, Lisp_Object wrong
)
1006 Lisp_Object args
[4];
1008 args
[0] = build_string ("Value should be from ");
1009 args
[1] = Fnumber_to_string (min
);
1010 args
[2] = build_string (" to ");
1011 args
[3] = Fnumber_to_string (max
);
1013 xsignal2 (Qerror
, Fconcat (4, args
), wrong
);
1016 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1017 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1018 buffer-independent contents of the value cell: forwarded just one
1019 step past the buffer-localness.
1021 BUF non-zero means set the value in buffer BUF instead of the
1022 current buffer. This only plays a role for per-buffer variables. */
1025 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
1027 switch (XFWDTYPE (valcontents
))
1030 CHECK_NUMBER (newval
);
1031 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1035 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1039 *XOBJFWD (valcontents
)->objvar
= newval
;
1041 /* If this variable is a default for something stored
1042 in the buffer itself, such as default-fill-column,
1043 find the buffers that don't have local values for it
1045 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1046 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1048 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1049 - (char *) &buffer_defaults
);
1050 int idx
= PER_BUFFER_IDX (offset
);
1052 Lisp_Object tail
, buf
;
1057 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1059 struct buffer
*b
= XBUFFER (buf
);
1061 if (! PER_BUFFER_VALUE_P (b
, idx
))
1062 set_per_buffer_value (b
, offset
, newval
);
1067 case Lisp_Fwd_Buffer_Obj
:
1069 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1070 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1074 if (SYMBOLP (predicate
))
1078 if ((prop
= Fget (predicate
, Qchoice
), !NILP (prop
)))
1080 if (NILP (Fmemq (newval
, prop
)))
1081 wrong_choice (prop
, newval
);
1083 else if ((prop
= Fget (predicate
, Qrange
), !NILP (prop
)))
1085 Lisp_Object min
= XCAR (prop
), max
= XCDR (prop
);
1087 if (!NUMBERP (newval
)
1088 || !NILP (arithcompare (newval
, min
, ARITH_LESS
))
1089 || !NILP (arithcompare (newval
, max
, ARITH_GRTR
)))
1090 wrong_range (min
, max
, newval
);
1092 else if (FUNCTIONP (predicate
))
1094 if (NILP (call1 (predicate
, newval
)))
1095 wrong_type_argument (predicate
, newval
);
1100 buf
= current_buffer
;
1101 set_per_buffer_value (buf
, offset
, newval
);
1105 case Lisp_Fwd_Kboard_Obj
:
1107 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1108 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1109 *(Lisp_Object
*) p
= newval
;
1114 emacs_abort (); /* goto def; */
1118 /* Set up SYMBOL to refer to its global binding. This makes it safe
1119 to alter the status of other bindings. BEWARE: this may be called
1120 during the mark phase of GC, where we assume that Lisp_Object slots
1121 of BLV are marked after this function has changed them. */
1124 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1126 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1128 /* Unload the previously loaded binding. */
1130 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1132 /* Select the global binding in the symbol. */
1133 set_blv_valcell (blv
, blv
->defcell
);
1135 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1137 /* Indicate that the global binding is set up now. */
1138 set_blv_where (blv
, Qnil
);
1139 set_blv_found (blv
, 0);
1142 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1143 VALCONTENTS is the contents of its value cell,
1144 which points to a struct Lisp_Buffer_Local_Value.
1146 Return the value forwarded one step past the buffer-local stage.
1147 This could be another forwarding pointer. */
1150 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1152 register Lisp_Object tem1
;
1154 eassert (blv
== SYMBOL_BLV (symbol
));
1159 || (blv
->frame_local
1160 ? !EQ (selected_frame
, tem1
)
1161 : current_buffer
!= XBUFFER (tem1
)))
1164 /* Unload the previously loaded binding. */
1165 tem1
= blv
->valcell
;
1167 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1168 /* Choose the new binding. */
1171 XSETSYMBOL (var
, symbol
);
1172 if (blv
->frame_local
)
1174 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1175 set_blv_where (blv
, selected_frame
);
1179 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1180 set_blv_where (blv
, Fcurrent_buffer ());
1183 if (!(blv
->found
= !NILP (tem1
)))
1184 tem1
= blv
->defcell
;
1186 /* Load the new binding. */
1187 set_blv_valcell (blv
, tem1
);
1189 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1193 /* Find the value of a symbol, returning Qunbound if it's not bound.
1194 This is helpful for code which just wants to get a variable's value
1195 if it has one, without signaling an error.
1196 Note that it must not be possible to quit
1197 within this function. Great care is required for this. */
1200 find_symbol_value (Lisp_Object symbol
)
1202 struct Lisp_Symbol
*sym
;
1204 CHECK_SYMBOL (symbol
);
1205 sym
= XSYMBOL (symbol
);
1208 switch (sym
->redirect
)
1210 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1211 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1212 case SYMBOL_LOCALIZED
:
1214 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1215 swap_in_symval_forwarding (sym
, blv
);
1216 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1219 case SYMBOL_FORWARDED
:
1220 return do_symval_forwarding (SYMBOL_FWD (sym
));
1221 default: emacs_abort ();
1225 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1226 doc
: /* Return SYMBOL's value. Error if that is void.
1227 Note that if `lexical-binding' is in effect, this returns the
1228 global value outside of any lexical scope. */)
1229 (Lisp_Object symbol
)
1233 val
= find_symbol_value (symbol
);
1234 if (!EQ (val
, Qunbound
))
1237 xsignal1 (Qvoid_variable
, symbol
);
1240 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1241 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1242 (register Lisp_Object symbol
, Lisp_Object newval
)
1244 set_internal (symbol
, newval
, Qnil
, 0);
1248 /* Store the value NEWVAL into SYMBOL.
1249 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1250 (nil stands for the current buffer/frame).
1252 If BINDFLAG is false, then if this symbol is supposed to become
1253 local in every buffer where it is set, then we make it local.
1254 If BINDFLAG is true, we don't do that. */
1257 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1260 bool voide
= EQ (newval
, Qunbound
);
1261 struct Lisp_Symbol
*sym
;
1264 /* If restoring in a dead buffer, do nothing. */
1265 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1268 CHECK_SYMBOL (symbol
);
1269 if (SYMBOL_CONSTANT_P (symbol
))
1271 if (NILP (Fkeywordp (symbol
))
1272 || !EQ (newval
, Fsymbol_value (symbol
)))
1273 xsignal1 (Qsetting_constant
, symbol
);
1275 /* Allow setting keywords to their own value. */
1279 sym
= XSYMBOL (symbol
);
1282 switch (sym
->redirect
)
1284 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1285 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1286 case SYMBOL_LOCALIZED
:
1288 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1291 if (blv
->frame_local
)
1292 where
= selected_frame
;
1294 XSETBUFFER (where
, current_buffer
);
1296 /* If the current buffer is not the buffer whose binding is
1297 loaded, or if there may be frame-local bindings and the frame
1298 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1299 the default binding is loaded, the loaded binding may be the
1301 if (!EQ (blv
->where
, where
)
1302 /* Also unload a global binding (if the var is local_if_set). */
1303 || (EQ (blv
->valcell
, blv
->defcell
)))
1305 /* The currently loaded binding is not necessarily valid.
1306 We need to unload it, and choose a new binding. */
1308 /* Write out `realvalue' to the old loaded binding. */
1310 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1312 /* Find the new binding. */
1313 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1314 tem1
= assq_no_quit (symbol
,
1316 ? XFRAME (where
)->param_alist
1317 : BVAR (XBUFFER (where
), local_var_alist
)));
1318 set_blv_where (blv
, where
);
1323 /* This buffer still sees the default value. */
1325 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1326 or if this is `let' rather than `set',
1327 make CURRENT-ALIST-ELEMENT point to itself,
1328 indicating that we're seeing the default value.
1329 Likewise if the variable has been let-bound
1330 in the current buffer. */
1331 if (bindflag
|| !blv
->local_if_set
1332 || let_shadows_buffer_binding_p (sym
))
1335 tem1
= blv
->defcell
;
1337 /* If it's a local_if_set, being set not bound,
1338 and we're not within a let that was made for this buffer,
1339 create a new buffer-local binding for the variable.
1340 That means, give this buffer a new assoc for a local value
1341 and load that binding. */
1344 /* local_if_set is only supported for buffer-local
1345 bindings, not for frame-local bindings. */
1346 eassert (!blv
->frame_local
);
1347 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1348 bset_local_var_alist
1350 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1354 /* Record which binding is now loaded. */
1355 set_blv_valcell (blv
, tem1
);
1358 /* Store the new value in the cons cell. */
1359 set_blv_value (blv
, newval
);
1364 /* If storing void (making the symbol void), forward only through
1365 buffer-local indicator, not through Lisp_Objfwd, etc. */
1368 store_symval_forwarding (blv
->fwd
, newval
,
1370 ? XBUFFER (where
) : current_buffer
);
1374 case SYMBOL_FORWARDED
:
1377 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1378 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1379 if (BUFFER_OBJFWDP (innercontents
))
1381 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1382 int idx
= PER_BUFFER_IDX (offset
);
1385 && !let_shadows_buffer_binding_p (sym
))
1386 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1390 { /* If storing void (making the symbol void), forward only through
1391 buffer-local indicator, not through Lisp_Objfwd, etc. */
1392 sym
->redirect
= SYMBOL_PLAINVAL
;
1393 SET_SYMBOL_VAL (sym
, newval
);
1396 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1399 default: emacs_abort ();
1404 /* Access or set a buffer-local symbol's default value. */
1406 /* Return the default value of SYMBOL, but don't check for voidness.
1407 Return Qunbound if it is void. */
1410 default_value (Lisp_Object symbol
)
1412 struct Lisp_Symbol
*sym
;
1414 CHECK_SYMBOL (symbol
);
1415 sym
= XSYMBOL (symbol
);
1418 switch (sym
->redirect
)
1420 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1421 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1422 case SYMBOL_LOCALIZED
:
1424 /* If var is set up for a buffer that lacks a local value for it,
1425 the current value is nominally the default value.
1426 But the `realvalue' slot may be more up to date, since
1427 ordinary setq stores just that slot. So use that. */
1428 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1429 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1430 return do_symval_forwarding (blv
->fwd
);
1432 return XCDR (blv
->defcell
);
1434 case SYMBOL_FORWARDED
:
1436 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1438 /* For a built-in buffer-local variable, get the default value
1439 rather than letting do_symval_forwarding get the current value. */
1440 if (BUFFER_OBJFWDP (valcontents
))
1442 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1443 if (PER_BUFFER_IDX (offset
) != 0)
1444 return per_buffer_default (offset
);
1447 /* For other variables, get the current value. */
1448 return do_symval_forwarding (valcontents
);
1450 default: emacs_abort ();
1454 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1455 doc
: /* Return t if SYMBOL has a non-void default value.
1456 This is the value that is seen in buffers that do not have their own values
1457 for this variable. */)
1458 (Lisp_Object symbol
)
1460 register Lisp_Object value
;
1462 value
= default_value (symbol
);
1463 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1466 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1467 doc
: /* Return SYMBOL's default value.
1468 This is the value that is seen in buffers that do not have their own values
1469 for this variable. The default value is meaningful for variables with
1470 local bindings in certain buffers. */)
1471 (Lisp_Object symbol
)
1473 Lisp_Object value
= default_value (symbol
);
1474 if (!EQ (value
, Qunbound
))
1477 xsignal1 (Qvoid_variable
, symbol
);
1480 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1481 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1482 The default value is seen in buffers that do not have their own values
1483 for this variable. */)
1484 (Lisp_Object symbol
, Lisp_Object value
)
1486 struct Lisp_Symbol
*sym
;
1488 CHECK_SYMBOL (symbol
);
1489 if (SYMBOL_CONSTANT_P (symbol
))
1491 if (NILP (Fkeywordp (symbol
))
1492 || !EQ (value
, Fdefault_value (symbol
)))
1493 xsignal1 (Qsetting_constant
, symbol
);
1495 /* Allow setting keywords to their own value. */
1498 sym
= XSYMBOL (symbol
);
1501 switch (sym
->redirect
)
1503 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1504 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1505 case SYMBOL_LOCALIZED
:
1507 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1509 /* Store new value into the DEFAULT-VALUE slot. */
1510 XSETCDR (blv
->defcell
, value
);
1512 /* If the default binding is now loaded, set the REALVALUE slot too. */
1513 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1514 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1517 case SYMBOL_FORWARDED
:
1519 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1521 /* Handle variables like case-fold-search that have special slots
1523 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1524 if (BUFFER_OBJFWDP (valcontents
))
1526 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1527 int idx
= PER_BUFFER_IDX (offset
);
1529 set_per_buffer_default (offset
, value
);
1531 /* If this variable is not always local in all buffers,
1532 set it in the buffers that don't nominally have a local value. */
1538 if (!PER_BUFFER_VALUE_P (b
, idx
))
1539 set_per_buffer_value (b
, offset
, value
);
1544 return Fset (symbol
, value
);
1546 default: emacs_abort ();
1550 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1551 doc
: /* Set the default value of variable VAR to VALUE.
1552 VAR, the variable name, is literal (not evaluated);
1553 VALUE is an expression: it is evaluated and its value returned.
1554 The default value of a variable is seen in buffers
1555 that do not have their own values for the variable.
1557 More generally, you can use multiple variables and values, as in
1558 (setq-default VAR VALUE VAR VALUE...)
1559 This sets each VAR's default value to the corresponding VALUE.
1560 The VALUE for the Nth VAR can refer to the new default values
1562 usage: (setq-default [VAR VALUE]...) */)
1565 Lisp_Object args_left
, symbol
, val
;
1566 struct gcpro gcpro1
;
1568 args_left
= val
= args
;
1571 while (CONSP (args_left
))
1573 val
= eval_sub (Fcar (XCDR (args_left
)));
1574 symbol
= XCAR (args_left
);
1575 Fset_default (symbol
, val
);
1576 args_left
= Fcdr (XCDR (args_left
));
1583 /* Lisp functions for creating and removing buffer-local variables. */
1588 union Lisp_Fwd
*fwd
;
1591 static struct Lisp_Buffer_Local_Value
*
1592 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1593 union Lisp_Val_Fwd valcontents
)
1595 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1599 XSETSYMBOL (symbol
, sym
);
1600 tem
= Fcons (symbol
, (forwarded
1601 ? do_symval_forwarding (valcontents
.fwd
)
1602 : valcontents
.value
));
1604 /* Buffer_Local_Values cannot have as realval a buffer-local
1605 or keyboard-local forwarding. */
1606 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1607 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1608 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1609 set_blv_where (blv
, Qnil
);
1610 blv
->frame_local
= 0;
1611 blv
->local_if_set
= 0;
1612 set_blv_defcell (blv
, tem
);
1613 set_blv_valcell (blv
, tem
);
1614 set_blv_found (blv
, 0);
1618 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1619 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1620 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1621 At any time, the value for the current buffer is in effect,
1622 unless the variable has never been set in this buffer,
1623 in which case the default value is in effect.
1624 Note that binding the variable with `let', or setting it while
1625 a `let'-style binding made in this buffer is in effect,
1626 does not make the variable buffer-local. Return VARIABLE.
1628 This globally affects all uses of this variable, so it belongs together with
1629 the variable declaration, rather than with its uses (if you just want to make
1630 a variable local to the current buffer for one particular use, use
1631 `make-local-variable'). Buffer-local bindings are normally cleared
1632 while setting up a new major mode, unless they have a `permanent-local'
1635 The function `default-value' gets the default value and `set-default' sets it. */)
1636 (register Lisp_Object variable
)
1638 struct Lisp_Symbol
*sym
;
1639 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1640 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1641 bool forwarded
IF_LINT (= 0);
1643 CHECK_SYMBOL (variable
);
1644 sym
= XSYMBOL (variable
);
1647 switch (sym
->redirect
)
1649 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1650 case SYMBOL_PLAINVAL
:
1651 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1652 if (EQ (valcontents
.value
, Qunbound
))
1653 valcontents
.value
= Qnil
;
1655 case SYMBOL_LOCALIZED
:
1656 blv
= SYMBOL_BLV (sym
);
1657 if (blv
->frame_local
)
1658 error ("Symbol %s may not be buffer-local",
1659 SDATA (SYMBOL_NAME (variable
)));
1661 case SYMBOL_FORWARDED
:
1662 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1663 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1664 error ("Symbol %s may not be buffer-local",
1665 SDATA (SYMBOL_NAME (variable
)));
1666 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1669 default: emacs_abort ();
1673 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1677 blv
= make_blv (sym
, forwarded
, valcontents
);
1678 sym
->redirect
= SYMBOL_LOCALIZED
;
1679 SET_SYMBOL_BLV (sym
, blv
);
1682 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1683 if (let_shadows_global_binding_p (symbol
))
1684 message ("Making %s buffer-local while let-bound!",
1685 SDATA (SYMBOL_NAME (variable
)));
1689 blv
->local_if_set
= 1;
1693 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1694 1, 1, "vMake Local Variable: ",
1695 doc
: /* Make VARIABLE have a separate value in the current buffer.
1696 Other buffers will continue to share a common default value.
1697 \(The buffer-local value of VARIABLE starts out as the same value
1698 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1701 If the variable is already arranged to become local when set,
1702 this function causes a local value to exist for this buffer,
1703 just as setting the variable would do.
1705 This function returns VARIABLE, and therefore
1706 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1709 See also `make-variable-buffer-local'.
1711 Do not use `make-local-variable' to make a hook variable buffer-local.
1712 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1713 (Lisp_Object variable
)
1716 bool forwarded
IF_LINT (= 0);
1717 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1718 struct Lisp_Symbol
*sym
;
1719 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1721 CHECK_SYMBOL (variable
);
1722 sym
= XSYMBOL (variable
);
1725 switch (sym
->redirect
)
1727 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1728 case SYMBOL_PLAINVAL
:
1729 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1730 case SYMBOL_LOCALIZED
:
1731 blv
= SYMBOL_BLV (sym
);
1732 if (blv
->frame_local
)
1733 error ("Symbol %s may not be buffer-local",
1734 SDATA (SYMBOL_NAME (variable
)));
1736 case SYMBOL_FORWARDED
:
1737 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1738 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1739 error ("Symbol %s may not be buffer-local",
1740 SDATA (SYMBOL_NAME (variable
)));
1742 default: emacs_abort ();
1746 error ("Symbol %s may not be buffer-local",
1747 SDATA (SYMBOL_NAME (variable
)));
1749 if (blv
? blv
->local_if_set
1750 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1752 tem
= Fboundp (variable
);
1753 /* Make sure the symbol has a local value in this particular buffer,
1754 by setting it to the same value it already has. */
1755 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1760 blv
= make_blv (sym
, forwarded
, valcontents
);
1761 sym
->redirect
= SYMBOL_LOCALIZED
;
1762 SET_SYMBOL_BLV (sym
, blv
);
1765 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1766 if (let_shadows_global_binding_p (symbol
))
1767 message ("Making %s local to %s while let-bound!",
1768 SDATA (SYMBOL_NAME (variable
)),
1769 SDATA (BVAR (current_buffer
, name
)));
1773 /* Make sure this buffer has its own value of symbol. */
1774 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1775 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1778 if (let_shadows_buffer_binding_p (sym
))
1779 message ("Making %s buffer-local while locally let-bound!",
1780 SDATA (SYMBOL_NAME (variable
)));
1782 /* Swap out any local binding for some other buffer, and make
1783 sure the current value is permanently recorded, if it's the
1785 find_symbol_value (variable
);
1787 bset_local_var_alist
1789 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1790 BVAR (current_buffer
, local_var_alist
)));
1792 /* Make sure symbol does not think it is set up for this buffer;
1793 force it to look once again for this buffer's value. */
1794 if (current_buffer
== XBUFFER (blv
->where
))
1795 set_blv_where (blv
, Qnil
);
1796 set_blv_found (blv
, 0);
1799 /* If the symbol forwards into a C variable, then load the binding
1800 for this buffer now. If C code modifies the variable before we
1801 load the binding in, then that new value will clobber the default
1802 binding the next time we unload it. */
1804 swap_in_symval_forwarding (sym
, blv
);
1809 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1810 1, 1, "vKill Local Variable: ",
1811 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1812 From now on the default value will apply in this buffer. Return VARIABLE. */)
1813 (register Lisp_Object variable
)
1815 register Lisp_Object tem
;
1816 struct Lisp_Buffer_Local_Value
*blv
;
1817 struct Lisp_Symbol
*sym
;
1819 CHECK_SYMBOL (variable
);
1820 sym
= XSYMBOL (variable
);
1823 switch (sym
->redirect
)
1825 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1826 case SYMBOL_PLAINVAL
: return variable
;
1827 case SYMBOL_FORWARDED
:
1829 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1830 if (BUFFER_OBJFWDP (valcontents
))
1832 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1833 int idx
= PER_BUFFER_IDX (offset
);
1837 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1838 set_per_buffer_value (current_buffer
, offset
,
1839 per_buffer_default (offset
));
1844 case SYMBOL_LOCALIZED
:
1845 blv
= SYMBOL_BLV (sym
);
1846 if (blv
->frame_local
)
1849 default: emacs_abort ();
1852 /* Get rid of this buffer's alist element, if any. */
1853 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1854 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1856 bset_local_var_alist
1858 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1860 /* If the symbol is set up with the current buffer's binding
1861 loaded, recompute its value. We have to do it now, or else
1862 forwarded objects won't work right. */
1864 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1865 if (EQ (buf
, blv
->where
))
1867 set_blv_where (blv
, Qnil
);
1869 find_symbol_value (variable
);
1876 /* Lisp functions for creating and removing buffer-local variables. */
1878 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1879 when/if this is removed. */
1881 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1882 1, 1, "vMake Variable Frame Local: ",
1883 doc
: /* Enable VARIABLE to have frame-local bindings.
1884 This does not create any frame-local bindings for VARIABLE,
1885 it just makes them possible.
1887 A frame-local binding is actually a frame parameter value.
1888 If a frame F has a value for the frame parameter named VARIABLE,
1889 that also acts as a frame-local binding for VARIABLE in F--
1890 provided this function has been called to enable VARIABLE
1891 to have frame-local bindings at all.
1893 The only way to create a frame-local binding for VARIABLE in a frame
1894 is to set the VARIABLE frame parameter of that frame. See
1895 `modify-frame-parameters' for how to set frame parameters.
1897 Note that since Emacs 23.1, variables cannot be both buffer-local and
1898 frame-local any more (buffer-local bindings used to take precedence over
1899 frame-local bindings). */)
1900 (Lisp_Object variable
)
1903 union Lisp_Val_Fwd valcontents
;
1904 struct Lisp_Symbol
*sym
;
1905 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1907 CHECK_SYMBOL (variable
);
1908 sym
= XSYMBOL (variable
);
1911 switch (sym
->redirect
)
1913 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1914 case SYMBOL_PLAINVAL
:
1915 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1916 if (EQ (valcontents
.value
, Qunbound
))
1917 valcontents
.value
= Qnil
;
1919 case SYMBOL_LOCALIZED
:
1920 if (SYMBOL_BLV (sym
)->frame_local
)
1923 error ("Symbol %s may not be frame-local",
1924 SDATA (SYMBOL_NAME (variable
)));
1925 case SYMBOL_FORWARDED
:
1926 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1927 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1928 error ("Symbol %s may not be frame-local",
1929 SDATA (SYMBOL_NAME (variable
)));
1931 default: emacs_abort ();
1935 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1937 blv
= make_blv (sym
, forwarded
, valcontents
);
1938 blv
->frame_local
= 1;
1939 sym
->redirect
= SYMBOL_LOCALIZED
;
1940 SET_SYMBOL_BLV (sym
, blv
);
1943 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1944 if (let_shadows_global_binding_p (symbol
))
1945 message ("Making %s frame-local while let-bound!",
1946 SDATA (SYMBOL_NAME (variable
)));
1951 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1953 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1954 BUFFER defaults to the current buffer. */)
1955 (Lisp_Object variable
, Lisp_Object buffer
)
1957 struct buffer
*buf
= decode_buffer (buffer
);
1958 struct Lisp_Symbol
*sym
;
1960 CHECK_SYMBOL (variable
);
1961 sym
= XSYMBOL (variable
);
1964 switch (sym
->redirect
)
1966 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1967 case SYMBOL_PLAINVAL
: return Qnil
;
1968 case SYMBOL_LOCALIZED
:
1970 Lisp_Object tail
, elt
, tmp
;
1971 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1972 XSETBUFFER (tmp
, buf
);
1973 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1975 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1976 return blv_found (blv
) ? Qt
: Qnil
;
1978 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1981 if (EQ (variable
, XCAR (elt
)))
1983 eassert (!blv
->frame_local
);
1989 case SYMBOL_FORWARDED
:
1991 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1992 if (BUFFER_OBJFWDP (valcontents
))
1994 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1995 int idx
= PER_BUFFER_IDX (offset
);
1996 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2001 default: emacs_abort ();
2005 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2007 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
2008 BUFFER defaults to the current buffer.
2010 More precisely, return non-nil if either VARIABLE already has a local
2011 value in BUFFER, or if VARIABLE is automatically buffer-local (see
2012 `make-variable-buffer-local'). */)
2013 (register Lisp_Object variable
, Lisp_Object buffer
)
2015 struct Lisp_Symbol
*sym
;
2017 CHECK_SYMBOL (variable
);
2018 sym
= XSYMBOL (variable
);
2021 switch (sym
->redirect
)
2023 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2024 case SYMBOL_PLAINVAL
: return Qnil
;
2025 case SYMBOL_LOCALIZED
:
2027 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2028 if (blv
->local_if_set
)
2030 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2031 return Flocal_variable_p (variable
, buffer
);
2033 case SYMBOL_FORWARDED
:
2034 /* All BUFFER_OBJFWD slots become local if they are set. */
2035 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2036 default: emacs_abort ();
2040 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2042 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2043 If the current binding is buffer-local, the value is the current buffer.
2044 If the current binding is frame-local, the value is the selected frame.
2045 If the current binding is global (the default), the value is nil. */)
2046 (register Lisp_Object variable
)
2048 struct Lisp_Symbol
*sym
;
2050 CHECK_SYMBOL (variable
);
2051 sym
= XSYMBOL (variable
);
2053 /* Make sure the current binding is actually swapped in. */
2054 find_symbol_value (variable
);
2057 switch (sym
->redirect
)
2059 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2060 case SYMBOL_PLAINVAL
: return Qnil
;
2061 case SYMBOL_FORWARDED
:
2063 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2064 if (KBOARD_OBJFWDP (valcontents
))
2065 return Fframe_terminal (selected_frame
);
2066 else if (!BUFFER_OBJFWDP (valcontents
))
2070 case SYMBOL_LOCALIZED
:
2071 /* For a local variable, record both the symbol and which
2072 buffer's or frame's value we are saving. */
2073 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2074 return Fcurrent_buffer ();
2075 else if (sym
->redirect
== SYMBOL_LOCALIZED
2076 && blv_found (SYMBOL_BLV (sym
)))
2077 return SYMBOL_BLV (sym
)->where
;
2080 default: emacs_abort ();
2084 /* This code is disabled now that we use the selected frame to return
2085 keyboard-local-values. */
2087 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2089 DEFUN ("terminal-local-value", Fterminal_local_value
,
2090 Sterminal_local_value
, 2, 2, 0,
2091 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2092 If SYMBOL is not a terminal-local variable, then return its normal
2093 value, like `symbol-value'.
2095 TERMINAL may be a terminal object, a frame, or nil (meaning the
2096 selected frame's terminal device). */)
2097 (Lisp_Object symbol
, Lisp_Object terminal
)
2100 struct terminal
*t
= get_terminal (terminal
, 1);
2101 push_kboard (t
->kboard
);
2102 result
= Fsymbol_value (symbol
);
2107 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2108 Sset_terminal_local_value
, 3, 3, 0,
2109 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2110 If VARIABLE is not a terminal-local variable, then set its normal
2111 binding, like `set'.
2113 TERMINAL may be a terminal object, a frame, or nil (meaning the
2114 selected frame's terminal device). */)
2115 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2118 struct terminal
*t
= get_terminal (terminal
, 1);
2119 push_kboard (d
->kboard
);
2120 result
= Fset (symbol
, value
);
2126 /* Find the function at the end of a chain of symbol function indirections. */
2128 /* If OBJECT is a symbol, find the end of its function chain and
2129 return the value found there. If OBJECT is not a symbol, just
2130 return it. If there is a cycle in the function chain, signal a
2131 cyclic-function-indirection error.
2133 This is like Findirect_function, except that it doesn't signal an
2134 error if the chain ends up unbound. */
2136 indirect_function (register Lisp_Object object
)
2138 Lisp_Object tortoise
, hare
;
2140 hare
= tortoise
= object
;
2144 if (!SYMBOLP (hare
) || NILP (hare
))
2146 hare
= XSYMBOL (hare
)->function
;
2147 if (!SYMBOLP (hare
) || NILP (hare
))
2149 hare
= XSYMBOL (hare
)->function
;
2151 tortoise
= XSYMBOL (tortoise
)->function
;
2153 if (EQ (hare
, tortoise
))
2154 xsignal1 (Qcyclic_function_indirection
, object
);
2160 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2161 doc
: /* Return the function at the end of OBJECT's function chain.
2162 If OBJECT is not a symbol, just return it. Otherwise, follow all
2163 function indirections to find the final function binding and return it.
2164 If the final symbol in the chain is unbound, signal a void-function error.
2165 Optional arg NOERROR non-nil means to return nil instead of signaling.
2166 Signal a cyclic-function-indirection error if there is a loop in the
2167 function chain of symbols. */)
2168 (register Lisp_Object object
, Lisp_Object noerror
)
2172 /* Optimize for no indirection. */
2174 if (SYMBOLP (result
) && !NILP (result
)
2175 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2176 result
= indirect_function (result
);
2181 xsignal1 (Qvoid_function
, object
);
2186 /* Extract and set vector and string elements. */
2188 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2189 doc
: /* Return the element of ARRAY at index IDX.
2190 ARRAY may be a vector, a string, a char-table, a bool-vector,
2191 or a byte-code object. IDX starts at 0. */)
2192 (register Lisp_Object array
, Lisp_Object idx
)
2194 register EMACS_INT idxval
;
2197 idxval
= XINT (idx
);
2198 if (STRINGP (array
))
2201 ptrdiff_t idxval_byte
;
2203 if (idxval
< 0 || idxval
>= SCHARS (array
))
2204 args_out_of_range (array
, idx
);
2205 if (! STRING_MULTIBYTE (array
))
2206 return make_number ((unsigned char) SREF (array
, idxval
));
2207 idxval_byte
= string_char_to_byte (array
, idxval
);
2209 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2210 return make_number (c
);
2212 else if (BOOL_VECTOR_P (array
))
2214 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2215 args_out_of_range (array
, idx
);
2216 return bool_vector_ref (array
, idxval
);
2218 else if (CHAR_TABLE_P (array
))
2220 CHECK_CHARACTER (idx
);
2221 return CHAR_TABLE_REF (array
, idxval
);
2226 if (VECTORP (array
))
2227 size
= ASIZE (array
);
2228 else if (COMPILEDP (array
))
2229 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2231 wrong_type_argument (Qarrayp
, array
);
2233 if (idxval
< 0 || idxval
>= size
)
2234 args_out_of_range (array
, idx
);
2235 return AREF (array
, idxval
);
2239 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2240 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2241 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2242 bool-vector. IDX starts at 0. */)
2243 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2245 register EMACS_INT idxval
;
2248 idxval
= XINT (idx
);
2249 CHECK_ARRAY (array
, Qarrayp
);
2250 CHECK_IMPURE (array
);
2252 if (VECTORP (array
))
2254 if (idxval
< 0 || idxval
>= ASIZE (array
))
2255 args_out_of_range (array
, idx
);
2256 ASET (array
, idxval
, newelt
);
2258 else if (BOOL_VECTOR_P (array
))
2260 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2261 args_out_of_range (array
, idx
);
2262 bool_vector_set (array
, idxval
, !NILP (newelt
));
2264 else if (CHAR_TABLE_P (array
))
2266 CHECK_CHARACTER (idx
);
2267 CHAR_TABLE_SET (array
, idxval
, newelt
);
2273 if (idxval
< 0 || idxval
>= SCHARS (array
))
2274 args_out_of_range (array
, idx
);
2275 CHECK_CHARACTER (newelt
);
2276 c
= XFASTINT (newelt
);
2278 if (STRING_MULTIBYTE (array
))
2280 ptrdiff_t idxval_byte
, nbytes
;
2281 int prev_bytes
, new_bytes
;
2282 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2284 nbytes
= SBYTES (array
);
2285 idxval_byte
= string_char_to_byte (array
, idxval
);
2286 p1
= SDATA (array
) + idxval_byte
;
2287 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2288 new_bytes
= CHAR_STRING (c
, p0
);
2289 if (prev_bytes
!= new_bytes
)
2291 /* We must relocate the string data. */
2292 ptrdiff_t nchars
= SCHARS (array
);
2294 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2296 memcpy (str
, SDATA (array
), nbytes
);
2297 allocate_string_data (XSTRING (array
), nchars
,
2298 nbytes
+ new_bytes
- prev_bytes
);
2299 memcpy (SDATA (array
), str
, idxval_byte
);
2300 p1
= SDATA (array
) + idxval_byte
;
2301 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2302 nbytes
- (idxval_byte
+ prev_bytes
));
2304 clear_string_char_byte_cache ();
2311 if (! SINGLE_BYTE_CHAR_P (c
))
2315 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2316 if (SREF (array
, i
) >= 0x80)
2317 args_out_of_range (array
, newelt
);
2318 /* ARRAY is an ASCII string. Convert it to a multibyte
2319 string, and try `aset' again. */
2320 STRING_SET_MULTIBYTE (array
);
2321 return Faset (array
, idx
, newelt
);
2323 SSET (array
, idxval
, c
);
2330 /* Arithmetic functions */
2333 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2335 double f1
= 0, f2
= 0;
2338 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2339 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2341 if (FLOATP (num1
) || FLOATP (num2
))
2344 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2345 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2351 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2355 case ARITH_NOTEQUAL
:
2356 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2361 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2365 case ARITH_LESS_OR_EQUAL
:
2366 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2371 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2375 case ARITH_GRTR_OR_EQUAL
:
2376 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2386 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2387 enum Arith_Comparison comparison
)
2390 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2392 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2398 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2399 doc
: /* Return t if args, all numbers or markers, are equal.
2400 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2401 (ptrdiff_t nargs
, Lisp_Object
*args
)
2403 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2406 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2407 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2408 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2409 (ptrdiff_t nargs
, Lisp_Object
*args
)
2411 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2414 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2415 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2416 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2417 (ptrdiff_t nargs
, Lisp_Object
*args
)
2419 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2422 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2423 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2424 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2425 (ptrdiff_t nargs
, Lisp_Object
*args
)
2427 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2430 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2431 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2432 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2433 (ptrdiff_t nargs
, Lisp_Object
*args
)
2435 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2438 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2439 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2440 (register Lisp_Object num1
, Lisp_Object num2
)
2442 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2445 /* Convert the cons-of-integers, integer, or float value C to an
2446 unsigned value with maximum value MAX. Signal an error if C does not
2447 have a valid format or is out of range. */
2449 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2452 uintmax_t val
IF_LINT (= 0);
2455 valid
= 0 <= XINT (c
);
2458 else if (FLOATP (c
))
2460 double d
= XFLOAT_DATA (c
);
2462 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2468 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2470 uintmax_t top
= XFASTINT (XCAR (c
));
2471 Lisp_Object rest
= XCDR (c
);
2472 if (top
<= UINTMAX_MAX
>> 24 >> 16
2474 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2475 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2477 uintmax_t mid
= XFASTINT (XCAR (rest
));
2478 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2481 else if (top
<= UINTMAX_MAX
>> 16)
2485 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2487 val
= top
<< 16 | XFASTINT (rest
);
2493 if (! (valid
&& val
<= max
))
2494 error ("Not an in-range integer, float, or cons of integers");
2498 /* Convert the cons-of-integers, integer, or float value C to a signed
2499 value with extrema MIN and MAX. Signal an error if C does not have
2500 a valid format or is out of range. */
2502 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2505 intmax_t val
IF_LINT (= 0);
2511 else if (FLOATP (c
))
2513 double d
= XFLOAT_DATA (c
);
2515 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2521 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2523 intmax_t top
= XINT (XCAR (c
));
2524 Lisp_Object rest
= XCDR (c
);
2525 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2527 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2528 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2530 intmax_t mid
= XFASTINT (XCAR (rest
));
2531 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2534 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2538 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2540 val
= top
<< 16 | XFASTINT (rest
);
2546 if (! (valid
&& min
<= val
&& val
<= max
))
2547 error ("Not an in-range integer, float, or cons of integers");
2551 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2552 doc
: /* Return the decimal representation of NUMBER as a string.
2553 Uses a minus sign if negative.
2554 NUMBER may be an integer or a floating point number. */)
2555 (Lisp_Object number
)
2557 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2560 CHECK_NUMBER_OR_FLOAT (number
);
2562 if (FLOATP (number
))
2563 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2565 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2567 return make_unibyte_string (buffer
, len
);
2570 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2571 doc
: /* Parse STRING as a decimal number and return the number.
2572 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2573 STRING cannot be parsed as an integer or floating point number.
2575 If BASE, interpret STRING as a number in that base. If BASE isn't
2576 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2577 If the base used is not 10, STRING is always parsed as an integer. */)
2578 (register Lisp_Object string
, Lisp_Object base
)
2584 CHECK_STRING (string
);
2590 CHECK_NUMBER (base
);
2591 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2592 xsignal1 (Qargs_out_of_range
, base
);
2596 p
= SSDATA (string
);
2597 while (*p
== ' ' || *p
== '\t')
2600 val
= string_to_number (p
, b
, 1);
2601 return NILP (val
) ? make_number (0) : val
;
2617 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2618 ptrdiff_t, Lisp_Object
*);
2620 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2623 ptrdiff_t argnum
, ok_args
;
2624 EMACS_INT accum
= 0;
2625 EMACS_INT next
, ok_accum
;
2646 for (argnum
= 0; argnum
< nargs
; argnum
++)
2654 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2656 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2659 return float_arith_driver (ok_accum
, ok_args
, code
,
2662 next
= XINT (args
[argnum
]);
2666 if (INT_ADD_OVERFLOW (accum
, next
))
2674 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2679 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2682 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2684 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2686 accum
= ab
& INTMASK
;
2697 xsignal0 (Qarith_error
);
2711 if (!argnum
|| next
> accum
)
2715 if (!argnum
|| next
< accum
)
2721 XSETINT (val
, accum
);
2726 #define isnan(x) ((x) != (x))
2729 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2730 ptrdiff_t nargs
, Lisp_Object
*args
)
2732 register Lisp_Object val
;
2735 for (; argnum
< nargs
; argnum
++)
2737 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2738 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2742 next
= XFLOAT_DATA (val
);
2746 args
[argnum
] = val
; /* runs into a compiler bug. */
2747 next
= XINT (args
[argnum
]);
2755 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2765 if (! IEEE_FLOATING_POINT
&& next
== 0)
2766 xsignal0 (Qarith_error
);
2773 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2775 if (!argnum
|| isnan (next
) || next
> accum
)
2779 if (!argnum
|| isnan (next
) || next
< accum
)
2785 return make_float (accum
);
2789 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2790 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2791 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2792 (ptrdiff_t nargs
, Lisp_Object
*args
)
2794 return arith_driver (Aadd
, nargs
, args
);
2797 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2798 doc
: /* Negate number or subtract numbers or markers and return the result.
2799 With one arg, negates it. With more than one arg,
2800 subtracts all but the first from the first.
2801 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2802 (ptrdiff_t nargs
, Lisp_Object
*args
)
2804 return arith_driver (Asub
, nargs
, args
);
2807 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2808 doc
: /* Return product of any number of arguments, which are numbers or markers.
2809 usage: (* &rest NUMBERS-OR-MARKERS) */)
2810 (ptrdiff_t nargs
, Lisp_Object
*args
)
2812 return arith_driver (Amult
, nargs
, args
);
2815 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2816 doc
: /* Return first argument divided by all the remaining arguments.
2817 The arguments must be numbers or markers.
2818 usage: (/ DIVIDEND &rest DIVISORS) */)
2819 (ptrdiff_t nargs
, Lisp_Object
*args
)
2822 for (argnum
= 2; argnum
< nargs
; argnum
++)
2823 if (FLOATP (args
[argnum
]))
2824 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2825 return arith_driver (Adiv
, nargs
, args
);
2828 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2829 doc
: /* Return remainder of X divided by Y.
2830 Both must be integers or markers. */)
2831 (register Lisp_Object x
, Lisp_Object y
)
2835 CHECK_NUMBER_COERCE_MARKER (x
);
2836 CHECK_NUMBER_COERCE_MARKER (y
);
2839 xsignal0 (Qarith_error
);
2841 XSETINT (val
, XINT (x
) % XINT (y
));
2845 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2846 doc
: /* Return X modulo Y.
2847 The result falls between zero (inclusive) and Y (exclusive).
2848 Both X and Y must be numbers or markers. */)
2849 (register Lisp_Object x
, Lisp_Object y
)
2854 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2855 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2857 if (FLOATP (x
) || FLOATP (y
))
2858 return fmod_float (x
, y
);
2864 xsignal0 (Qarith_error
);
2868 /* If the "remainder" comes out with the wrong sign, fix it. */
2869 if (i2
< 0 ? i1
> 0 : i1
< 0)
2876 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2877 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2878 The value is always a number; markers are converted to numbers.
2879 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2880 (ptrdiff_t nargs
, Lisp_Object
*args
)
2882 return arith_driver (Amax
, nargs
, args
);
2885 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2886 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2887 The value is always a number; markers are converted to numbers.
2888 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2889 (ptrdiff_t nargs
, Lisp_Object
*args
)
2891 return arith_driver (Amin
, nargs
, args
);
2894 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2895 doc
: /* Return bitwise-and of all the arguments.
2896 Arguments may be integers, or markers converted to integers.
2897 usage: (logand &rest INTS-OR-MARKERS) */)
2898 (ptrdiff_t nargs
, Lisp_Object
*args
)
2900 return arith_driver (Alogand
, nargs
, args
);
2903 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2904 doc
: /* Return bitwise-or of all the arguments.
2905 Arguments may be integers, or markers converted to integers.
2906 usage: (logior &rest INTS-OR-MARKERS) */)
2907 (ptrdiff_t nargs
, Lisp_Object
*args
)
2909 return arith_driver (Alogior
, nargs
, args
);
2912 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2913 doc
: /* Return bitwise-exclusive-or of all the arguments.
2914 Arguments may be integers, or markers converted to integers.
2915 usage: (logxor &rest INTS-OR-MARKERS) */)
2916 (ptrdiff_t nargs
, Lisp_Object
*args
)
2918 return arith_driver (Alogxor
, nargs
, args
);
2921 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2922 doc
: /* Return VALUE with its bits shifted left by COUNT.
2923 If COUNT is negative, shifting is actually to the right.
2924 In this case, the sign bit is duplicated. */)
2925 (register Lisp_Object value
, Lisp_Object count
)
2927 register Lisp_Object val
;
2929 CHECK_NUMBER (value
);
2930 CHECK_NUMBER (count
);
2932 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2934 else if (XINT (count
) > 0)
2935 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2936 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2937 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2939 XSETINT (val
, XINT (value
) >> -XINT (count
));
2943 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2944 doc
: /* Return VALUE with its bits shifted left by COUNT.
2945 If COUNT is negative, shifting is actually to the right.
2946 In this case, zeros are shifted in on the left. */)
2947 (register Lisp_Object value
, Lisp_Object count
)
2949 register Lisp_Object val
;
2951 CHECK_NUMBER (value
);
2952 CHECK_NUMBER (count
);
2954 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2956 else if (XINT (count
) > 0)
2957 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2958 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2961 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2965 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2966 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2967 Markers are converted to integers. */)
2968 (register Lisp_Object number
)
2970 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2972 if (FLOATP (number
))
2973 return (make_float (1.0 + XFLOAT_DATA (number
)));
2975 XSETINT (number
, XINT (number
) + 1);
2979 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2980 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2981 Markers are converted to integers. */)
2982 (register Lisp_Object number
)
2984 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2986 if (FLOATP (number
))
2987 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2989 XSETINT (number
, XINT (number
) - 1);
2993 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2994 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2995 (register Lisp_Object number
)
2997 CHECK_NUMBER (number
);
2998 XSETINT (number
, ~XINT (number
));
3002 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3003 doc
: /* Return the byteorder for the machine.
3004 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3005 lowercase l) for small endian machines. */)
3008 unsigned i
= 0x04030201;
3009 int order
= *(char *)&i
== 1 ? 108 : 66;
3011 return make_number (order
);
3014 /* Because we round up the bool vector allocate size to word_size
3015 units, we can safely read past the "end" of the vector in the
3016 operations below. These extra bits are always zero. */
3019 bool_vector_spare_mask (EMACS_INT nr_bits
)
3021 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
3024 /* Info about unsigned long long, falling back on unsigned long
3025 if unsigned long long is not available. */
3027 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
3028 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
3029 # define ULL_MAX ULLONG_MAX
3031 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
3032 # define ULL_MAX ULONG_MAX
3033 # define count_one_bits_ll count_one_bits_l
3034 # define count_trailing_zeros_ll count_trailing_zeros_l
3037 /* Shift VAL right by the width of an unsigned long long.
3038 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3041 shift_right_ull (bits_word w
)
3043 /* Pacify bogus GCC warning about shift count exceeding type width. */
3044 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3048 /* Return the number of 1 bits in W. */
3051 count_one_bits_word (bits_word w
)
3053 if (BITS_WORD_MAX
<= UINT_MAX
)
3054 return count_one_bits (w
);
3055 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3056 return count_one_bits_l (w
);
3059 int i
= 0, count
= 0;
3060 while (count
+= count_one_bits_ll (w
),
3061 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3062 w
= shift_right_ull (w
);
3067 enum bool_vector_op
{ bool_vector_exclusive_or
,
3069 bool_vector_intersection
,
3070 bool_vector_set_difference
,
3071 bool_vector_subsetp
};
3074 bool_vector_binop_driver (Lisp_Object a
,
3077 enum bool_vector_op op
)
3080 bits_word
*adata
, *bdata
, *destdata
;
3084 CHECK_BOOL_VECTOR (a
);
3085 CHECK_BOOL_VECTOR (b
);
3087 nr_bits
= bool_vector_size (a
);
3088 if (bool_vector_size (b
) != nr_bits
)
3089 wrong_length_argument (a
, b
, dest
);
3091 nr_words
= bool_vector_words (nr_bits
);
3092 adata
= bool_vector_data (a
);
3093 bdata
= bool_vector_data (b
);
3097 dest
= make_uninit_bool_vector (nr_bits
);
3098 destdata
= bool_vector_data (dest
);
3102 CHECK_BOOL_VECTOR (dest
);
3103 destdata
= bool_vector_data (dest
);
3104 if (bool_vector_size (dest
) != nr_bits
)
3105 wrong_length_argument (a
, b
, dest
);
3109 case bool_vector_exclusive_or
:
3110 for (; i
< nr_words
; i
++)
3111 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3115 case bool_vector_subsetp
:
3116 for (; i
< nr_words
; i
++)
3117 if (adata
[i
] &~ bdata
[i
])
3121 case bool_vector_union
:
3122 for (; i
< nr_words
; i
++)
3123 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3127 case bool_vector_intersection
:
3128 for (; i
< nr_words
; i
++)
3129 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3133 case bool_vector_set_difference
:
3134 for (; i
< nr_words
; i
++)
3135 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3146 case bool_vector_exclusive_or
:
3147 for (; i
< nr_words
; i
++)
3148 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3151 case bool_vector_union
:
3152 for (; i
< nr_words
; i
++)
3153 destdata
[i
] = adata
[i
] | bdata
[i
];
3156 case bool_vector_intersection
:
3157 for (; i
< nr_words
; i
++)
3158 destdata
[i
] = adata
[i
] & bdata
[i
];
3161 case bool_vector_set_difference
:
3162 for (; i
< nr_words
; i
++)
3163 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3173 /* PRECONDITION must be true. Return VALUE. This odd construction
3174 works around a bogus GCC diagnostic "shift count >= width of type". */
3177 pre_value (bool precondition
, int value
)
3179 eassume (precondition
);
3180 return precondition
? value
: 0;
3183 /* Compute the number of trailing zero bits in val. If val is zero,
3184 return the number of bits in val. */
3186 count_trailing_zero_bits (bits_word val
)
3188 if (BITS_WORD_MAX
== UINT_MAX
)
3189 return count_trailing_zeros (val
);
3190 if (BITS_WORD_MAX
== ULONG_MAX
)
3191 return count_trailing_zeros_l (val
);
3192 if (BITS_WORD_MAX
== ULL_MAX
)
3193 return count_trailing_zeros_ll (val
);
3195 /* The rest of this code is for the unlikely platform where bits_word differs
3196 in width from unsigned int, unsigned long, and unsigned long long. */
3197 val
|= ~ BITS_WORD_MAX
;
3198 if (BITS_WORD_MAX
<= UINT_MAX
)
3199 return count_trailing_zeros (val
);
3200 if (BITS_WORD_MAX
<= ULONG_MAX
)
3201 return count_trailing_zeros_l (val
);
3206 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3207 count
+= BITS_PER_ULL
)
3210 return count
+ count_trailing_zeros_ll (val
);
3211 val
= shift_right_ull (val
);
3214 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3215 && BITS_WORD_MAX
== (bits_word
) -1)
3216 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3217 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3218 return count
+ count_trailing_zeros_ll (val
);
3223 bits_word_to_host_endian (bits_word val
)
3225 #ifndef WORDS_BIGENDIAN
3228 if (BITS_WORD_MAX
>> 31 == 1)
3229 return bswap_32 (val
);
3230 # if HAVE_UNSIGNED_LONG_LONG
3231 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3232 return bswap_64 (val
);
3237 for (i
= 0; i
< sizeof val
; i
++)
3239 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3240 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3241 val
= val
>> 1 >> (CHAR_BIT
- 1);
3248 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3249 Sbool_vector_exclusive_or
, 2, 3, 0,
3250 doc
: /* Return A ^ B, bitwise exclusive or.
3251 If optional third argument C is given, store result into C.
3252 A, B, and C must be bool vectors of the same length.
3253 Return the destination vector if it changed or nil otherwise. */)
3254 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3256 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3259 DEFUN ("bool-vector-union", Fbool_vector_union
,
3260 Sbool_vector_union
, 2, 3, 0,
3261 doc
: /* Return A | B, bitwise or.
3262 If optional third argument C is given, store result into C.
3263 A, B, and C must be bool vectors of the same length.
3264 Return the destination vector if it changed or nil otherwise. */)
3265 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3267 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3270 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3271 Sbool_vector_intersection
, 2, 3, 0,
3272 doc
: /* Return A & B, bitwise and.
3273 If optional third argument C is given, store result into C.
3274 A, B, and C must be bool vectors of the same length.
3275 Return the destination vector if it changed or nil otherwise. */)
3276 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3278 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3281 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3282 Sbool_vector_set_difference
, 2, 3, 0,
3283 doc
: /* Return A &~ B, set difference.
3284 If optional third argument C is given, store result into C.
3285 A, B, and C must be bool vectors of the same length.
3286 Return the destination vector if it changed or nil otherwise. */)
3287 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3289 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3292 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3293 Sbool_vector_subsetp
, 2, 2, 0,
3294 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3295 A and B must be bool vectors of the same length. */)
3296 (Lisp_Object a
, Lisp_Object b
)
3298 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3301 DEFUN ("bool-vector-not", Fbool_vector_not
,
3302 Sbool_vector_not
, 1, 2, 0,
3303 doc
: /* Compute ~A, set complement.
3304 If optional second argument B is given, store result into B.
3305 A and B must be bool vectors of the same length.
3306 Return the destination vector. */)
3307 (Lisp_Object a
, Lisp_Object b
)
3310 bits_word
*bdata
, *adata
;
3313 CHECK_BOOL_VECTOR (a
);
3314 nr_bits
= bool_vector_size (a
);
3317 b
= make_uninit_bool_vector (nr_bits
);
3320 CHECK_BOOL_VECTOR (b
);
3321 if (bool_vector_size (b
) != nr_bits
)
3322 wrong_length_argument (a
, b
, Qnil
);
3325 bdata
= bool_vector_data (b
);
3326 adata
= bool_vector_data (a
);
3328 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3329 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3331 if (nr_bits
% BITS_PER_BITS_WORD
)
3333 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3335 mword
&= bool_vector_spare_mask (nr_bits
);
3336 bdata
[i
] = bits_word_to_host_endian (mword
);
3342 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3343 Sbool_vector_count_population
, 1, 1, 0,
3344 doc
: /* Count how many elements in A are t.
3345 A is a bool vector. To count A's nil elements, subtract the return
3346 value from A's length. */)
3352 ptrdiff_t i
, nwords
;
3354 CHECK_BOOL_VECTOR (a
);
3356 nr_bits
= bool_vector_size (a
);
3357 nwords
= bool_vector_words (nr_bits
);
3359 adata
= bool_vector_data (a
);
3361 for (i
= 0; i
< nwords
; i
++)
3362 count
+= count_one_bits_word (adata
[i
]);
3364 return make_number (count
);
3367 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3368 Sbool_vector_count_consecutive
, 3, 3, 0,
3369 doc
: /* Count how many consecutive elements in A equal B starting at I.
3370 A is a bool vector, B is t or nil, and I is an index into A. */)
3371 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3378 bits_word mword
; /* Machine word. */
3379 ptrdiff_t pos
, pos0
;
3382 CHECK_BOOL_VECTOR (a
);
3385 nr_bits
= bool_vector_size (a
);
3386 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3387 args_out_of_range (a
, i
);
3389 adata
= bool_vector_data (a
);
3390 nr_words
= bool_vector_words (nr_bits
);
3391 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3392 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3395 /* By XORing with twiddle, we transform the problem of "count
3396 consecutive equal values" into "count the zero bits". The latter
3397 operation usually has hardware support. */
3398 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3400 /* Scan the remainder of the mword at the current offset. */
3401 if (pos
< nr_words
&& offset
!= 0)
3403 mword
= bits_word_to_host_endian (adata
[pos
]);
3407 /* Do not count the pad bits. */
3408 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3410 count
= count_trailing_zero_bits (mword
);
3412 if (count
+ offset
< BITS_PER_BITS_WORD
)
3413 return make_number (count
);
3416 /* Scan whole words until we either reach the end of the vector or
3417 find an mword that doesn't completely match. twiddle is
3418 endian-independent. */
3420 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3422 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3426 /* If we stopped because of a mismatch, see how many bits match
3427 in the current mword. */
3428 mword
= bits_word_to_host_endian (adata
[pos
]);
3430 count
+= count_trailing_zero_bits (mword
);
3432 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3434 /* If we hit the end, we might have overshot our count. Reduce
3435 the total by the number of spare bits at the end of the
3437 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3440 return make_number (count
);
3447 Lisp_Object error_tail
, arith_tail
;
3449 DEFSYM (Qquote
, "quote");
3450 DEFSYM (Qlambda
, "lambda");
3451 DEFSYM (Qsubr
, "subr");
3452 DEFSYM (Qerror_conditions
, "error-conditions");
3453 DEFSYM (Qerror_message
, "error-message");
3454 DEFSYM (Qtop_level
, "top-level");
3456 DEFSYM (Qerror
, "error");
3457 DEFSYM (Quser_error
, "user-error");
3458 DEFSYM (Qquit
, "quit");
3459 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3460 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3461 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3462 DEFSYM (Qvoid_function
, "void-function");
3463 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3464 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3465 DEFSYM (Qvoid_variable
, "void-variable");
3466 DEFSYM (Qsetting_constant
, "setting-constant");
3467 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3469 DEFSYM (Qinvalid_function
, "invalid-function");
3470 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3471 DEFSYM (Qno_catch
, "no-catch");
3472 DEFSYM (Qend_of_file
, "end-of-file");
3473 DEFSYM (Qarith_error
, "arith-error");
3474 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3475 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3476 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3477 DEFSYM (Qtext_read_only
, "text-read-only");
3478 DEFSYM (Qmark_inactive
, "mark-inactive");
3480 DEFSYM (Qlistp
, "listp");
3481 DEFSYM (Qconsp
, "consp");
3482 DEFSYM (Qsymbolp
, "symbolp");
3483 DEFSYM (Qkeywordp
, "keywordp");
3484 DEFSYM (Qintegerp
, "integerp");
3485 DEFSYM (Qnatnump
, "natnump");
3486 DEFSYM (Qwholenump
, "wholenump");
3487 DEFSYM (Qstringp
, "stringp");
3488 DEFSYM (Qarrayp
, "arrayp");
3489 DEFSYM (Qsequencep
, "sequencep");
3490 DEFSYM (Qbufferp
, "bufferp");
3491 DEFSYM (Qvectorp
, "vectorp");
3492 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3493 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3494 DEFSYM (Qmarkerp
, "markerp");
3495 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3496 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3497 DEFSYM (Qboundp
, "boundp");
3498 DEFSYM (Qfboundp
, "fboundp");
3500 DEFSYM (Qfloatp
, "floatp");
3501 DEFSYM (Qnumberp
, "numberp");
3502 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3504 DEFSYM (Qchar_table_p
, "char-table-p");
3505 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3507 DEFSYM (Qsubrp
, "subrp");
3508 DEFSYM (Qunevalled
, "unevalled");
3509 DEFSYM (Qmany
, "many");
3511 DEFSYM (Qcdr
, "cdr");
3513 /* Handle automatic advice activation. */
3514 DEFSYM (Qad_advice_info
, "ad-advice-info");
3515 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3517 error_tail
= pure_cons (Qerror
, Qnil
);
3519 /* ERROR is used as a signaler for random errors for which nothing else is
3522 Fput (Qerror
, Qerror_conditions
,
3524 Fput (Qerror
, Qerror_message
,
3525 build_pure_c_string ("error"));
3527 #define PUT_ERROR(sym, tail, msg) \
3528 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3529 Fput (sym, Qerror_message, build_pure_c_string (msg))
3531 PUT_ERROR (Qquit
, Qnil
, "Quit");
3533 PUT_ERROR (Quser_error
, error_tail
, "");
3534 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3535 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3536 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3537 PUT_ERROR (Qvoid_function
, error_tail
,
3538 "Symbol's function definition is void");
3539 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3540 "Symbol's chain of function indirections contains a loop");
3541 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3542 "Symbol's chain of variable indirections contains a loop");
3543 DEFSYM (Qcircular_list
, "circular-list");
3544 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3545 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3546 PUT_ERROR (Qsetting_constant
, error_tail
,
3547 "Attempt to set a constant symbol");
3548 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3549 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3550 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3551 "Wrong number of arguments");
3552 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3553 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3555 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3556 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3557 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3559 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3560 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3561 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3562 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3563 "Text is read-only");
3565 DEFSYM (Qrange_error
, "range-error");
3566 DEFSYM (Qdomain_error
, "domain-error");
3567 DEFSYM (Qsingularity_error
, "singularity-error");
3568 DEFSYM (Qoverflow_error
, "overflow-error");
3569 DEFSYM (Qunderflow_error
, "underflow-error");
3571 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3573 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3575 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3576 "Arithmetic singularity error");
3578 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3579 "Arithmetic overflow error");
3580 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3581 "Arithmetic underflow error");
3585 staticpro (&Qunbound
);
3587 /* Types that type-of returns. */
3588 DEFSYM (Qinteger
, "integer");
3589 DEFSYM (Qsymbol
, "symbol");
3590 DEFSYM (Qstring
, "string");
3591 DEFSYM (Qcons
, "cons");
3592 DEFSYM (Qmarker
, "marker");
3593 DEFSYM (Qoverlay
, "overlay");
3594 DEFSYM (Qfloat
, "float");
3595 DEFSYM (Qwindow_configuration
, "window-configuration");
3596 DEFSYM (Qprocess
, "process");
3597 DEFSYM (Qwindow
, "window");
3598 DEFSYM (Qcompiled_function
, "compiled-function");
3599 DEFSYM (Qbuffer
, "buffer");
3600 DEFSYM (Qframe
, "frame");
3601 DEFSYM (Qvector
, "vector");
3602 DEFSYM (Qchar_table
, "char-table");
3603 DEFSYM (Qbool_vector
, "bool-vector");
3604 DEFSYM (Qhash_table
, "hash-table");
3605 DEFSYM (Qmisc
, "misc");
3607 DEFSYM (Qdefun
, "defun");
3609 DEFSYM (Qfont_spec
, "font-spec");
3610 DEFSYM (Qfont_entity
, "font-entity");
3611 DEFSYM (Qfont_object
, "font-object");
3613 DEFSYM (Qinteractive_form
, "interactive-form");
3614 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3616 defsubr (&Sindirect_variable
);
3617 defsubr (&Sinteractive_form
);
3620 defsubr (&Stype_of
);
3625 defsubr (&Sintegerp
);
3626 defsubr (&Sinteger_or_marker_p
);
3627 defsubr (&Snumberp
);
3628 defsubr (&Snumber_or_marker_p
);
3630 defsubr (&Snatnump
);
3631 defsubr (&Ssymbolp
);
3632 defsubr (&Skeywordp
);
3633 defsubr (&Sstringp
);
3634 defsubr (&Smultibyte_string_p
);
3635 defsubr (&Svectorp
);
3636 defsubr (&Schar_table_p
);
3637 defsubr (&Svector_or_char_table_p
);
3638 defsubr (&Sbool_vector_p
);
3640 defsubr (&Ssequencep
);
3641 defsubr (&Sbufferp
);
3642 defsubr (&Smarkerp
);
3644 defsubr (&Sbyte_code_function_p
);
3645 defsubr (&Schar_or_string_p
);
3648 defsubr (&Scar_safe
);
3649 defsubr (&Scdr_safe
);
3652 defsubr (&Ssymbol_function
);
3653 defsubr (&Sindirect_function
);
3654 defsubr (&Ssymbol_plist
);
3655 defsubr (&Ssymbol_name
);
3656 defsubr (&Smakunbound
);
3657 defsubr (&Sfmakunbound
);
3659 defsubr (&Sfboundp
);
3661 defsubr (&Sdefalias
);
3662 defsubr (&Ssetplist
);
3663 defsubr (&Ssymbol_value
);
3665 defsubr (&Sdefault_boundp
);
3666 defsubr (&Sdefault_value
);
3667 defsubr (&Sset_default
);
3668 defsubr (&Ssetq_default
);
3669 defsubr (&Smake_variable_buffer_local
);
3670 defsubr (&Smake_local_variable
);
3671 defsubr (&Skill_local_variable
);
3672 defsubr (&Smake_variable_frame_local
);
3673 defsubr (&Slocal_variable_p
);
3674 defsubr (&Slocal_variable_if_set_p
);
3675 defsubr (&Svariable_binding_locus
);
3676 #if 0 /* XXX Remove this. --lorentey */
3677 defsubr (&Sterminal_local_value
);
3678 defsubr (&Sset_terminal_local_value
);
3682 defsubr (&Snumber_to_string
);
3683 defsubr (&Sstring_to_number
);
3684 defsubr (&Seqlsign
);
3706 defsubr (&Sbyteorder
);
3707 defsubr (&Ssubr_arity
);
3708 defsubr (&Ssubr_name
);
3710 defsubr (&Sbool_vector_exclusive_or
);
3711 defsubr (&Sbool_vector_union
);
3712 defsubr (&Sbool_vector_intersection
);
3713 defsubr (&Sbool_vector_set_difference
);
3714 defsubr (&Sbool_vector_not
);
3715 defsubr (&Sbool_vector_subsetp
);
3716 defsubr (&Sbool_vector_count_consecutive
);
3717 defsubr (&Sbool_vector_count_population
);
3719 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3721 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3722 doc
: /* The largest value that is representable in a Lisp integer. */);
3723 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3724 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3726 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3727 doc
: /* The smallest value that is representable in a Lisp integer. */);
3728 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3729 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;