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 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
975 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
976 buffer-independent contents of the value cell: forwarded just one
977 step past the buffer-localness.
979 BUF non-zero means set the value in buffer BUF instead of the
980 current buffer. This only plays a role for per-buffer variables. */
983 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
985 switch (XFWDTYPE (valcontents
))
988 CHECK_NUMBER (newval
);
989 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
993 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
997 *XOBJFWD (valcontents
)->objvar
= newval
;
999 /* If this variable is a default for something stored
1000 in the buffer itself, such as default-fill-column,
1001 find the buffers that don't have local values for it
1003 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1004 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1006 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1007 - (char *) &buffer_defaults
);
1008 int idx
= PER_BUFFER_IDX (offset
);
1010 Lisp_Object tail
, buf
;
1015 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1017 struct buffer
*b
= XBUFFER (buf
);
1019 if (! PER_BUFFER_VALUE_P (b
, idx
))
1020 set_per_buffer_value (b
, offset
, newval
);
1025 case Lisp_Fwd_Buffer_Obj
:
1027 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1028 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1030 if (!NILP (predicate
) && !NILP (newval
)
1031 && NILP (call1 (predicate
, newval
)))
1032 wrong_type_argument (predicate
, newval
);
1035 buf
= current_buffer
;
1036 set_per_buffer_value (buf
, offset
, newval
);
1040 case Lisp_Fwd_Kboard_Obj
:
1042 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1043 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1044 *(Lisp_Object
*) p
= newval
;
1049 emacs_abort (); /* goto def; */
1053 /* Set up SYMBOL to refer to its global binding. This makes it safe
1054 to alter the status of other bindings. BEWARE: this may be called
1055 during the mark phase of GC, where we assume that Lisp_Object slots
1056 of BLV are marked after this function has changed them. */
1059 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1061 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1063 /* Unload the previously loaded binding. */
1065 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1067 /* Select the global binding in the symbol. */
1068 set_blv_valcell (blv
, blv
->defcell
);
1070 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1072 /* Indicate that the global binding is set up now. */
1073 set_blv_where (blv
, Qnil
);
1074 set_blv_found (blv
, 0);
1077 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1078 VALCONTENTS is the contents of its value cell,
1079 which points to a struct Lisp_Buffer_Local_Value.
1081 Return the value forwarded one step past the buffer-local stage.
1082 This could be another forwarding pointer. */
1085 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1087 register Lisp_Object tem1
;
1089 eassert (blv
== SYMBOL_BLV (symbol
));
1094 || (blv
->frame_local
1095 ? !EQ (selected_frame
, tem1
)
1096 : current_buffer
!= XBUFFER (tem1
)))
1099 /* Unload the previously loaded binding. */
1100 tem1
= blv
->valcell
;
1102 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1103 /* Choose the new binding. */
1106 XSETSYMBOL (var
, symbol
);
1107 if (blv
->frame_local
)
1109 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1110 set_blv_where (blv
, selected_frame
);
1114 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1115 set_blv_where (blv
, Fcurrent_buffer ());
1118 if (!(blv
->found
= !NILP (tem1
)))
1119 tem1
= blv
->defcell
;
1121 /* Load the new binding. */
1122 set_blv_valcell (blv
, tem1
);
1124 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1128 /* Find the value of a symbol, returning Qunbound if it's not bound.
1129 This is helpful for code which just wants to get a variable's value
1130 if it has one, without signaling an error.
1131 Note that it must not be possible to quit
1132 within this function. Great care is required for this. */
1135 find_symbol_value (Lisp_Object symbol
)
1137 struct Lisp_Symbol
*sym
;
1139 CHECK_SYMBOL (symbol
);
1140 sym
= XSYMBOL (symbol
);
1143 switch (sym
->redirect
)
1145 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1146 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1147 case SYMBOL_LOCALIZED
:
1149 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1150 swap_in_symval_forwarding (sym
, blv
);
1151 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1154 case SYMBOL_FORWARDED
:
1155 return do_symval_forwarding (SYMBOL_FWD (sym
));
1156 default: emacs_abort ();
1160 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1161 doc
: /* Return SYMBOL's value. Error if that is void.
1162 Note that if `lexical-binding' is in effect, this returns the
1163 global value outside of any lexical scope. */)
1164 (Lisp_Object symbol
)
1168 val
= find_symbol_value (symbol
);
1169 if (!EQ (val
, Qunbound
))
1172 xsignal1 (Qvoid_variable
, symbol
);
1175 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1176 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1177 (register Lisp_Object symbol
, Lisp_Object newval
)
1179 set_internal (symbol
, newval
, Qnil
, 0);
1183 /* Store the value NEWVAL into SYMBOL.
1184 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1185 (nil stands for the current buffer/frame).
1187 If BINDFLAG is false, then if this symbol is supposed to become
1188 local in every buffer where it is set, then we make it local.
1189 If BINDFLAG is true, we don't do that. */
1192 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1195 bool voide
= EQ (newval
, Qunbound
);
1196 struct Lisp_Symbol
*sym
;
1199 /* If restoring in a dead buffer, do nothing. */
1200 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1203 CHECK_SYMBOL (symbol
);
1204 if (SYMBOL_CONSTANT_P (symbol
))
1206 if (NILP (Fkeywordp (symbol
))
1207 || !EQ (newval
, Fsymbol_value (symbol
)))
1208 xsignal1 (Qsetting_constant
, symbol
);
1210 /* Allow setting keywords to their own value. */
1214 sym
= XSYMBOL (symbol
);
1217 switch (sym
->redirect
)
1219 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1220 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1221 case SYMBOL_LOCALIZED
:
1223 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1226 if (blv
->frame_local
)
1227 where
= selected_frame
;
1229 XSETBUFFER (where
, current_buffer
);
1231 /* If the current buffer is not the buffer whose binding is
1232 loaded, or if there may be frame-local bindings and the frame
1233 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1234 the default binding is loaded, the loaded binding may be the
1236 if (!EQ (blv
->where
, where
)
1237 /* Also unload a global binding (if the var is local_if_set). */
1238 || (EQ (blv
->valcell
, blv
->defcell
)))
1240 /* The currently loaded binding is not necessarily valid.
1241 We need to unload it, and choose a new binding. */
1243 /* Write out `realvalue' to the old loaded binding. */
1245 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1247 /* Find the new binding. */
1248 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1249 tem1
= Fassq (symbol
,
1251 ? XFRAME (where
)->param_alist
1252 : BVAR (XBUFFER (where
), local_var_alist
)));
1253 set_blv_where (blv
, where
);
1258 /* This buffer still sees the default value. */
1260 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1261 or if this is `let' rather than `set',
1262 make CURRENT-ALIST-ELEMENT point to itself,
1263 indicating that we're seeing the default value.
1264 Likewise if the variable has been let-bound
1265 in the current buffer. */
1266 if (bindflag
|| !blv
->local_if_set
1267 || let_shadows_buffer_binding_p (sym
))
1270 tem1
= blv
->defcell
;
1272 /* If it's a local_if_set, being set not bound,
1273 and we're not within a let that was made for this buffer,
1274 create a new buffer-local binding for the variable.
1275 That means, give this buffer a new assoc for a local value
1276 and load that binding. */
1279 /* local_if_set is only supported for buffer-local
1280 bindings, not for frame-local bindings. */
1281 eassert (!blv
->frame_local
);
1282 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1283 bset_local_var_alist
1285 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1289 /* Record which binding is now loaded. */
1290 set_blv_valcell (blv
, tem1
);
1293 /* Store the new value in the cons cell. */
1294 set_blv_value (blv
, newval
);
1299 /* If storing void (making the symbol void), forward only through
1300 buffer-local indicator, not through Lisp_Objfwd, etc. */
1303 store_symval_forwarding (blv
->fwd
, newval
,
1305 ? XBUFFER (where
) : current_buffer
);
1309 case SYMBOL_FORWARDED
:
1312 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1313 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1314 if (BUFFER_OBJFWDP (innercontents
))
1316 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1317 int idx
= PER_BUFFER_IDX (offset
);
1320 && !let_shadows_buffer_binding_p (sym
))
1321 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1325 { /* If storing void (making the symbol void), forward only through
1326 buffer-local indicator, not through Lisp_Objfwd, etc. */
1327 sym
->redirect
= SYMBOL_PLAINVAL
;
1328 SET_SYMBOL_VAL (sym
, newval
);
1331 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1334 default: emacs_abort ();
1339 /* Access or set a buffer-local symbol's default value. */
1341 /* Return the default value of SYMBOL, but don't check for voidness.
1342 Return Qunbound if it is void. */
1345 default_value (Lisp_Object symbol
)
1347 struct Lisp_Symbol
*sym
;
1349 CHECK_SYMBOL (symbol
);
1350 sym
= XSYMBOL (symbol
);
1353 switch (sym
->redirect
)
1355 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1356 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1357 case SYMBOL_LOCALIZED
:
1359 /* If var is set up for a buffer that lacks a local value for it,
1360 the current value is nominally the default value.
1361 But the `realvalue' slot may be more up to date, since
1362 ordinary setq stores just that slot. So use that. */
1363 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1364 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1365 return do_symval_forwarding (blv
->fwd
);
1367 return XCDR (blv
->defcell
);
1369 case SYMBOL_FORWARDED
:
1371 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1373 /* For a built-in buffer-local variable, get the default value
1374 rather than letting do_symval_forwarding get the current value. */
1375 if (BUFFER_OBJFWDP (valcontents
))
1377 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1378 if (PER_BUFFER_IDX (offset
) != 0)
1379 return per_buffer_default (offset
);
1382 /* For other variables, get the current value. */
1383 return do_symval_forwarding (valcontents
);
1385 default: emacs_abort ();
1389 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1390 doc
: /* Return t if SYMBOL has a non-void default value.
1391 This is the value that is seen in buffers that do not have their own values
1392 for this variable. */)
1393 (Lisp_Object symbol
)
1395 register Lisp_Object value
;
1397 value
= default_value (symbol
);
1398 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1401 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1402 doc
: /* Return SYMBOL's default value.
1403 This is the value that is seen in buffers that do not have their own values
1404 for this variable. The default value is meaningful for variables with
1405 local bindings in certain buffers. */)
1406 (Lisp_Object symbol
)
1408 Lisp_Object value
= default_value (symbol
);
1409 if (!EQ (value
, Qunbound
))
1412 xsignal1 (Qvoid_variable
, symbol
);
1415 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1416 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1417 The default value is seen in buffers that do not have their own values
1418 for this variable. */)
1419 (Lisp_Object symbol
, Lisp_Object value
)
1421 struct Lisp_Symbol
*sym
;
1423 CHECK_SYMBOL (symbol
);
1424 if (SYMBOL_CONSTANT_P (symbol
))
1426 if (NILP (Fkeywordp (symbol
))
1427 || !EQ (value
, Fdefault_value (symbol
)))
1428 xsignal1 (Qsetting_constant
, symbol
);
1430 /* Allow setting keywords to their own value. */
1433 sym
= XSYMBOL (symbol
);
1436 switch (sym
->redirect
)
1438 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1439 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1440 case SYMBOL_LOCALIZED
:
1442 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1444 /* Store new value into the DEFAULT-VALUE slot. */
1445 XSETCDR (blv
->defcell
, value
);
1447 /* If the default binding is now loaded, set the REALVALUE slot too. */
1448 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1449 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1452 case SYMBOL_FORWARDED
:
1454 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1456 /* Handle variables like case-fold-search that have special slots
1458 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1459 if (BUFFER_OBJFWDP (valcontents
))
1461 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1462 int idx
= PER_BUFFER_IDX (offset
);
1464 set_per_buffer_default (offset
, value
);
1466 /* If this variable is not always local in all buffers,
1467 set it in the buffers that don't nominally have a local value. */
1473 if (!PER_BUFFER_VALUE_P (b
, idx
))
1474 set_per_buffer_value (b
, offset
, value
);
1479 return Fset (symbol
, value
);
1481 default: emacs_abort ();
1485 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1486 doc
: /* Set the default value of variable VAR to VALUE.
1487 VAR, the variable name, is literal (not evaluated);
1488 VALUE is an expression: it is evaluated and its value returned.
1489 The default value of a variable is seen in buffers
1490 that do not have their own values for the variable.
1492 More generally, you can use multiple variables and values, as in
1493 (setq-default VAR VALUE VAR VALUE...)
1494 This sets each VAR's default value to the corresponding VALUE.
1495 The VALUE for the Nth VAR can refer to the new default values
1497 usage: (setq-default [VAR VALUE]...) */)
1500 Lisp_Object args_left
, symbol
, val
;
1501 struct gcpro gcpro1
;
1503 args_left
= val
= args
;
1506 while (CONSP (args_left
))
1508 val
= eval_sub (Fcar (XCDR (args_left
)));
1509 symbol
= XCAR (args_left
);
1510 Fset_default (symbol
, val
);
1511 args_left
= Fcdr (XCDR (args_left
));
1518 /* Lisp functions for creating and removing buffer-local variables. */
1523 union Lisp_Fwd
*fwd
;
1526 static struct Lisp_Buffer_Local_Value
*
1527 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1528 union Lisp_Val_Fwd valcontents
)
1530 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1534 XSETSYMBOL (symbol
, sym
);
1535 tem
= Fcons (symbol
, (forwarded
1536 ? do_symval_forwarding (valcontents
.fwd
)
1537 : valcontents
.value
));
1539 /* Buffer_Local_Values cannot have as realval a buffer-local
1540 or keyboard-local forwarding. */
1541 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1542 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1543 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1544 set_blv_where (blv
, Qnil
);
1545 blv
->frame_local
= 0;
1546 blv
->local_if_set
= 0;
1547 set_blv_defcell (blv
, tem
);
1548 set_blv_valcell (blv
, tem
);
1549 set_blv_found (blv
, 0);
1553 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1554 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1555 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1556 At any time, the value for the current buffer is in effect,
1557 unless the variable has never been set in this buffer,
1558 in which case the default value is in effect.
1559 Note that binding the variable with `let', or setting it while
1560 a `let'-style binding made in this buffer is in effect,
1561 does not make the variable buffer-local. Return VARIABLE.
1563 This globally affects all uses of this variable, so it belongs together with
1564 the variable declaration, rather than with its uses (if you just want to make
1565 a variable local to the current buffer for one particular use, use
1566 `make-local-variable'). Buffer-local bindings are normally cleared
1567 while setting up a new major mode, unless they have a `permanent-local'
1570 The function `default-value' gets the default value and `set-default' sets it. */)
1571 (register Lisp_Object variable
)
1573 struct Lisp_Symbol
*sym
;
1574 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1575 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1576 bool forwarded
IF_LINT (= 0);
1578 CHECK_SYMBOL (variable
);
1579 sym
= XSYMBOL (variable
);
1582 switch (sym
->redirect
)
1584 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1585 case SYMBOL_PLAINVAL
:
1586 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1587 if (EQ (valcontents
.value
, Qunbound
))
1588 valcontents
.value
= Qnil
;
1590 case SYMBOL_LOCALIZED
:
1591 blv
= SYMBOL_BLV (sym
);
1592 if (blv
->frame_local
)
1593 error ("Symbol %s may not be buffer-local",
1594 SDATA (SYMBOL_NAME (variable
)));
1596 case SYMBOL_FORWARDED
:
1597 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1598 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1599 error ("Symbol %s may not be buffer-local",
1600 SDATA (SYMBOL_NAME (variable
)));
1601 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1604 default: emacs_abort ();
1608 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1612 blv
= make_blv (sym
, forwarded
, valcontents
);
1613 sym
->redirect
= SYMBOL_LOCALIZED
;
1614 SET_SYMBOL_BLV (sym
, blv
);
1617 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1618 if (let_shadows_global_binding_p (symbol
))
1619 message ("Making %s buffer-local while let-bound!",
1620 SDATA (SYMBOL_NAME (variable
)));
1624 blv
->local_if_set
= 1;
1628 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1629 1, 1, "vMake Local Variable: ",
1630 doc
: /* Make VARIABLE have a separate value in the current buffer.
1631 Other buffers will continue to share a common default value.
1632 \(The buffer-local value of VARIABLE starts out as the same value
1633 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1636 If the variable is already arranged to become local when set,
1637 this function causes a local value to exist for this buffer,
1638 just as setting the variable would do.
1640 This function returns VARIABLE, and therefore
1641 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1644 See also `make-variable-buffer-local'.
1646 Do not use `make-local-variable' to make a hook variable buffer-local.
1647 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1648 (Lisp_Object variable
)
1651 bool forwarded
IF_LINT (= 0);
1652 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1653 struct Lisp_Symbol
*sym
;
1654 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1656 CHECK_SYMBOL (variable
);
1657 sym
= XSYMBOL (variable
);
1660 switch (sym
->redirect
)
1662 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1663 case SYMBOL_PLAINVAL
:
1664 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1665 case SYMBOL_LOCALIZED
:
1666 blv
= SYMBOL_BLV (sym
);
1667 if (blv
->frame_local
)
1668 error ("Symbol %s may not be buffer-local",
1669 SDATA (SYMBOL_NAME (variable
)));
1671 case SYMBOL_FORWARDED
:
1672 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1673 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1674 error ("Symbol %s may not be buffer-local",
1675 SDATA (SYMBOL_NAME (variable
)));
1677 default: emacs_abort ();
1681 error ("Symbol %s may not be buffer-local",
1682 SDATA (SYMBOL_NAME (variable
)));
1684 if (blv
? blv
->local_if_set
1685 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1687 tem
= Fboundp (variable
);
1688 /* Make sure the symbol has a local value in this particular buffer,
1689 by setting it to the same value it already has. */
1690 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1695 blv
= make_blv (sym
, forwarded
, valcontents
);
1696 sym
->redirect
= SYMBOL_LOCALIZED
;
1697 SET_SYMBOL_BLV (sym
, blv
);
1700 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1701 if (let_shadows_global_binding_p (symbol
))
1702 message ("Making %s local to %s while let-bound!",
1703 SDATA (SYMBOL_NAME (variable
)),
1704 SDATA (BVAR (current_buffer
, name
)));
1708 /* Make sure this buffer has its own value of symbol. */
1709 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1710 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1713 if (let_shadows_buffer_binding_p (sym
))
1714 message ("Making %s buffer-local while locally let-bound!",
1715 SDATA (SYMBOL_NAME (variable
)));
1717 /* Swap out any local binding for some other buffer, and make
1718 sure the current value is permanently recorded, if it's the
1720 find_symbol_value (variable
);
1722 bset_local_var_alist
1724 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1725 BVAR (current_buffer
, local_var_alist
)));
1727 /* Make sure symbol does not think it is set up for this buffer;
1728 force it to look once again for this buffer's value. */
1729 if (current_buffer
== XBUFFER (blv
->where
))
1730 set_blv_where (blv
, Qnil
);
1731 set_blv_found (blv
, 0);
1734 /* If the symbol forwards into a C variable, then load the binding
1735 for this buffer now. If C code modifies the variable before we
1736 load the binding in, then that new value will clobber the default
1737 binding the next time we unload it. */
1739 swap_in_symval_forwarding (sym
, blv
);
1744 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1745 1, 1, "vKill Local Variable: ",
1746 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1747 From now on the default value will apply in this buffer. Return VARIABLE. */)
1748 (register Lisp_Object variable
)
1750 register Lisp_Object tem
;
1751 struct Lisp_Buffer_Local_Value
*blv
;
1752 struct Lisp_Symbol
*sym
;
1754 CHECK_SYMBOL (variable
);
1755 sym
= XSYMBOL (variable
);
1758 switch (sym
->redirect
)
1760 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1761 case SYMBOL_PLAINVAL
: return variable
;
1762 case SYMBOL_FORWARDED
:
1764 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1765 if (BUFFER_OBJFWDP (valcontents
))
1767 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1768 int idx
= PER_BUFFER_IDX (offset
);
1772 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1773 set_per_buffer_value (current_buffer
, offset
,
1774 per_buffer_default (offset
));
1779 case SYMBOL_LOCALIZED
:
1780 blv
= SYMBOL_BLV (sym
);
1781 if (blv
->frame_local
)
1784 default: emacs_abort ();
1787 /* Get rid of this buffer's alist element, if any. */
1788 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1789 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1791 bset_local_var_alist
1793 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1795 /* If the symbol is set up with the current buffer's binding
1796 loaded, recompute its value. We have to do it now, or else
1797 forwarded objects won't work right. */
1799 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1800 if (EQ (buf
, blv
->where
))
1802 set_blv_where (blv
, Qnil
);
1804 find_symbol_value (variable
);
1811 /* Lisp functions for creating and removing buffer-local variables. */
1813 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1814 when/if this is removed. */
1816 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1817 1, 1, "vMake Variable Frame Local: ",
1818 doc
: /* Enable VARIABLE to have frame-local bindings.
1819 This does not create any frame-local bindings for VARIABLE,
1820 it just makes them possible.
1822 A frame-local binding is actually a frame parameter value.
1823 If a frame F has a value for the frame parameter named VARIABLE,
1824 that also acts as a frame-local binding for VARIABLE in F--
1825 provided this function has been called to enable VARIABLE
1826 to have frame-local bindings at all.
1828 The only way to create a frame-local binding for VARIABLE in a frame
1829 is to set the VARIABLE frame parameter of that frame. See
1830 `modify-frame-parameters' for how to set frame parameters.
1832 Note that since Emacs 23.1, variables cannot be both buffer-local and
1833 frame-local any more (buffer-local bindings used to take precedence over
1834 frame-local bindings). */)
1835 (Lisp_Object variable
)
1838 union Lisp_Val_Fwd valcontents
;
1839 struct Lisp_Symbol
*sym
;
1840 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1842 CHECK_SYMBOL (variable
);
1843 sym
= XSYMBOL (variable
);
1846 switch (sym
->redirect
)
1848 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1849 case SYMBOL_PLAINVAL
:
1850 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1851 if (EQ (valcontents
.value
, Qunbound
))
1852 valcontents
.value
= Qnil
;
1854 case SYMBOL_LOCALIZED
:
1855 if (SYMBOL_BLV (sym
)->frame_local
)
1858 error ("Symbol %s may not be frame-local",
1859 SDATA (SYMBOL_NAME (variable
)));
1860 case SYMBOL_FORWARDED
:
1861 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1862 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1863 error ("Symbol %s may not be frame-local",
1864 SDATA (SYMBOL_NAME (variable
)));
1866 default: emacs_abort ();
1870 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1872 blv
= make_blv (sym
, forwarded
, valcontents
);
1873 blv
->frame_local
= 1;
1874 sym
->redirect
= SYMBOL_LOCALIZED
;
1875 SET_SYMBOL_BLV (sym
, blv
);
1878 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1879 if (let_shadows_global_binding_p (symbol
))
1880 message ("Making %s frame-local while let-bound!",
1881 SDATA (SYMBOL_NAME (variable
)));
1886 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1888 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1889 BUFFER defaults to the current buffer. */)
1890 (register Lisp_Object variable
, Lisp_Object buffer
)
1892 register struct buffer
*buf
;
1893 struct Lisp_Symbol
*sym
;
1896 buf
= current_buffer
;
1899 CHECK_BUFFER (buffer
);
1900 buf
= XBUFFER (buffer
);
1903 CHECK_SYMBOL (variable
);
1904 sym
= XSYMBOL (variable
);
1907 switch (sym
->redirect
)
1909 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1910 case SYMBOL_PLAINVAL
: return Qnil
;
1911 case SYMBOL_LOCALIZED
:
1913 Lisp_Object tail
, elt
, tmp
;
1914 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1915 XSETBUFFER (tmp
, buf
);
1916 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1918 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1919 return blv_found (blv
) ? Qt
: Qnil
;
1921 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1924 if (EQ (variable
, XCAR (elt
)))
1926 eassert (!blv
->frame_local
);
1932 case SYMBOL_FORWARDED
:
1934 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1935 if (BUFFER_OBJFWDP (valcontents
))
1937 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1938 int idx
= PER_BUFFER_IDX (offset
);
1939 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1944 default: emacs_abort ();
1948 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1950 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1951 BUFFER defaults to the current buffer.
1953 More precisely, return non-nil if either VARIABLE already has a local
1954 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1955 `make-variable-buffer-local'). */)
1956 (register Lisp_Object variable
, Lisp_Object 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 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1971 if (blv
->local_if_set
)
1973 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1974 return Flocal_variable_p (variable
, buffer
);
1976 case SYMBOL_FORWARDED
:
1977 /* All BUFFER_OBJFWD slots become local if they are set. */
1978 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1979 default: emacs_abort ();
1983 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1985 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1986 If the current binding is buffer-local, the value is the current buffer.
1987 If the current binding is frame-local, the value is the selected frame.
1988 If the current binding is global (the default), the value is nil. */)
1989 (register Lisp_Object variable
)
1991 struct Lisp_Symbol
*sym
;
1993 CHECK_SYMBOL (variable
);
1994 sym
= XSYMBOL (variable
);
1996 /* Make sure the current binding is actually swapped in. */
1997 find_symbol_value (variable
);
2000 switch (sym
->redirect
)
2002 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2003 case SYMBOL_PLAINVAL
: return Qnil
;
2004 case SYMBOL_FORWARDED
:
2006 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2007 if (KBOARD_OBJFWDP (valcontents
))
2008 return Fframe_terminal (selected_frame
);
2009 else if (!BUFFER_OBJFWDP (valcontents
))
2013 case SYMBOL_LOCALIZED
:
2014 /* For a local variable, record both the symbol and which
2015 buffer's or frame's value we are saving. */
2016 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2017 return Fcurrent_buffer ();
2018 else if (sym
->redirect
== SYMBOL_LOCALIZED
2019 && blv_found (SYMBOL_BLV (sym
)))
2020 return SYMBOL_BLV (sym
)->where
;
2023 default: emacs_abort ();
2027 /* This code is disabled now that we use the selected frame to return
2028 keyboard-local-values. */
2030 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2032 DEFUN ("terminal-local-value", Fterminal_local_value
,
2033 Sterminal_local_value
, 2, 2, 0,
2034 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2035 If SYMBOL is not a terminal-local variable, then return its normal
2036 value, like `symbol-value'.
2038 TERMINAL may be a terminal object, a frame, or nil (meaning the
2039 selected frame's terminal device). */)
2040 (Lisp_Object symbol
, Lisp_Object terminal
)
2043 struct terminal
*t
= get_terminal (terminal
, 1);
2044 push_kboard (t
->kboard
);
2045 result
= Fsymbol_value (symbol
);
2050 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2051 Sset_terminal_local_value
, 3, 3, 0,
2052 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2053 If VARIABLE is not a terminal-local variable, then set its normal
2054 binding, like `set'.
2056 TERMINAL may be a terminal object, a frame, or nil (meaning the
2057 selected frame's terminal device). */)
2058 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2061 struct terminal
*t
= get_terminal (terminal
, 1);
2062 push_kboard (d
->kboard
);
2063 result
= Fset (symbol
, value
);
2069 /* Find the function at the end of a chain of symbol function indirections. */
2071 /* If OBJECT is a symbol, find the end of its function chain and
2072 return the value found there. If OBJECT is not a symbol, just
2073 return it. If there is a cycle in the function chain, signal a
2074 cyclic-function-indirection error.
2076 This is like Findirect_function, except that it doesn't signal an
2077 error if the chain ends up unbound. */
2079 indirect_function (register Lisp_Object object
)
2081 Lisp_Object tortoise
, hare
;
2083 hare
= tortoise
= object
;
2087 if (!SYMBOLP (hare
) || NILP (hare
))
2089 hare
= XSYMBOL (hare
)->function
;
2090 if (!SYMBOLP (hare
) || NILP (hare
))
2092 hare
= XSYMBOL (hare
)->function
;
2094 tortoise
= XSYMBOL (tortoise
)->function
;
2096 if (EQ (hare
, tortoise
))
2097 xsignal1 (Qcyclic_function_indirection
, object
);
2103 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2104 doc
: /* Return the function at the end of OBJECT's function chain.
2105 If OBJECT is not a symbol, just return it. Otherwise, follow all
2106 function indirections to find the final function binding and return it.
2107 If the final symbol in the chain is unbound, signal a void-function error.
2108 Optional arg NOERROR non-nil means to return nil instead of signaling.
2109 Signal a cyclic-function-indirection error if there is a loop in the
2110 function chain of symbols. */)
2111 (register Lisp_Object object
, Lisp_Object noerror
)
2115 /* Optimize for no indirection. */
2117 if (SYMBOLP (result
) && !NILP (result
)
2118 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2119 result
= indirect_function (result
);
2124 xsignal1 (Qvoid_function
, object
);
2129 /* Extract and set vector and string elements. */
2131 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2132 doc
: /* Return the element of ARRAY at index IDX.
2133 ARRAY may be a vector, a string, a char-table, a bool-vector,
2134 or a byte-code object. IDX starts at 0. */)
2135 (register Lisp_Object array
, Lisp_Object idx
)
2137 register EMACS_INT idxval
;
2140 idxval
= XINT (idx
);
2141 if (STRINGP (array
))
2144 ptrdiff_t idxval_byte
;
2146 if (idxval
< 0 || idxval
>= SCHARS (array
))
2147 args_out_of_range (array
, idx
);
2148 if (! STRING_MULTIBYTE (array
))
2149 return make_number ((unsigned char) SREF (array
, idxval
));
2150 idxval_byte
= string_char_to_byte (array
, idxval
);
2152 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2153 return make_number (c
);
2155 else if (BOOL_VECTOR_P (array
))
2157 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2158 args_out_of_range (array
, idx
);
2159 return bool_vector_ref (array
, idxval
);
2161 else if (CHAR_TABLE_P (array
))
2163 CHECK_CHARACTER (idx
);
2164 return CHAR_TABLE_REF (array
, idxval
);
2169 if (VECTORP (array
))
2170 size
= ASIZE (array
);
2171 else if (COMPILEDP (array
))
2172 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2174 wrong_type_argument (Qarrayp
, array
);
2176 if (idxval
< 0 || idxval
>= size
)
2177 args_out_of_range (array
, idx
);
2178 return AREF (array
, idxval
);
2182 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2183 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2184 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2185 bool-vector. IDX starts at 0. */)
2186 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2188 register EMACS_INT idxval
;
2191 idxval
= XINT (idx
);
2192 CHECK_ARRAY (array
, Qarrayp
);
2193 CHECK_IMPURE (array
);
2195 if (VECTORP (array
))
2197 if (idxval
< 0 || idxval
>= ASIZE (array
))
2198 args_out_of_range (array
, idx
);
2199 ASET (array
, idxval
, newelt
);
2201 else if (BOOL_VECTOR_P (array
))
2203 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2204 args_out_of_range (array
, idx
);
2205 bool_vector_set (array
, idxval
, !NILP (newelt
));
2207 else if (CHAR_TABLE_P (array
))
2209 CHECK_CHARACTER (idx
);
2210 CHAR_TABLE_SET (array
, idxval
, newelt
);
2216 if (idxval
< 0 || idxval
>= SCHARS (array
))
2217 args_out_of_range (array
, idx
);
2218 CHECK_CHARACTER (newelt
);
2219 c
= XFASTINT (newelt
);
2221 if (STRING_MULTIBYTE (array
))
2223 ptrdiff_t idxval_byte
, nbytes
;
2224 int prev_bytes
, new_bytes
;
2225 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2227 nbytes
= SBYTES (array
);
2228 idxval_byte
= string_char_to_byte (array
, idxval
);
2229 p1
= SDATA (array
) + idxval_byte
;
2230 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2231 new_bytes
= CHAR_STRING (c
, p0
);
2232 if (prev_bytes
!= new_bytes
)
2234 /* We must relocate the string data. */
2235 ptrdiff_t nchars
= SCHARS (array
);
2237 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2239 memcpy (str
, SDATA (array
), nbytes
);
2240 allocate_string_data (XSTRING (array
), nchars
,
2241 nbytes
+ new_bytes
- prev_bytes
);
2242 memcpy (SDATA (array
), str
, idxval_byte
);
2243 p1
= SDATA (array
) + idxval_byte
;
2244 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2245 nbytes
- (idxval_byte
+ prev_bytes
));
2247 clear_string_char_byte_cache ();
2254 if (! SINGLE_BYTE_CHAR_P (c
))
2258 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2259 if (SREF (array
, i
) >= 0x80)
2260 args_out_of_range (array
, newelt
);
2261 /* ARRAY is an ASCII string. Convert it to a multibyte
2262 string, and try `aset' again. */
2263 STRING_SET_MULTIBYTE (array
);
2264 return Faset (array
, idx
, newelt
);
2266 SSET (array
, idxval
, c
);
2273 /* Arithmetic functions */
2276 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2278 double f1
= 0, f2
= 0;
2281 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2282 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2284 if (FLOATP (num1
) || FLOATP (num2
))
2287 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2288 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2294 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2298 case ARITH_NOTEQUAL
:
2299 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2304 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2308 case ARITH_LESS_OR_EQUAL
:
2309 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2314 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2318 case ARITH_GRTR_OR_EQUAL
:
2319 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2329 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2330 enum Arith_Comparison comparison
)
2333 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2335 if (EQ (Qnil
, arithcompare (args
[argnum
-1], args
[argnum
], comparison
)))
2341 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2342 doc
: /* Return t if args, all numbers or markers, are equal.
2343 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2344 (ptrdiff_t nargs
, Lisp_Object
*args
)
2346 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2349 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2350 doc
: /* Return t if each arg is less than the next arg. All must be numbers or markers.
2351 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2352 (ptrdiff_t nargs
, Lisp_Object
*args
)
2354 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2357 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2358 doc
: /* Return t if each arg is greater than the next arg. All must be numbers or markers.
2359 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2360 (ptrdiff_t nargs
, Lisp_Object
*args
)
2362 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2365 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2366 doc
: /* Return t if each arg is less than or equal to the next arg.
2367 All must be numbers or markers.
2368 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2369 (ptrdiff_t nargs
, Lisp_Object
*args
)
2371 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2374 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2375 doc
: /* Return t if each arg is greater than or equal to the next arg.
2376 All must be numbers or markers.
2377 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2378 (ptrdiff_t nargs
, Lisp_Object
*args
)
2380 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2383 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2384 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2385 (register Lisp_Object num1
, Lisp_Object num2
)
2387 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2390 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2391 doc
: /* Return t if NUMBER is zero. */)
2392 (register Lisp_Object number
)
2394 CHECK_NUMBER_OR_FLOAT (number
);
2396 if (FLOATP (number
))
2398 if (XFLOAT_DATA (number
) == 0.0)
2408 /* Convert the cons-of-integers, integer, or float value C to an
2409 unsigned value with maximum value MAX. Signal an error if C does not
2410 have a valid format or is out of range. */
2412 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2415 uintmax_t val
IF_LINT (= 0);
2418 valid
= 0 <= XINT (c
);
2421 else if (FLOATP (c
))
2423 double d
= XFLOAT_DATA (c
);
2425 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2431 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2433 uintmax_t top
= XFASTINT (XCAR (c
));
2434 Lisp_Object rest
= XCDR (c
);
2435 if (top
<= UINTMAX_MAX
>> 24 >> 16
2437 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2438 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2440 uintmax_t mid
= XFASTINT (XCAR (rest
));
2441 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2444 else if (top
<= UINTMAX_MAX
>> 16)
2448 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2450 val
= top
<< 16 | XFASTINT (rest
);
2456 if (! (valid
&& val
<= max
))
2457 error ("Not an in-range integer, float, or cons of integers");
2461 /* Convert the cons-of-integers, integer, or float value C to a signed
2462 value with extrema MIN and MAX. Signal an error if C does not have
2463 a valid format or is out of range. */
2465 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2468 intmax_t val
IF_LINT (= 0);
2474 else if (FLOATP (c
))
2476 double d
= XFLOAT_DATA (c
);
2478 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2484 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2486 intmax_t top
= XINT (XCAR (c
));
2487 Lisp_Object rest
= XCDR (c
);
2488 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2490 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2491 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2493 intmax_t mid
= XFASTINT (XCAR (rest
));
2494 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2497 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2501 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2503 val
= top
<< 16 | XFASTINT (rest
);
2509 if (! (valid
&& min
<= val
&& val
<= max
))
2510 error ("Not an in-range integer, float, or cons of integers");
2514 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2515 doc
: /* Return the decimal representation of NUMBER as a string.
2516 Uses a minus sign if negative.
2517 NUMBER may be an integer or a floating point number. */)
2518 (Lisp_Object number
)
2520 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2523 CHECK_NUMBER_OR_FLOAT (number
);
2525 if (FLOATP (number
))
2526 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2528 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2530 return make_unibyte_string (buffer
, len
);
2533 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2534 doc
: /* Parse STRING as a decimal number and return the number.
2535 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2536 STRING cannot be parsed as an integer or floating point number.
2538 If BASE, interpret STRING as a number in that base. If BASE isn't
2539 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2540 If the base used is not 10, STRING is always parsed as an integer. */)
2541 (register Lisp_Object string
, Lisp_Object base
)
2547 CHECK_STRING (string
);
2553 CHECK_NUMBER (base
);
2554 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2555 xsignal1 (Qargs_out_of_range
, base
);
2559 p
= SSDATA (string
);
2560 while (*p
== ' ' || *p
== '\t')
2563 val
= string_to_number (p
, b
, 1);
2564 return NILP (val
) ? make_number (0) : val
;
2580 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2581 ptrdiff_t, Lisp_Object
*);
2583 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2586 ptrdiff_t argnum
, ok_args
;
2587 EMACS_INT accum
= 0;
2588 EMACS_INT next
, ok_accum
;
2609 for (argnum
= 0; argnum
< nargs
; argnum
++)
2617 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2619 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2622 return float_arith_driver (ok_accum
, ok_args
, code
,
2625 next
= XINT (args
[argnum
]);
2629 if (INT_ADD_OVERFLOW (accum
, next
))
2637 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2642 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2645 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2647 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2649 accum
= ab
& INTMASK
;
2660 xsignal0 (Qarith_error
);
2674 if (!argnum
|| next
> accum
)
2678 if (!argnum
|| next
< accum
)
2684 XSETINT (val
, accum
);
2689 #define isnan(x) ((x) != (x))
2692 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2693 ptrdiff_t nargs
, Lisp_Object
*args
)
2695 register Lisp_Object val
;
2698 for (; argnum
< nargs
; argnum
++)
2700 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2701 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2705 next
= XFLOAT_DATA (val
);
2709 args
[argnum
] = val
; /* runs into a compiler bug. */
2710 next
= XINT (args
[argnum
]);
2718 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2728 if (! IEEE_FLOATING_POINT
&& next
== 0)
2729 xsignal0 (Qarith_error
);
2736 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2738 if (!argnum
|| isnan (next
) || next
> accum
)
2742 if (!argnum
|| isnan (next
) || next
< accum
)
2748 return make_float (accum
);
2752 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2753 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2754 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2755 (ptrdiff_t nargs
, Lisp_Object
*args
)
2757 return arith_driver (Aadd
, nargs
, args
);
2760 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2761 doc
: /* Negate number or subtract numbers or markers and return the result.
2762 With one arg, negates it. With more than one arg,
2763 subtracts all but the first from the first.
2764 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2765 (ptrdiff_t nargs
, Lisp_Object
*args
)
2767 return arith_driver (Asub
, nargs
, args
);
2770 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2771 doc
: /* Return product of any number of arguments, which are numbers or markers.
2772 usage: (* &rest NUMBERS-OR-MARKERS) */)
2773 (ptrdiff_t nargs
, Lisp_Object
*args
)
2775 return arith_driver (Amult
, nargs
, args
);
2778 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2779 doc
: /* Return first argument divided by all the remaining arguments.
2780 The arguments must be numbers or markers.
2781 usage: (/ DIVIDEND &rest DIVISORS) */)
2782 (ptrdiff_t nargs
, Lisp_Object
*args
)
2785 for (argnum
= 2; argnum
< nargs
; argnum
++)
2786 if (FLOATP (args
[argnum
]))
2787 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2788 return arith_driver (Adiv
, nargs
, args
);
2791 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2792 doc
: /* Return remainder of X divided by Y.
2793 Both must be integers or markers. */)
2794 (register Lisp_Object x
, Lisp_Object y
)
2798 CHECK_NUMBER_COERCE_MARKER (x
);
2799 CHECK_NUMBER_COERCE_MARKER (y
);
2802 xsignal0 (Qarith_error
);
2804 XSETINT (val
, XINT (x
) % XINT (y
));
2808 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2809 doc
: /* Return X modulo Y.
2810 The result falls between zero (inclusive) and Y (exclusive).
2811 Both X and Y must be numbers or markers. */)
2812 (register Lisp_Object x
, Lisp_Object y
)
2817 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2818 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2820 if (FLOATP (x
) || FLOATP (y
))
2821 return fmod_float (x
, y
);
2827 xsignal0 (Qarith_error
);
2831 /* If the "remainder" comes out with the wrong sign, fix it. */
2832 if (i2
< 0 ? i1
> 0 : i1
< 0)
2839 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2840 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2841 The value is always a number; markers are converted to numbers.
2842 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2843 (ptrdiff_t nargs
, Lisp_Object
*args
)
2845 return arith_driver (Amax
, nargs
, args
);
2848 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2849 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2850 The value is always a number; markers are converted to numbers.
2851 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2852 (ptrdiff_t nargs
, Lisp_Object
*args
)
2854 return arith_driver (Amin
, nargs
, args
);
2857 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2858 doc
: /* Return bitwise-and of all the arguments.
2859 Arguments may be integers, or markers converted to integers.
2860 usage: (logand &rest INTS-OR-MARKERS) */)
2861 (ptrdiff_t nargs
, Lisp_Object
*args
)
2863 return arith_driver (Alogand
, nargs
, args
);
2866 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2867 doc
: /* Return bitwise-or of all the arguments.
2868 Arguments may be integers, or markers converted to integers.
2869 usage: (logior &rest INTS-OR-MARKERS) */)
2870 (ptrdiff_t nargs
, Lisp_Object
*args
)
2872 return arith_driver (Alogior
, nargs
, args
);
2875 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2876 doc
: /* Return bitwise-exclusive-or of all the arguments.
2877 Arguments may be integers, or markers converted to integers.
2878 usage: (logxor &rest INTS-OR-MARKERS) */)
2879 (ptrdiff_t nargs
, Lisp_Object
*args
)
2881 return arith_driver (Alogxor
, nargs
, args
);
2884 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2885 doc
: /* Return VALUE with its bits shifted left by COUNT.
2886 If COUNT is negative, shifting is actually to the right.
2887 In this case, the sign bit is duplicated. */)
2888 (register Lisp_Object value
, Lisp_Object count
)
2890 register Lisp_Object val
;
2892 CHECK_NUMBER (value
);
2893 CHECK_NUMBER (count
);
2895 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2897 else if (XINT (count
) > 0)
2898 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2899 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2900 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2902 XSETINT (val
, XINT (value
) >> -XINT (count
));
2906 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2907 doc
: /* Return VALUE with its bits shifted left by COUNT.
2908 If COUNT is negative, shifting is actually to the right.
2909 In this case, zeros are shifted in on the left. */)
2910 (register Lisp_Object value
, Lisp_Object count
)
2912 register Lisp_Object val
;
2914 CHECK_NUMBER (value
);
2915 CHECK_NUMBER (count
);
2917 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2919 else if (XINT (count
) > 0)
2920 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2921 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2924 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2928 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2929 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2930 Markers are converted to integers. */)
2931 (register Lisp_Object number
)
2933 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2935 if (FLOATP (number
))
2936 return (make_float (1.0 + XFLOAT_DATA (number
)));
2938 XSETINT (number
, XINT (number
) + 1);
2942 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2943 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2944 Markers are converted to integers. */)
2945 (register Lisp_Object number
)
2947 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2949 if (FLOATP (number
))
2950 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2952 XSETINT (number
, XINT (number
) - 1);
2956 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2957 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2958 (register Lisp_Object number
)
2960 CHECK_NUMBER (number
);
2961 XSETINT (number
, ~XINT (number
));
2965 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2966 doc
: /* Return the byteorder for the machine.
2967 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2968 lowercase l) for small endian machines. */)
2971 unsigned i
= 0x04030201;
2972 int order
= *(char *)&i
== 1 ? 108 : 66;
2974 return make_number (order
);
2977 /* Because we round up the bool vector allocate size to word_size
2978 units, we can safely read past the "end" of the vector in the
2979 operations below. These extra bits are always zero. */
2982 bool_vector_spare_mask (EMACS_INT nr_bits
)
2984 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2987 /* Info about unsigned long long, falling back on unsigned long
2988 if unsigned long long is not available. */
2990 #if HAVE_UNSIGNED_LONG_LONG_INT
2991 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2992 # define ULL_MAX ULLONG_MAX
2994 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
2995 # define ULL_MAX ULONG_MAX
2996 # define count_one_bits_ll count_one_bits_l
2997 # define count_trailing_zeros_ll count_trailing_zeros_l
3000 /* Shift VAL right by the width of an unsigned long long.
3001 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3004 shift_right_ull (bits_word w
)
3006 /* Pacify bogus GCC warning about shift count exceeding type width. */
3007 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3011 /* Return the number of 1 bits in W. */
3014 count_one_bits_word (bits_word w
)
3016 if (BITS_WORD_MAX
<= UINT_MAX
)
3017 return count_one_bits (w
);
3018 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3019 return count_one_bits_l (w
);
3022 int i
= 0, count
= 0;
3023 while (count
+= count_one_bits_ll (w
),
3024 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3025 w
= shift_right_ull (w
);
3030 enum bool_vector_op
{ bool_vector_exclusive_or
,
3032 bool_vector_intersection
,
3033 bool_vector_set_difference
,
3034 bool_vector_subsetp
};
3037 bool_vector_binop_driver (Lisp_Object a
,
3040 enum bool_vector_op op
)
3043 bits_word
*adata
, *bdata
, *destdata
;
3047 CHECK_BOOL_VECTOR (a
);
3048 CHECK_BOOL_VECTOR (b
);
3050 nr_bits
= bool_vector_size (a
);
3051 if (bool_vector_size (b
) != nr_bits
)
3052 wrong_length_argument (a
, b
, dest
);
3054 nr_words
= bool_vector_words (nr_bits
);
3055 adata
= bool_vector_data (a
);
3056 bdata
= bool_vector_data (b
);
3060 dest
= make_uninit_bool_vector (nr_bits
);
3061 destdata
= bool_vector_data (dest
);
3065 CHECK_BOOL_VECTOR (dest
);
3066 destdata
= bool_vector_data (dest
);
3067 if (bool_vector_size (dest
) != nr_bits
)
3068 wrong_length_argument (a
, b
, dest
);
3072 case bool_vector_exclusive_or
:
3073 for (; i
< nr_words
; i
++)
3074 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3078 case bool_vector_subsetp
:
3079 for (; i
< nr_words
; i
++)
3080 if (adata
[i
] &~ bdata
[i
])
3084 case bool_vector_union
:
3085 for (; i
< nr_words
; i
++)
3086 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3090 case bool_vector_intersection
:
3091 for (; i
< nr_words
; i
++)
3092 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3096 case bool_vector_set_difference
:
3097 for (; i
< nr_words
; i
++)
3098 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3109 case bool_vector_exclusive_or
:
3110 for (; i
< nr_words
; i
++)
3111 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3114 case bool_vector_union
:
3115 for (; i
< nr_words
; i
++)
3116 destdata
[i
] = adata
[i
] | bdata
[i
];
3119 case bool_vector_intersection
:
3120 for (; i
< nr_words
; i
++)
3121 destdata
[i
] = adata
[i
] & bdata
[i
];
3124 case bool_vector_set_difference
:
3125 for (; i
< nr_words
; i
++)
3126 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3136 /* PRECONDITION must be true. Return VALUE. This odd construction
3137 works around a bogus GCC diagnostic "shift count >= width of type". */
3140 pre_value (bool precondition
, int value
)
3142 eassume (precondition
);
3143 return precondition
? value
: 0;
3146 /* Compute the number of trailing zero bits in val. If val is zero,
3147 return the number of bits in val. */
3149 count_trailing_zero_bits (bits_word val
)
3151 if (BITS_WORD_MAX
== UINT_MAX
)
3152 return count_trailing_zeros (val
);
3153 if (BITS_WORD_MAX
== ULONG_MAX
)
3154 return count_trailing_zeros_l (val
);
3155 if (BITS_WORD_MAX
== ULL_MAX
)
3156 return count_trailing_zeros_ll (val
);
3158 /* The rest of this code is for the unlikely platform where bits_word differs
3159 in width from unsigned int, unsigned long, and unsigned long long. */
3160 val
|= ~ BITS_WORD_MAX
;
3161 if (BITS_WORD_MAX
<= UINT_MAX
)
3162 return count_trailing_zeros (val
);
3163 if (BITS_WORD_MAX
<= ULONG_MAX
)
3164 return count_trailing_zeros_l (val
);
3169 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3170 count
+= BITS_PER_ULL
)
3173 return count
+ count_trailing_zeros_ll (val
);
3174 val
= shift_right_ull (val
);
3177 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3178 && BITS_WORD_MAX
== (bits_word
) -1)
3179 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3180 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3181 return count
+ count_trailing_zeros_ll (val
);
3186 bits_word_to_host_endian (bits_word val
)
3188 #ifndef WORDS_BIGENDIAN
3191 if (BITS_WORD_MAX
>> 31 == 1)
3192 return bswap_32 (val
);
3193 # if HAVE_UNSIGNED_LONG_LONG
3194 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3195 return bswap_64 (val
);
3200 for (i
= 0; i
< sizeof val
; i
++)
3202 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3203 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3204 val
= val
>> 1 >> (CHAR_BIT
- 1);
3211 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3212 Sbool_vector_exclusive_or
, 2, 3, 0,
3213 doc
: /* Return A ^ B, bitwise exclusive or.
3214 If optional third argument C is given, store result into C.
3215 A, B, and C must be bool vectors of the same length.
3216 Return the destination vector if it changed or nil otherwise. */)
3217 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3219 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3222 DEFUN ("bool-vector-union", Fbool_vector_union
,
3223 Sbool_vector_union
, 2, 3, 0,
3224 doc
: /* Return A | B, bitwise or.
3225 If optional third argument C is given, store result into C.
3226 A, B, and C must be bool vectors of the same length.
3227 Return the destination vector if it changed or nil otherwise. */)
3228 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3230 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3233 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3234 Sbool_vector_intersection
, 2, 3, 0,
3235 doc
: /* Return A & B, bitwise and.
3236 If optional third argument C is given, store result into C.
3237 A, B, and C must be bool vectors of the same length.
3238 Return the destination vector if it changed or nil otherwise. */)
3239 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3241 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3244 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3245 Sbool_vector_set_difference
, 2, 3, 0,
3246 doc
: /* Return A &~ B, set difference.
3247 If optional third argument C is given, store result into C.
3248 A, B, and C must be bool vectors of the same length.
3249 Return the destination vector if it changed or nil otherwise. */)
3250 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3252 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3255 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3256 Sbool_vector_subsetp
, 2, 2, 0,
3257 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3258 A and B must be bool vectors of the same length. */)
3259 (Lisp_Object a
, Lisp_Object b
)
3261 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3264 DEFUN ("bool-vector-not", Fbool_vector_not
,
3265 Sbool_vector_not
, 1, 2, 0,
3266 doc
: /* Compute ~A, set complement.
3267 If optional second argument B is given, store result into B.
3268 A and B must be bool vectors of the same length.
3269 Return the destination vector. */)
3270 (Lisp_Object a
, Lisp_Object b
)
3273 bits_word
*bdata
, *adata
;
3276 CHECK_BOOL_VECTOR (a
);
3277 nr_bits
= bool_vector_size (a
);
3280 b
= make_uninit_bool_vector (nr_bits
);
3283 CHECK_BOOL_VECTOR (b
);
3284 if (bool_vector_size (b
) != nr_bits
)
3285 wrong_length_argument (a
, b
, Qnil
);
3288 bdata
= bool_vector_data (b
);
3289 adata
= bool_vector_data (a
);
3291 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3292 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3294 if (nr_bits
% BITS_PER_BITS_WORD
)
3296 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3298 mword
&= bool_vector_spare_mask (nr_bits
);
3299 bdata
[i
] = bits_word_to_host_endian (mword
);
3305 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3306 Sbool_vector_count_population
, 1, 1, 0,
3307 doc
: /* Count how many elements in A are t.
3308 A is a bool vector. To count A's nil elements, subtract the return
3309 value from A's length. */)
3315 ptrdiff_t i
, nwords
;
3317 CHECK_BOOL_VECTOR (a
);
3319 nr_bits
= bool_vector_size (a
);
3320 nwords
= bool_vector_words (nr_bits
);
3322 adata
= bool_vector_data (a
);
3324 for (i
= 0; i
< nwords
; i
++)
3325 count
+= count_one_bits_word (adata
[i
]);
3327 return make_number (count
);
3330 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3331 Sbool_vector_count_consecutive
, 3, 3, 0,
3332 doc
: /* Count how many consecutive elements in A equal B starting at I.
3333 A is a bool vector, B is t or nil, and I is an index into A. */)
3334 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3341 bits_word mword
; /* Machine word. */
3342 ptrdiff_t pos
, pos0
;
3345 CHECK_BOOL_VECTOR (a
);
3348 nr_bits
= bool_vector_size (a
);
3349 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3350 args_out_of_range (a
, i
);
3352 adata
= bool_vector_data (a
);
3353 nr_words
= bool_vector_words (nr_bits
);
3354 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3355 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3358 /* By XORing with twiddle, we transform the problem of "count
3359 consecutive equal values" into "count the zero bits". The latter
3360 operation usually has hardware support. */
3361 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3363 /* Scan the remainder of the mword at the current offset. */
3364 if (pos
< nr_words
&& offset
!= 0)
3366 mword
= bits_word_to_host_endian (adata
[pos
]);
3370 /* Do not count the pad bits. */
3371 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3373 count
= count_trailing_zero_bits (mword
);
3375 if (count
+ offset
< BITS_PER_BITS_WORD
)
3376 return make_number (count
);
3379 /* Scan whole words until we either reach the end of the vector or
3380 find an mword that doesn't completely match. twiddle is
3381 endian-independent. */
3383 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3385 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3389 /* If we stopped because of a mismatch, see how many bits match
3390 in the current mword. */
3391 mword
= bits_word_to_host_endian (adata
[pos
]);
3393 count
+= count_trailing_zero_bits (mword
);
3395 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3397 /* If we hit the end, we might have overshot our count. Reduce
3398 the total by the number of spare bits at the end of the
3400 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3403 return make_number (count
);
3410 Lisp_Object error_tail
, arith_tail
;
3412 DEFSYM (Qquote
, "quote");
3413 DEFSYM (Qlambda
, "lambda");
3414 DEFSYM (Qsubr
, "subr");
3415 DEFSYM (Qerror_conditions
, "error-conditions");
3416 DEFSYM (Qerror_message
, "error-message");
3417 DEFSYM (Qtop_level
, "top-level");
3419 DEFSYM (Qerror
, "error");
3420 DEFSYM (Quser_error
, "user-error");
3421 DEFSYM (Qquit
, "quit");
3422 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3423 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3424 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3425 DEFSYM (Qvoid_function
, "void-function");
3426 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3427 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3428 DEFSYM (Qvoid_variable
, "void-variable");
3429 DEFSYM (Qsetting_constant
, "setting-constant");
3430 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3432 DEFSYM (Qinvalid_function
, "invalid-function");
3433 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3434 DEFSYM (Qno_catch
, "no-catch");
3435 DEFSYM (Qend_of_file
, "end-of-file");
3436 DEFSYM (Qarith_error
, "arith-error");
3437 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3438 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3439 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3440 DEFSYM (Qtext_read_only
, "text-read-only");
3441 DEFSYM (Qmark_inactive
, "mark-inactive");
3443 DEFSYM (Qlistp
, "listp");
3444 DEFSYM (Qconsp
, "consp");
3445 DEFSYM (Qsymbolp
, "symbolp");
3446 DEFSYM (Qkeywordp
, "keywordp");
3447 DEFSYM (Qintegerp
, "integerp");
3448 DEFSYM (Qnatnump
, "natnump");
3449 DEFSYM (Qwholenump
, "wholenump");
3450 DEFSYM (Qstringp
, "stringp");
3451 DEFSYM (Qarrayp
, "arrayp");
3452 DEFSYM (Qsequencep
, "sequencep");
3453 DEFSYM (Qbufferp
, "bufferp");
3454 DEFSYM (Qvectorp
, "vectorp");
3455 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3456 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3457 DEFSYM (Qmarkerp
, "markerp");
3458 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3459 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3460 DEFSYM (Qboundp
, "boundp");
3461 DEFSYM (Qfboundp
, "fboundp");
3463 DEFSYM (Qfloatp
, "floatp");
3464 DEFSYM (Qnumberp
, "numberp");
3465 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3467 DEFSYM (Qchar_table_p
, "char-table-p");
3468 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3470 DEFSYM (Qsubrp
, "subrp");
3471 DEFSYM (Qunevalled
, "unevalled");
3472 DEFSYM (Qmany
, "many");
3474 DEFSYM (Qcdr
, "cdr");
3476 /* Handle automatic advice activation. */
3477 DEFSYM (Qad_advice_info
, "ad-advice-info");
3478 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3480 error_tail
= pure_cons (Qerror
, Qnil
);
3482 /* ERROR is used as a signaler for random errors for which nothing else is
3485 Fput (Qerror
, Qerror_conditions
,
3487 Fput (Qerror
, Qerror_message
,
3488 build_pure_c_string ("error"));
3490 #define PUT_ERROR(sym, tail, msg) \
3491 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3492 Fput (sym, Qerror_message, build_pure_c_string (msg))
3494 PUT_ERROR (Qquit
, Qnil
, "Quit");
3496 PUT_ERROR (Quser_error
, error_tail
, "");
3497 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3498 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3499 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3500 PUT_ERROR (Qvoid_function
, error_tail
,
3501 "Symbol's function definition is void");
3502 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3503 "Symbol's chain of function indirections contains a loop");
3504 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3505 "Symbol's chain of variable indirections contains a loop");
3506 DEFSYM (Qcircular_list
, "circular-list");
3507 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3508 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3509 PUT_ERROR (Qsetting_constant
, error_tail
,
3510 "Attempt to set a constant symbol");
3511 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3512 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3513 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3514 "Wrong number of arguments");
3515 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3516 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3518 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3519 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3520 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3522 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3523 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3524 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3525 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3526 "Text is read-only");
3528 DEFSYM (Qrange_error
, "range-error");
3529 DEFSYM (Qdomain_error
, "domain-error");
3530 DEFSYM (Qsingularity_error
, "singularity-error");
3531 DEFSYM (Qoverflow_error
, "overflow-error");
3532 DEFSYM (Qunderflow_error
, "underflow-error");
3534 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3536 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3538 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3539 "Arithmetic singularity error");
3541 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3542 "Arithmetic overflow error");
3543 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3544 "Arithmetic underflow error");
3548 staticpro (&Qunbound
);
3550 /* Types that type-of returns. */
3551 DEFSYM (Qinteger
, "integer");
3552 DEFSYM (Qsymbol
, "symbol");
3553 DEFSYM (Qstring
, "string");
3554 DEFSYM (Qcons
, "cons");
3555 DEFSYM (Qmarker
, "marker");
3556 DEFSYM (Qoverlay
, "overlay");
3557 DEFSYM (Qfloat
, "float");
3558 DEFSYM (Qwindow_configuration
, "window-configuration");
3559 DEFSYM (Qprocess
, "process");
3560 DEFSYM (Qwindow
, "window");
3561 DEFSYM (Qcompiled_function
, "compiled-function");
3562 DEFSYM (Qbuffer
, "buffer");
3563 DEFSYM (Qframe
, "frame");
3564 DEFSYM (Qvector
, "vector");
3565 DEFSYM (Qchar_table
, "char-table");
3566 DEFSYM (Qbool_vector
, "bool-vector");
3567 DEFSYM (Qhash_table
, "hash-table");
3568 DEFSYM (Qmisc
, "misc");
3570 DEFSYM (Qdefun
, "defun");
3572 DEFSYM (Qfont_spec
, "font-spec");
3573 DEFSYM (Qfont_entity
, "font-entity");
3574 DEFSYM (Qfont_object
, "font-object");
3576 DEFSYM (Qinteractive_form
, "interactive-form");
3577 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3579 defsubr (&Sindirect_variable
);
3580 defsubr (&Sinteractive_form
);
3583 defsubr (&Stype_of
);
3588 defsubr (&Sintegerp
);
3589 defsubr (&Sinteger_or_marker_p
);
3590 defsubr (&Snumberp
);
3591 defsubr (&Snumber_or_marker_p
);
3593 defsubr (&Snatnump
);
3594 defsubr (&Ssymbolp
);
3595 defsubr (&Skeywordp
);
3596 defsubr (&Sstringp
);
3597 defsubr (&Smultibyte_string_p
);
3598 defsubr (&Svectorp
);
3599 defsubr (&Schar_table_p
);
3600 defsubr (&Svector_or_char_table_p
);
3601 defsubr (&Sbool_vector_p
);
3603 defsubr (&Ssequencep
);
3604 defsubr (&Sbufferp
);
3605 defsubr (&Smarkerp
);
3607 defsubr (&Sbyte_code_function_p
);
3608 defsubr (&Schar_or_string_p
);
3611 defsubr (&Scar_safe
);
3612 defsubr (&Scdr_safe
);
3615 defsubr (&Ssymbol_function
);
3616 defsubr (&Sindirect_function
);
3617 defsubr (&Ssymbol_plist
);
3618 defsubr (&Ssymbol_name
);
3619 defsubr (&Smakunbound
);
3620 defsubr (&Sfmakunbound
);
3622 defsubr (&Sfboundp
);
3624 defsubr (&Sdefalias
);
3625 defsubr (&Ssetplist
);
3626 defsubr (&Ssymbol_value
);
3628 defsubr (&Sdefault_boundp
);
3629 defsubr (&Sdefault_value
);
3630 defsubr (&Sset_default
);
3631 defsubr (&Ssetq_default
);
3632 defsubr (&Smake_variable_buffer_local
);
3633 defsubr (&Smake_local_variable
);
3634 defsubr (&Skill_local_variable
);
3635 defsubr (&Smake_variable_frame_local
);
3636 defsubr (&Slocal_variable_p
);
3637 defsubr (&Slocal_variable_if_set_p
);
3638 defsubr (&Svariable_binding_locus
);
3639 #if 0 /* XXX Remove this. --lorentey */
3640 defsubr (&Sterminal_local_value
);
3641 defsubr (&Sset_terminal_local_value
);
3645 defsubr (&Snumber_to_string
);
3646 defsubr (&Sstring_to_number
);
3647 defsubr (&Seqlsign
);
3670 defsubr (&Sbyteorder
);
3671 defsubr (&Ssubr_arity
);
3672 defsubr (&Ssubr_name
);
3674 defsubr (&Sbool_vector_exclusive_or
);
3675 defsubr (&Sbool_vector_union
);
3676 defsubr (&Sbool_vector_intersection
);
3677 defsubr (&Sbool_vector_set_difference
);
3678 defsubr (&Sbool_vector_not
);
3679 defsubr (&Sbool_vector_subsetp
);
3680 defsubr (&Sbool_vector_count_consecutive
);
3681 defsubr (&Sbool_vector_count_population
);
3683 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3685 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3686 doc
: /* The largest value that is representable in a Lisp integer. */);
3687 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3688 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3690 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3691 doc
: /* The smallest value that is representable in a Lisp integer. */);
3692 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3693 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;