1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 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. Error 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 set_symbol_function (symbol
, definition
);
735 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
736 doc
: /* Set SYMBOL's function definition to DEFINITION.
737 Associates the function with the current load file, if any.
738 The optional third argument DOCSTRING specifies the documentation string
739 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
740 determined by DEFINITION.
741 The return value is undefined. */)
742 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
744 CHECK_SYMBOL (symbol
);
745 if (!NILP (Vpurify_flag
)
746 /* If `definition' is a keymap, immutable (and copying) is wrong. */
747 && !KEYMAPP (definition
))
748 definition
= Fpurecopy (definition
);
751 bool autoload
= AUTOLOADP (definition
);
752 if (NILP (Vpurify_flag
) || !autoload
)
753 { /* Only add autoload entries after dumping, because the ones before are
754 not useful and else we get loads of them from the loaddefs.el. */
756 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
757 /* Remember that the function was already an autoload. */
758 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
759 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
763 { /* Handle automatic advice activation. */
764 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
766 call2 (hook
, symbol
, definition
);
768 Ffset (symbol
, definition
);
771 if (!NILP (docstring
))
772 Fput (symbol
, Qfunction_documentation
, docstring
);
773 /* We used to return `definition', but now that `defun' and `defmacro' expand
774 to a call to `defalias', we return `symbol' for backward compatibility
779 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
780 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
781 (register Lisp_Object symbol
, Lisp_Object newplist
)
783 CHECK_SYMBOL (symbol
);
784 set_symbol_plist (symbol
, newplist
);
788 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
789 doc
: /* Return minimum and maximum number of args allowed for SUBR.
790 SUBR must be a built-in function.
791 The returned value is a pair (MIN . MAX). MIN is the minimum number
792 of args. MAX is the maximum number or the symbol `many', for a
793 function with `&rest' args, or `unevalled' for a special form. */)
796 short minargs
, maxargs
;
798 minargs
= XSUBR (subr
)->min_args
;
799 maxargs
= XSUBR (subr
)->max_args
;
800 return Fcons (make_number (minargs
),
801 maxargs
== MANY
? Qmany
802 : maxargs
== UNEVALLED
? Qunevalled
803 : make_number (maxargs
));
806 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
807 doc
: /* Return name of subroutine SUBR.
808 SUBR must be a built-in function. */)
813 name
= XSUBR (subr
)->symbol_name
;
814 return build_string (name
);
817 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
818 doc
: /* Return the interactive form of CMD or nil if none.
819 If CMD is not a command, the return value is nil.
820 Value, if non-nil, is a list \(interactive SPEC). */)
823 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
828 /* Use an `interactive-form' property if present, analogous to the
829 function-documentation property. */
831 while (SYMBOLP (fun
))
833 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
837 fun
= Fsymbol_function (fun
);
842 const char *spec
= XSUBR (fun
)->intspec
;
844 return list2 (Qinteractive
,
845 (*spec
!= '(') ? build_string (spec
) :
846 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
848 else if (COMPILEDP (fun
))
850 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
851 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
853 else if (AUTOLOADP (fun
))
854 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
855 else if (CONSP (fun
))
857 Lisp_Object funcar
= XCAR (fun
);
858 if (EQ (funcar
, Qclosure
))
859 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
860 else if (EQ (funcar
, Qlambda
))
861 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
867 /***********************************************************************
868 Getting and Setting Values of Symbols
869 ***********************************************************************/
871 /* Return the symbol holding SYMBOL's value. Signal
872 `cyclic-variable-indirection' if SYMBOL's chain of variable
873 indirections contains a loop. */
876 indirect_variable (struct Lisp_Symbol
*symbol
)
878 struct Lisp_Symbol
*tortoise
, *hare
;
880 hare
= tortoise
= symbol
;
882 while (hare
->redirect
== SYMBOL_VARALIAS
)
884 hare
= SYMBOL_ALIAS (hare
);
885 if (hare
->redirect
!= SYMBOL_VARALIAS
)
888 hare
= SYMBOL_ALIAS (hare
);
889 tortoise
= SYMBOL_ALIAS (tortoise
);
891 if (hare
== tortoise
)
894 XSETSYMBOL (tem
, symbol
);
895 xsignal1 (Qcyclic_variable_indirection
, tem
);
903 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
904 doc
: /* Return the variable at the end of OBJECT's variable chain.
905 If OBJECT is a symbol, follow its variable indirections (if any), and
906 return the variable at the end of the chain of aliases. See Info node
907 `(elisp)Variable Aliases'.
909 If OBJECT is not a symbol, just return it. If there is a loop in the
910 chain of aliases, signal a `cyclic-variable-indirection' error. */)
913 if (SYMBOLP (object
))
915 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
916 XSETSYMBOL (object
, sym
);
922 /* Given the raw contents of a symbol value cell,
923 return the Lisp value of the symbol.
924 This does not handle buffer-local variables; use
925 swap_in_symval_forwarding for that. */
928 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
930 register Lisp_Object val
;
931 switch (XFWDTYPE (valcontents
))
934 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
938 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
941 return *XOBJFWD (valcontents
)->objvar
;
943 case Lisp_Fwd_Buffer_Obj
:
944 return per_buffer_value (current_buffer
,
945 XBUFFER_OBJFWD (valcontents
)->offset
);
947 case Lisp_Fwd_Kboard_Obj
:
948 /* We used to simply use current_kboard here, but from Lisp
949 code, its value is often unexpected. It seems nicer to
950 allow constructions like this to work as intuitively expected:
952 (with-selected-frame frame
953 (define-key local-function-map "\eOP" [f1]))
955 On the other hand, this affects the semantics of
956 last-command and real-last-command, and people may rely on
957 that. I took a quick look at the Lisp codebase, and I
958 don't think anything will break. --lorentey */
959 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
960 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
961 default: emacs_abort ();
965 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
966 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
967 buffer-independent contents of the value cell: forwarded just one
968 step past the buffer-localness.
970 BUF non-zero means set the value in buffer BUF instead of the
971 current buffer. This only plays a role for per-buffer variables. */
974 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
976 switch (XFWDTYPE (valcontents
))
979 CHECK_NUMBER (newval
);
980 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
984 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
988 *XOBJFWD (valcontents
)->objvar
= newval
;
990 /* If this variable is a default for something stored
991 in the buffer itself, such as default-fill-column,
992 find the buffers that don't have local values for it
994 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
995 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
997 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
998 - (char *) &buffer_defaults
);
999 int idx
= PER_BUFFER_IDX (offset
);
1001 Lisp_Object tail
, buf
;
1006 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1008 struct buffer
*b
= XBUFFER (buf
);
1010 if (! PER_BUFFER_VALUE_P (b
, idx
))
1011 set_per_buffer_value (b
, offset
, newval
);
1016 case Lisp_Fwd_Buffer_Obj
:
1018 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1019 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1021 if (!NILP (predicate
) && !NILP (newval
)
1022 && NILP (call1 (predicate
, newval
)))
1023 wrong_type_argument (predicate
, newval
);
1026 buf
= current_buffer
;
1027 set_per_buffer_value (buf
, offset
, newval
);
1031 case Lisp_Fwd_Kboard_Obj
:
1033 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1034 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1035 *(Lisp_Object
*) p
= newval
;
1040 emacs_abort (); /* goto def; */
1044 /* Set up SYMBOL to refer to its global binding. This makes it safe
1045 to alter the status of other bindings. BEWARE: this may be called
1046 during the mark phase of GC, where we assume that Lisp_Object slots
1047 of BLV are marked after this function has changed them. */
1050 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1052 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1054 /* Unload the previously loaded binding. */
1056 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1058 /* Select the global binding in the symbol. */
1059 set_blv_valcell (blv
, blv
->defcell
);
1061 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1063 /* Indicate that the global binding is set up now. */
1064 set_blv_where (blv
, Qnil
);
1065 set_blv_found (blv
, 0);
1068 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1069 VALCONTENTS is the contents of its value cell,
1070 which points to a struct Lisp_Buffer_Local_Value.
1072 Return the value forwarded one step past the buffer-local stage.
1073 This could be another forwarding pointer. */
1076 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1078 register Lisp_Object tem1
;
1080 eassert (blv
== SYMBOL_BLV (symbol
));
1085 || (blv
->frame_local
1086 ? !EQ (selected_frame
, tem1
)
1087 : current_buffer
!= XBUFFER (tem1
)))
1090 /* Unload the previously loaded binding. */
1091 tem1
= blv
->valcell
;
1093 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1094 /* Choose the new binding. */
1097 XSETSYMBOL (var
, symbol
);
1098 if (blv
->frame_local
)
1100 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1101 set_blv_where (blv
, selected_frame
);
1105 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1106 set_blv_where (blv
, Fcurrent_buffer ());
1109 if (!(blv
->found
= !NILP (tem1
)))
1110 tem1
= blv
->defcell
;
1112 /* Load the new binding. */
1113 set_blv_valcell (blv
, tem1
);
1115 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1119 /* Find the value of a symbol, returning Qunbound if it's not bound.
1120 This is helpful for code which just wants to get a variable's value
1121 if it has one, without signaling an error.
1122 Note that it must not be possible to quit
1123 within this function. Great care is required for this. */
1126 find_symbol_value (Lisp_Object symbol
)
1128 struct Lisp_Symbol
*sym
;
1130 CHECK_SYMBOL (symbol
);
1131 sym
= XSYMBOL (symbol
);
1134 switch (sym
->redirect
)
1136 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1137 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1138 case SYMBOL_LOCALIZED
:
1140 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1141 swap_in_symval_forwarding (sym
, blv
);
1142 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1145 case SYMBOL_FORWARDED
:
1146 return do_symval_forwarding (SYMBOL_FWD (sym
));
1147 default: emacs_abort ();
1151 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1152 doc
: /* Return SYMBOL's value. Error if that is void.
1153 Note that if `lexical-binding' is in effect, this returns the
1154 global value outside of any lexical scope. */)
1155 (Lisp_Object symbol
)
1159 val
= find_symbol_value (symbol
);
1160 if (!EQ (val
, Qunbound
))
1163 xsignal1 (Qvoid_variable
, symbol
);
1166 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1167 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1168 (register Lisp_Object symbol
, Lisp_Object newval
)
1170 set_internal (symbol
, newval
, Qnil
, 0);
1174 /* Store the value NEWVAL into SYMBOL.
1175 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1176 (nil stands for the current buffer/frame).
1178 If BINDFLAG is false, then if this symbol is supposed to become
1179 local in every buffer where it is set, then we make it local.
1180 If BINDFLAG is true, we don't do that. */
1183 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1186 bool voide
= EQ (newval
, Qunbound
);
1187 struct Lisp_Symbol
*sym
;
1190 /* If restoring in a dead buffer, do nothing. */
1191 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1194 CHECK_SYMBOL (symbol
);
1195 if (SYMBOL_CONSTANT_P (symbol
))
1197 if (NILP (Fkeywordp (symbol
))
1198 || !EQ (newval
, Fsymbol_value (symbol
)))
1199 xsignal1 (Qsetting_constant
, symbol
);
1201 /* Allow setting keywords to their own value. */
1205 sym
= XSYMBOL (symbol
);
1208 switch (sym
->redirect
)
1210 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1211 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1212 case SYMBOL_LOCALIZED
:
1214 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1217 if (blv
->frame_local
)
1218 where
= selected_frame
;
1220 XSETBUFFER (where
, current_buffer
);
1222 /* If the current buffer is not the buffer whose binding is
1223 loaded, or if there may be frame-local bindings and the frame
1224 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1225 the default binding is loaded, the loaded binding may be the
1227 if (!EQ (blv
->where
, where
)
1228 /* Also unload a global binding (if the var is local_if_set). */
1229 || (EQ (blv
->valcell
, blv
->defcell
)))
1231 /* The currently loaded binding is not necessarily valid.
1232 We need to unload it, and choose a new binding. */
1234 /* Write out `realvalue' to the old loaded binding. */
1236 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1238 /* Find the new binding. */
1239 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1240 tem1
= Fassq (symbol
,
1242 ? XFRAME (where
)->param_alist
1243 : BVAR (XBUFFER (where
), local_var_alist
)));
1244 set_blv_where (blv
, where
);
1249 /* This buffer still sees the default value. */
1251 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1252 or if this is `let' rather than `set',
1253 make CURRENT-ALIST-ELEMENT point to itself,
1254 indicating that we're seeing the default value.
1255 Likewise if the variable has been let-bound
1256 in the current buffer. */
1257 if (bindflag
|| !blv
->local_if_set
1258 || let_shadows_buffer_binding_p (sym
))
1261 tem1
= blv
->defcell
;
1263 /* If it's a local_if_set, being set not bound,
1264 and we're not within a let that was made for this buffer,
1265 create a new buffer-local binding for the variable.
1266 That means, give this buffer a new assoc for a local value
1267 and load that binding. */
1270 /* local_if_set is only supported for buffer-local
1271 bindings, not for frame-local bindings. */
1272 eassert (!blv
->frame_local
);
1273 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1274 bset_local_var_alist
1276 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1280 /* Record which binding is now loaded. */
1281 set_blv_valcell (blv
, tem1
);
1284 /* Store the new value in the cons cell. */
1285 set_blv_value (blv
, newval
);
1290 /* If storing void (making the symbol void), forward only through
1291 buffer-local indicator, not through Lisp_Objfwd, etc. */
1294 store_symval_forwarding (blv
->fwd
, newval
,
1296 ? XBUFFER (where
) : current_buffer
);
1300 case SYMBOL_FORWARDED
:
1303 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1304 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1305 if (BUFFER_OBJFWDP (innercontents
))
1307 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1308 int idx
= PER_BUFFER_IDX (offset
);
1311 && !let_shadows_buffer_binding_p (sym
))
1312 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1316 { /* If storing void (making the symbol void), forward only through
1317 buffer-local indicator, not through Lisp_Objfwd, etc. */
1318 sym
->redirect
= SYMBOL_PLAINVAL
;
1319 SET_SYMBOL_VAL (sym
, newval
);
1322 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1325 default: emacs_abort ();
1330 /* Access or set a buffer-local symbol's default value. */
1332 /* Return the default value of SYMBOL, but don't check for voidness.
1333 Return Qunbound if it is void. */
1336 default_value (Lisp_Object symbol
)
1338 struct Lisp_Symbol
*sym
;
1340 CHECK_SYMBOL (symbol
);
1341 sym
= XSYMBOL (symbol
);
1344 switch (sym
->redirect
)
1346 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1347 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1348 case SYMBOL_LOCALIZED
:
1350 /* If var is set up for a buffer that lacks a local value for it,
1351 the current value is nominally the default value.
1352 But the `realvalue' slot may be more up to date, since
1353 ordinary setq stores just that slot. So use that. */
1354 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1355 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1356 return do_symval_forwarding (blv
->fwd
);
1358 return XCDR (blv
->defcell
);
1360 case SYMBOL_FORWARDED
:
1362 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1364 /* For a built-in buffer-local variable, get the default value
1365 rather than letting do_symval_forwarding get the current value. */
1366 if (BUFFER_OBJFWDP (valcontents
))
1368 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1369 if (PER_BUFFER_IDX (offset
) != 0)
1370 return per_buffer_default (offset
);
1373 /* For other variables, get the current value. */
1374 return do_symval_forwarding (valcontents
);
1376 default: emacs_abort ();
1380 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1381 doc
: /* Return t if SYMBOL has a non-void default value.
1382 This is the value that is seen in buffers that do not have their own values
1383 for this variable. */)
1384 (Lisp_Object symbol
)
1386 register Lisp_Object value
;
1388 value
= default_value (symbol
);
1389 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1392 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1393 doc
: /* Return SYMBOL's default value.
1394 This is the value that is seen in buffers that do not have their own values
1395 for this variable. The default value is meaningful for variables with
1396 local bindings in certain buffers. */)
1397 (Lisp_Object symbol
)
1399 Lisp_Object value
= default_value (symbol
);
1400 if (!EQ (value
, Qunbound
))
1403 xsignal1 (Qvoid_variable
, symbol
);
1406 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1407 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1408 The default value is seen in buffers that do not have their own values
1409 for this variable. */)
1410 (Lisp_Object symbol
, Lisp_Object value
)
1412 struct Lisp_Symbol
*sym
;
1414 CHECK_SYMBOL (symbol
);
1415 if (SYMBOL_CONSTANT_P (symbol
))
1417 if (NILP (Fkeywordp (symbol
))
1418 || !EQ (value
, Fdefault_value (symbol
)))
1419 xsignal1 (Qsetting_constant
, symbol
);
1421 /* Allow setting keywords to their own value. */
1424 sym
= XSYMBOL (symbol
);
1427 switch (sym
->redirect
)
1429 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1430 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1431 case SYMBOL_LOCALIZED
:
1433 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1435 /* Store new value into the DEFAULT-VALUE slot. */
1436 XSETCDR (blv
->defcell
, value
);
1438 /* If the default binding is now loaded, set the REALVALUE slot too. */
1439 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1440 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1443 case SYMBOL_FORWARDED
:
1445 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1447 /* Handle variables like case-fold-search that have special slots
1449 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1450 if (BUFFER_OBJFWDP (valcontents
))
1452 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1453 int idx
= PER_BUFFER_IDX (offset
);
1455 set_per_buffer_default (offset
, value
);
1457 /* If this variable is not always local in all buffers,
1458 set it in the buffers that don't nominally have a local value. */
1464 if (!PER_BUFFER_VALUE_P (b
, idx
))
1465 set_per_buffer_value (b
, offset
, value
);
1470 return Fset (symbol
, value
);
1472 default: emacs_abort ();
1476 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1477 doc
: /* Set the default value of variable VAR to VALUE.
1478 VAR, the variable name, is literal (not evaluated);
1479 VALUE is an expression: it is evaluated and its value returned.
1480 The default value of a variable is seen in buffers
1481 that do not have their own values for the variable.
1483 More generally, you can use multiple variables and values, as in
1484 (setq-default VAR VALUE VAR VALUE...)
1485 This sets each VAR's default value to the corresponding VALUE.
1486 The VALUE for the Nth VAR can refer to the new default values
1488 usage: (setq-default [VAR VALUE]...) */)
1491 Lisp_Object args_left
, symbol
, val
;
1492 struct gcpro gcpro1
;
1494 args_left
= val
= args
;
1497 while (CONSP (args_left
))
1499 val
= eval_sub (Fcar (XCDR (args_left
)));
1500 symbol
= XCAR (args_left
);
1501 Fset_default (symbol
, val
);
1502 args_left
= Fcdr (XCDR (args_left
));
1509 /* Lisp functions for creating and removing buffer-local variables. */
1514 union Lisp_Fwd
*fwd
;
1517 static struct Lisp_Buffer_Local_Value
*
1518 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1519 union Lisp_Val_Fwd valcontents
)
1521 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1525 XSETSYMBOL (symbol
, sym
);
1526 tem
= Fcons (symbol
, (forwarded
1527 ? do_symval_forwarding (valcontents
.fwd
)
1528 : valcontents
.value
));
1530 /* Buffer_Local_Values cannot have as realval a buffer-local
1531 or keyboard-local forwarding. */
1532 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1533 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1534 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1535 set_blv_where (blv
, Qnil
);
1536 blv
->frame_local
= 0;
1537 blv
->local_if_set
= 0;
1538 set_blv_defcell (blv
, tem
);
1539 set_blv_valcell (blv
, tem
);
1540 set_blv_found (blv
, 0);
1544 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1545 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1546 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1547 At any time, the value for the current buffer is in effect,
1548 unless the variable has never been set in this buffer,
1549 in which case the default value is in effect.
1550 Note that binding the variable with `let', or setting it while
1551 a `let'-style binding made in this buffer is in effect,
1552 does not make the variable buffer-local. Return VARIABLE.
1554 In most cases it is better to use `make-local-variable',
1555 which makes a variable local in just one buffer.
1557 The function `default-value' gets the default value and `set-default' sets it. */)
1558 (register Lisp_Object variable
)
1560 struct Lisp_Symbol
*sym
;
1561 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1562 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1563 bool forwarded
IF_LINT (= 0);
1565 CHECK_SYMBOL (variable
);
1566 sym
= XSYMBOL (variable
);
1569 switch (sym
->redirect
)
1571 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1572 case SYMBOL_PLAINVAL
:
1573 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1574 if (EQ (valcontents
.value
, Qunbound
))
1575 valcontents
.value
= Qnil
;
1577 case SYMBOL_LOCALIZED
:
1578 blv
= SYMBOL_BLV (sym
);
1579 if (blv
->frame_local
)
1580 error ("Symbol %s may not be buffer-local",
1581 SDATA (SYMBOL_NAME (variable
)));
1583 case SYMBOL_FORWARDED
:
1584 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1585 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1586 error ("Symbol %s may not be buffer-local",
1587 SDATA (SYMBOL_NAME (variable
)));
1588 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1591 default: emacs_abort ();
1595 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1599 blv
= make_blv (sym
, forwarded
, valcontents
);
1600 sym
->redirect
= SYMBOL_LOCALIZED
;
1601 SET_SYMBOL_BLV (sym
, blv
);
1604 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1605 if (let_shadows_global_binding_p (symbol
))
1606 message ("Making %s buffer-local while let-bound!",
1607 SDATA (SYMBOL_NAME (variable
)));
1611 blv
->local_if_set
= 1;
1615 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1616 1, 1, "vMake Local Variable: ",
1617 doc
: /* Make VARIABLE have a separate value in the current buffer.
1618 Other buffers will continue to share a common default value.
1619 \(The buffer-local value of VARIABLE starts out as the same value
1620 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1623 If the variable is already arranged to become local when set,
1624 this function causes a local value to exist for this buffer,
1625 just as setting the variable would do.
1627 This function returns VARIABLE, and therefore
1628 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1631 See also `make-variable-buffer-local'.
1633 Do not use `make-local-variable' to make a hook variable buffer-local.
1634 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1635 (Lisp_Object variable
)
1638 bool forwarded
IF_LINT (= 0);
1639 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1640 struct Lisp_Symbol
*sym
;
1641 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1643 CHECK_SYMBOL (variable
);
1644 sym
= XSYMBOL (variable
);
1647 switch (sym
->redirect
)
1649 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1650 case SYMBOL_PLAINVAL
:
1651 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1652 case SYMBOL_LOCALIZED
:
1653 blv
= SYMBOL_BLV (sym
);
1654 if (blv
->frame_local
)
1655 error ("Symbol %s may not be buffer-local",
1656 SDATA (SYMBOL_NAME (variable
)));
1658 case SYMBOL_FORWARDED
:
1659 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1660 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1661 error ("Symbol %s may not be buffer-local",
1662 SDATA (SYMBOL_NAME (variable
)));
1664 default: emacs_abort ();
1668 error ("Symbol %s may not be buffer-local",
1669 SDATA (SYMBOL_NAME (variable
)));
1671 if (blv
? blv
->local_if_set
1672 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1674 tem
= Fboundp (variable
);
1675 /* Make sure the symbol has a local value in this particular buffer,
1676 by setting it to the same value it already has. */
1677 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1682 blv
= make_blv (sym
, forwarded
, valcontents
);
1683 sym
->redirect
= SYMBOL_LOCALIZED
;
1684 SET_SYMBOL_BLV (sym
, blv
);
1687 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1688 if (let_shadows_global_binding_p (symbol
))
1689 message ("Making %s local to %s while let-bound!",
1690 SDATA (SYMBOL_NAME (variable
)),
1691 SDATA (BVAR (current_buffer
, name
)));
1695 /* Make sure this buffer has its own value of symbol. */
1696 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1697 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1700 if (let_shadows_buffer_binding_p (sym
))
1701 message ("Making %s buffer-local while locally let-bound!",
1702 SDATA (SYMBOL_NAME (variable
)));
1704 /* Swap out any local binding for some other buffer, and make
1705 sure the current value is permanently recorded, if it's the
1707 find_symbol_value (variable
);
1709 bset_local_var_alist
1711 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1712 BVAR (current_buffer
, local_var_alist
)));
1714 /* Make sure symbol does not think it is set up for this buffer;
1715 force it to look once again for this buffer's value. */
1716 if (current_buffer
== XBUFFER (blv
->where
))
1717 set_blv_where (blv
, Qnil
);
1718 set_blv_found (blv
, 0);
1721 /* If the symbol forwards into a C variable, then load the binding
1722 for this buffer now. If C code modifies the variable before we
1723 load the binding in, then that new value will clobber the default
1724 binding the next time we unload it. */
1726 swap_in_symval_forwarding (sym
, blv
);
1731 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1732 1, 1, "vKill Local Variable: ",
1733 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1734 From now on the default value will apply in this buffer. Return VARIABLE. */)
1735 (register Lisp_Object variable
)
1737 register Lisp_Object tem
;
1738 struct Lisp_Buffer_Local_Value
*blv
;
1739 struct Lisp_Symbol
*sym
;
1741 CHECK_SYMBOL (variable
);
1742 sym
= XSYMBOL (variable
);
1745 switch (sym
->redirect
)
1747 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1748 case SYMBOL_PLAINVAL
: return variable
;
1749 case SYMBOL_FORWARDED
:
1751 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1752 if (BUFFER_OBJFWDP (valcontents
))
1754 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1755 int idx
= PER_BUFFER_IDX (offset
);
1759 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1760 set_per_buffer_value (current_buffer
, offset
,
1761 per_buffer_default (offset
));
1766 case SYMBOL_LOCALIZED
:
1767 blv
= SYMBOL_BLV (sym
);
1768 if (blv
->frame_local
)
1771 default: emacs_abort ();
1774 /* Get rid of this buffer's alist element, if any. */
1775 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1776 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1778 bset_local_var_alist
1780 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1782 /* If the symbol is set up with the current buffer's binding
1783 loaded, recompute its value. We have to do it now, or else
1784 forwarded objects won't work right. */
1786 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1787 if (EQ (buf
, blv
->where
))
1789 set_blv_where (blv
, Qnil
);
1791 find_symbol_value (variable
);
1798 /* Lisp functions for creating and removing buffer-local variables. */
1800 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1801 when/if this is removed. */
1803 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1804 1, 1, "vMake Variable Frame Local: ",
1805 doc
: /* Enable VARIABLE to have frame-local bindings.
1806 This does not create any frame-local bindings for VARIABLE,
1807 it just makes them possible.
1809 A frame-local binding is actually a frame parameter value.
1810 If a frame F has a value for the frame parameter named VARIABLE,
1811 that also acts as a frame-local binding for VARIABLE in F--
1812 provided this function has been called to enable VARIABLE
1813 to have frame-local bindings at all.
1815 The only way to create a frame-local binding for VARIABLE in a frame
1816 is to set the VARIABLE frame parameter of that frame. See
1817 `modify-frame-parameters' for how to set frame parameters.
1819 Note that since Emacs 23.1, variables cannot be both buffer-local and
1820 frame-local any more (buffer-local bindings used to take precedence over
1821 frame-local bindings). */)
1822 (Lisp_Object variable
)
1825 union Lisp_Val_Fwd valcontents
;
1826 struct Lisp_Symbol
*sym
;
1827 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1829 CHECK_SYMBOL (variable
);
1830 sym
= XSYMBOL (variable
);
1833 switch (sym
->redirect
)
1835 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1836 case SYMBOL_PLAINVAL
:
1837 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1838 if (EQ (valcontents
.value
, Qunbound
))
1839 valcontents
.value
= Qnil
;
1841 case SYMBOL_LOCALIZED
:
1842 if (SYMBOL_BLV (sym
)->frame_local
)
1845 error ("Symbol %s may not be frame-local",
1846 SDATA (SYMBOL_NAME (variable
)));
1847 case SYMBOL_FORWARDED
:
1848 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1849 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1850 error ("Symbol %s may not be frame-local",
1851 SDATA (SYMBOL_NAME (variable
)));
1853 default: emacs_abort ();
1857 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1859 blv
= make_blv (sym
, forwarded
, valcontents
);
1860 blv
->frame_local
= 1;
1861 sym
->redirect
= SYMBOL_LOCALIZED
;
1862 SET_SYMBOL_BLV (sym
, blv
);
1865 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1866 if (let_shadows_global_binding_p (symbol
))
1867 message ("Making %s frame-local while let-bound!",
1868 SDATA (SYMBOL_NAME (variable
)));
1873 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1875 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1876 BUFFER defaults to the current buffer. */)
1877 (register Lisp_Object variable
, Lisp_Object buffer
)
1879 register struct buffer
*buf
;
1880 struct Lisp_Symbol
*sym
;
1883 buf
= current_buffer
;
1886 CHECK_BUFFER (buffer
);
1887 buf
= XBUFFER (buffer
);
1890 CHECK_SYMBOL (variable
);
1891 sym
= XSYMBOL (variable
);
1894 switch (sym
->redirect
)
1896 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1897 case SYMBOL_PLAINVAL
: return Qnil
;
1898 case SYMBOL_LOCALIZED
:
1900 Lisp_Object tail
, elt
, tmp
;
1901 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1902 XSETBUFFER (tmp
, buf
);
1903 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1905 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1906 return blv_found (blv
) ? Qt
: Qnil
;
1908 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1911 if (EQ (variable
, XCAR (elt
)))
1913 eassert (!blv
->frame_local
);
1919 case SYMBOL_FORWARDED
:
1921 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1922 if (BUFFER_OBJFWDP (valcontents
))
1924 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1925 int idx
= PER_BUFFER_IDX (offset
);
1926 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1931 default: emacs_abort ();
1935 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1937 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1938 BUFFER defaults to the current buffer.
1940 More precisely, return non-nil if either VARIABLE already has a local
1941 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1942 `make-variable-buffer-local'). */)
1943 (register Lisp_Object variable
, Lisp_Object buffer
)
1945 struct Lisp_Symbol
*sym
;
1947 CHECK_SYMBOL (variable
);
1948 sym
= XSYMBOL (variable
);
1951 switch (sym
->redirect
)
1953 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1954 case SYMBOL_PLAINVAL
: return Qnil
;
1955 case SYMBOL_LOCALIZED
:
1957 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1958 if (blv
->local_if_set
)
1960 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1961 return Flocal_variable_p (variable
, buffer
);
1963 case SYMBOL_FORWARDED
:
1964 /* All BUFFER_OBJFWD slots become local if they are set. */
1965 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1966 default: emacs_abort ();
1970 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1972 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1973 If the current binding is buffer-local, the value is the current buffer.
1974 If the current binding is frame-local, the value is the selected frame.
1975 If the current binding is global (the default), the value is nil. */)
1976 (register Lisp_Object variable
)
1978 struct Lisp_Symbol
*sym
;
1980 CHECK_SYMBOL (variable
);
1981 sym
= XSYMBOL (variable
);
1983 /* Make sure the current binding is actually swapped in. */
1984 find_symbol_value (variable
);
1987 switch (sym
->redirect
)
1989 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1990 case SYMBOL_PLAINVAL
: return Qnil
;
1991 case SYMBOL_FORWARDED
:
1993 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1994 if (KBOARD_OBJFWDP (valcontents
))
1995 return Fframe_terminal (selected_frame
);
1996 else if (!BUFFER_OBJFWDP (valcontents
))
2000 case SYMBOL_LOCALIZED
:
2001 /* For a local variable, record both the symbol and which
2002 buffer's or frame's value we are saving. */
2003 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2004 return Fcurrent_buffer ();
2005 else if (sym
->redirect
== SYMBOL_LOCALIZED
2006 && blv_found (SYMBOL_BLV (sym
)))
2007 return SYMBOL_BLV (sym
)->where
;
2010 default: emacs_abort ();
2014 /* This code is disabled now that we use the selected frame to return
2015 keyboard-local-values. */
2017 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2019 DEFUN ("terminal-local-value", Fterminal_local_value
,
2020 Sterminal_local_value
, 2, 2, 0,
2021 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2022 If SYMBOL is not a terminal-local variable, then return its normal
2023 value, like `symbol-value'.
2025 TERMINAL may be a terminal object, a frame, or nil (meaning the
2026 selected frame's terminal device). */)
2027 (Lisp_Object symbol
, Lisp_Object terminal
)
2030 struct terminal
*t
= get_terminal (terminal
, 1);
2031 push_kboard (t
->kboard
);
2032 result
= Fsymbol_value (symbol
);
2037 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2038 Sset_terminal_local_value
, 3, 3, 0,
2039 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2040 If VARIABLE is not a terminal-local variable, then set its normal
2041 binding, like `set'.
2043 TERMINAL may be a terminal object, a frame, or nil (meaning the
2044 selected frame's terminal device). */)
2045 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2048 struct terminal
*t
= get_terminal (terminal
, 1);
2049 push_kboard (d
->kboard
);
2050 result
= Fset (symbol
, value
);
2056 /* Find the function at the end of a chain of symbol function indirections. */
2058 /* If OBJECT is a symbol, find the end of its function chain and
2059 return the value found there. If OBJECT is not a symbol, just
2060 return it. If there is a cycle in the function chain, signal a
2061 cyclic-function-indirection error.
2063 This is like Findirect_function, except that it doesn't signal an
2064 error if the chain ends up unbound. */
2066 indirect_function (register Lisp_Object object
)
2068 Lisp_Object tortoise
, hare
;
2070 hare
= tortoise
= object
;
2074 if (!SYMBOLP (hare
) || NILP (hare
))
2076 hare
= XSYMBOL (hare
)->function
;
2077 if (!SYMBOLP (hare
) || NILP (hare
))
2079 hare
= XSYMBOL (hare
)->function
;
2081 tortoise
= XSYMBOL (tortoise
)->function
;
2083 if (EQ (hare
, tortoise
))
2084 xsignal1 (Qcyclic_function_indirection
, object
);
2090 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2091 doc
: /* Return the function at the end of OBJECT's function chain.
2092 If OBJECT is not a symbol, just return it. Otherwise, follow all
2093 function indirections to find the final function binding and return it.
2094 If the final symbol in the chain is unbound, signal a void-function error.
2095 Optional arg NOERROR non-nil means to return nil instead of signaling.
2096 Signal a cyclic-function-indirection error if there is a loop in the
2097 function chain of symbols. */)
2098 (register Lisp_Object object
, Lisp_Object noerror
)
2102 /* Optimize for no indirection. */
2104 if (SYMBOLP (result
) && !NILP (result
)
2105 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2106 result
= indirect_function (result
);
2111 xsignal1 (Qvoid_function
, object
);
2116 /* Extract and set vector and string elements. */
2118 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2119 doc
: /* Return the element of ARRAY at index IDX.
2120 ARRAY may be a vector, a string, a char-table, a bool-vector,
2121 or a byte-code object. IDX starts at 0. */)
2122 (register Lisp_Object array
, Lisp_Object idx
)
2124 register EMACS_INT idxval
;
2127 idxval
= XINT (idx
);
2128 if (STRINGP (array
))
2131 ptrdiff_t idxval_byte
;
2133 if (idxval
< 0 || idxval
>= SCHARS (array
))
2134 args_out_of_range (array
, idx
);
2135 if (! STRING_MULTIBYTE (array
))
2136 return make_number ((unsigned char) SREF (array
, idxval
));
2137 idxval_byte
= string_char_to_byte (array
, idxval
);
2139 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2140 return make_number (c
);
2142 else if (BOOL_VECTOR_P (array
))
2146 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2147 args_out_of_range (array
, idx
);
2149 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2150 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2152 else if (CHAR_TABLE_P (array
))
2154 CHECK_CHARACTER (idx
);
2155 return CHAR_TABLE_REF (array
, idxval
);
2160 if (VECTORP (array
))
2161 size
= ASIZE (array
);
2162 else if (COMPILEDP (array
))
2163 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2165 wrong_type_argument (Qarrayp
, array
);
2167 if (idxval
< 0 || idxval
>= size
)
2168 args_out_of_range (array
, idx
);
2169 return AREF (array
, idxval
);
2173 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2174 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2175 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2176 bool-vector. IDX starts at 0. */)
2177 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2179 register EMACS_INT idxval
;
2182 idxval
= XINT (idx
);
2183 CHECK_ARRAY (array
, Qarrayp
);
2184 CHECK_IMPURE (array
);
2186 if (VECTORP (array
))
2188 if (idxval
< 0 || idxval
>= ASIZE (array
))
2189 args_out_of_range (array
, idx
);
2190 ASET (array
, idxval
, newelt
);
2192 else if (BOOL_VECTOR_P (array
))
2196 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2197 args_out_of_range (array
, idx
);
2199 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2201 if (! NILP (newelt
))
2202 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2204 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2205 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
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
)
2332 for (ptrdiff_t argnum
= 1; argnum
< nargs
; ++argnum
)
2334 if (EQ (Qnil
, arithcompare (args
[argnum
-1], args
[argnum
], comparison
)))
2340 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2341 doc
: /* Return t if args, all numbers or markers, are equal.
2342 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2343 (ptrdiff_t nargs
, Lisp_Object
*args
)
2345 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2348 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2349 doc
: /* Return t if each arg is less than the next arg. All must be numbers or markers.
2350 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2351 (ptrdiff_t nargs
, Lisp_Object
*args
)
2353 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2356 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2357 doc
: /* Return t if each arg is greater than the next arg. All must be numbers or markers.
2358 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2359 (ptrdiff_t nargs
, Lisp_Object
*args
)
2361 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2364 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2365 doc
: /* Return t if each arg is less than or equal to the next arg.
2366 All must be numbers or markers.
2367 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2368 (ptrdiff_t nargs
, Lisp_Object
*args
)
2370 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2373 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2374 doc
: /* Return t if each arg is greater than or equal to the next arg.
2375 All must be numbers or markers.
2376 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2377 (ptrdiff_t nargs
, Lisp_Object
*args
)
2379 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2382 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2383 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2384 (register Lisp_Object num1
, Lisp_Object num2
)
2386 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2389 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2390 doc
: /* Return t if NUMBER is zero. */)
2391 (register Lisp_Object number
)
2393 CHECK_NUMBER_OR_FLOAT (number
);
2395 if (FLOATP (number
))
2397 if (XFLOAT_DATA (number
) == 0.0)
2407 /* Convert the cons-of-integers, integer, or float value C to an
2408 unsigned value with maximum value MAX. Signal an error if C does not
2409 have a valid format or is out of range. */
2411 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2414 uintmax_t val
IF_LINT (= 0);
2417 valid
= 0 <= XINT (c
);
2420 else if (FLOATP (c
))
2422 double d
= XFLOAT_DATA (c
);
2424 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2430 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2432 uintmax_t top
= XFASTINT (XCAR (c
));
2433 Lisp_Object rest
= XCDR (c
);
2434 if (top
<= UINTMAX_MAX
>> 24 >> 16
2436 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2437 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2439 uintmax_t mid
= XFASTINT (XCAR (rest
));
2440 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2443 else if (top
<= UINTMAX_MAX
>> 16)
2447 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2449 val
= top
<< 16 | XFASTINT (rest
);
2455 if (! (valid
&& val
<= max
))
2456 error ("Not an in-range integer, float, or cons of integers");
2460 /* Convert the cons-of-integers, integer, or float value C to a signed
2461 value with extrema MIN and MAX. Signal an error if C does not have
2462 a valid format or is out of range. */
2464 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2467 intmax_t val
IF_LINT (= 0);
2473 else if (FLOATP (c
))
2475 double d
= XFLOAT_DATA (c
);
2477 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2483 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2485 intmax_t top
= XINT (XCAR (c
));
2486 Lisp_Object rest
= XCDR (c
);
2487 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2489 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2490 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2492 intmax_t mid
= XFASTINT (XCAR (rest
));
2493 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2496 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2500 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2502 val
= top
<< 16 | XFASTINT (rest
);
2508 if (! (valid
&& min
<= val
&& val
<= max
))
2509 error ("Not an in-range integer, float, or cons of integers");
2513 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2514 doc
: /* Return the decimal representation of NUMBER as a string.
2515 Uses a minus sign if negative.
2516 NUMBER may be an integer or a floating point number. */)
2517 (Lisp_Object number
)
2519 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2522 CHECK_NUMBER_OR_FLOAT (number
);
2524 if (FLOATP (number
))
2525 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2527 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2529 return make_unibyte_string (buffer
, len
);
2532 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2533 doc
: /* Parse STRING as a decimal number and return the number.
2534 This parses both integers and floating point numbers.
2535 It ignores leading spaces and tabs, and all trailing chars.
2537 If BASE, interpret STRING as a number in that base. If BASE isn't
2538 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2539 If the base used is not 10, STRING is always parsed as integer. */)
2540 (register Lisp_Object string
, Lisp_Object base
)
2546 CHECK_STRING (string
);
2552 CHECK_NUMBER (base
);
2553 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2554 xsignal1 (Qargs_out_of_range
, base
);
2558 p
= SSDATA (string
);
2559 while (*p
== ' ' || *p
== '\t')
2562 val
= string_to_number (p
, b
, 1);
2563 return NILP (val
) ? make_number (0) : val
;
2579 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2580 ptrdiff_t, Lisp_Object
*);
2582 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2585 ptrdiff_t argnum
, ok_args
;
2586 EMACS_INT accum
= 0;
2587 EMACS_INT next
, ok_accum
;
2608 for (argnum
= 0; argnum
< nargs
; argnum
++)
2616 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2618 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2621 return float_arith_driver (ok_accum
, ok_args
, code
,
2624 next
= XINT (args
[argnum
]);
2628 if (INT_ADD_OVERFLOW (accum
, next
))
2636 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2641 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2644 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2646 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2648 accum
= ab
& INTMASK
;
2659 xsignal0 (Qarith_error
);
2673 if (!argnum
|| next
> accum
)
2677 if (!argnum
|| next
< accum
)
2683 XSETINT (val
, accum
);
2688 #define isnan(x) ((x) != (x))
2691 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2692 ptrdiff_t nargs
, Lisp_Object
*args
)
2694 register Lisp_Object val
;
2697 for (; argnum
< nargs
; argnum
++)
2699 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2700 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2704 next
= XFLOAT_DATA (val
);
2708 args
[argnum
] = val
; /* runs into a compiler bug. */
2709 next
= XINT (args
[argnum
]);
2717 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2727 if (! IEEE_FLOATING_POINT
&& next
== 0)
2728 xsignal0 (Qarith_error
);
2735 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2737 if (!argnum
|| isnan (next
) || next
> accum
)
2741 if (!argnum
|| isnan (next
) || next
< accum
)
2747 return make_float (accum
);
2751 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2752 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2753 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2754 (ptrdiff_t nargs
, Lisp_Object
*args
)
2756 return arith_driver (Aadd
, nargs
, args
);
2759 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2760 doc
: /* Negate number or subtract numbers or markers and return the result.
2761 With one arg, negates it. With more than one arg,
2762 subtracts all but the first from the first.
2763 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2764 (ptrdiff_t nargs
, Lisp_Object
*args
)
2766 return arith_driver (Asub
, nargs
, args
);
2769 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2770 doc
: /* Return product of any number of arguments, which are numbers or markers.
2771 usage: (* &rest NUMBERS-OR-MARKERS) */)
2772 (ptrdiff_t nargs
, Lisp_Object
*args
)
2774 return arith_driver (Amult
, nargs
, args
);
2777 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2778 doc
: /* Return first argument divided by all the remaining arguments.
2779 The arguments must be numbers or markers.
2780 usage: (/ DIVIDEND &rest DIVISORS) */)
2781 (ptrdiff_t nargs
, Lisp_Object
*args
)
2784 for (argnum
= 2; argnum
< nargs
; argnum
++)
2785 if (FLOATP (args
[argnum
]))
2786 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2787 return arith_driver (Adiv
, nargs
, args
);
2790 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2791 doc
: /* Return remainder of X divided by Y.
2792 Both must be integers or markers. */)
2793 (register Lisp_Object x
, Lisp_Object y
)
2797 CHECK_NUMBER_COERCE_MARKER (x
);
2798 CHECK_NUMBER_COERCE_MARKER (y
);
2801 xsignal0 (Qarith_error
);
2803 XSETINT (val
, XINT (x
) % XINT (y
));
2807 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2808 doc
: /* Return X modulo Y.
2809 The result falls between zero (inclusive) and Y (exclusive).
2810 Both X and Y must be numbers or markers. */)
2811 (register Lisp_Object x
, Lisp_Object y
)
2816 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2817 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2819 if (FLOATP (x
) || FLOATP (y
))
2820 return fmod_float (x
, y
);
2826 xsignal0 (Qarith_error
);
2830 /* If the "remainder" comes out with the wrong sign, fix it. */
2831 if (i2
< 0 ? i1
> 0 : i1
< 0)
2838 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2839 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2840 The value is always a number; markers are converted to numbers.
2841 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2842 (ptrdiff_t nargs
, Lisp_Object
*args
)
2844 return arith_driver (Amax
, nargs
, args
);
2847 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2848 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2849 The value is always a number; markers are converted to numbers.
2850 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2851 (ptrdiff_t nargs
, Lisp_Object
*args
)
2853 return arith_driver (Amin
, nargs
, args
);
2856 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2857 doc
: /* Return bitwise-and of all the arguments.
2858 Arguments may be integers, or markers converted to integers.
2859 usage: (logand &rest INTS-OR-MARKERS) */)
2860 (ptrdiff_t nargs
, Lisp_Object
*args
)
2862 return arith_driver (Alogand
, nargs
, args
);
2865 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2866 doc
: /* Return bitwise-or of all the arguments.
2867 Arguments may be integers, or markers converted to integers.
2868 usage: (logior &rest INTS-OR-MARKERS) */)
2869 (ptrdiff_t nargs
, Lisp_Object
*args
)
2871 return arith_driver (Alogior
, nargs
, args
);
2874 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2875 doc
: /* Return bitwise-exclusive-or of all the arguments.
2876 Arguments may be integers, or markers converted to integers.
2877 usage: (logxor &rest INTS-OR-MARKERS) */)
2878 (ptrdiff_t nargs
, Lisp_Object
*args
)
2880 return arith_driver (Alogxor
, nargs
, args
);
2883 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2884 doc
: /* Return VALUE with its bits shifted left by COUNT.
2885 If COUNT is negative, shifting is actually to the right.
2886 In this case, the sign bit is duplicated. */)
2887 (register Lisp_Object value
, Lisp_Object count
)
2889 register Lisp_Object val
;
2891 CHECK_NUMBER (value
);
2892 CHECK_NUMBER (count
);
2894 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2896 else if (XINT (count
) > 0)
2897 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2898 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2899 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2901 XSETINT (val
, XINT (value
) >> -XINT (count
));
2905 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2906 doc
: /* Return VALUE with its bits shifted left by COUNT.
2907 If COUNT is negative, shifting is actually to the right.
2908 In this case, zeros are shifted in on the left. */)
2909 (register Lisp_Object value
, Lisp_Object count
)
2911 register Lisp_Object val
;
2913 CHECK_NUMBER (value
);
2914 CHECK_NUMBER (count
);
2916 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2918 else if (XINT (count
) > 0)
2919 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2920 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2923 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2927 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2928 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2929 Markers are converted to integers. */)
2930 (register Lisp_Object number
)
2932 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2934 if (FLOATP (number
))
2935 return (make_float (1.0 + XFLOAT_DATA (number
)));
2937 XSETINT (number
, XINT (number
) + 1);
2941 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2942 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2943 Markers are converted to integers. */)
2944 (register Lisp_Object number
)
2946 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2948 if (FLOATP (number
))
2949 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2951 XSETINT (number
, XINT (number
) - 1);
2955 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2956 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2957 (register Lisp_Object number
)
2959 CHECK_NUMBER (number
);
2960 XSETINT (number
, ~XINT (number
));
2964 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2965 doc
: /* Return the byteorder for the machine.
2966 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2967 lowercase l) for small endian machines. */)
2970 unsigned i
= 0x04030201;
2971 int order
= *(char *)&i
== 1 ? 108 : 66;
2973 return make_number (order
);
2976 /* Because we round up the bool vector allocate size to word_size
2977 units, we can safely read past the "end" of the vector in the
2978 operations below. These extra bits are always zero. Also, we
2979 always allocate bool vectors with at least one bits_word of storage so
2980 that we don't have to special-case empty bit vectors. */
2983 bool_vector_spare_mask (ptrdiff_t nr_bits
)
2985 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2988 #if BITS_WORD_MAX <= UINT_MAX
2989 # define popcount_bits_word count_one_bits
2990 #elif BITS_WORD_MAX <= ULONG_MAX
2991 # define popcount_bits_word count_one_bits_l
2992 #elif BITS_WORD_MAX <= ULLONG_MAX
2993 # define popcount_bits_word count_one_bits_ll
2995 # error "bits_word wider than long long? Please file a bug report."
2998 enum bool_vector_op
{ bool_vector_exclusive_or
,
3000 bool_vector_intersection
,
3001 bool_vector_set_difference
,
3002 bool_vector_subsetp
};
3005 bool_vector_binop_driver (Lisp_Object op1
,
3008 enum bool_vector_op op
)
3011 bits_word
*adata
, *bdata
, *cdata
;
3013 bits_word changed
= 0;
3017 CHECK_BOOL_VECTOR (op1
);
3018 CHECK_BOOL_VECTOR (op2
);
3020 nr_bits
= bool_vector_size (op1
);
3021 if (bool_vector_size (op2
) != nr_bits
)
3022 wrong_length_argument (op1
, op2
, dest
);
3026 dest
= Fmake_bool_vector (make_number (nr_bits
), Qnil
);
3031 CHECK_BOOL_VECTOR (dest
);
3032 if (bool_vector_size (dest
) != nr_bits
)
3033 wrong_length_argument (op1
, op2
, dest
);
3036 nr_words
= ROUNDUP (nr_bits
, BITS_PER_BITS_WORD
) / BITS_PER_BITS_WORD
;
3038 adata
= (bits_word
*) XBOOL_VECTOR (dest
)->data
;
3039 bdata
= (bits_word
*) XBOOL_VECTOR (op1
)->data
;
3040 cdata
= (bits_word
*) XBOOL_VECTOR (op2
)->data
;
3044 if (op
== bool_vector_exclusive_or
)
3045 mword
= bdata
[i
] ^ cdata
[i
];
3046 else if (op
== bool_vector_union
|| op
== bool_vector_subsetp
)
3047 mword
= bdata
[i
] | cdata
[i
];
3048 else if (op
== bool_vector_intersection
)
3049 mword
= bdata
[i
] & cdata
[i
];
3050 else if (op
== bool_vector_set_difference
)
3051 mword
= bdata
[i
] &~ cdata
[i
];
3055 changed
|= adata
[i
] ^ mword
;
3057 if (op
!= bool_vector_subsetp
)
3062 while (i
< nr_words
);
3064 return changed
? dest
: Qnil
;
3067 /* Compute the number of trailing zero bits in val. If val is zero,
3068 return the number of bits in val. */
3070 count_trailing_zero_bits (bits_word val
)
3072 if (BITS_WORD_MAX
== UINT_MAX
)
3073 return count_trailing_zeros (val
);
3074 if (BITS_WORD_MAX
== ULONG_MAX
)
3075 return count_trailing_zeros_l (val
);
3076 # if HAVE_UNSIGNED_LONG_LONG_INT
3077 if (BITS_WORD_MAX
== ULLONG_MAX
)
3078 return count_trailing_zeros_ll (val
);
3081 /* The rest of this code is for the unlikely platform where bits_word differs
3082 in width from unsigned int, unsigned long, and unsigned long long. */
3084 return CHAR_BIT
* sizeof (val
);
3085 if (BITS_WORD_MAX
<= UINT_MAX
)
3086 return count_trailing_zeros (val
);
3087 if (BITS_WORD_MAX
<= ULONG_MAX
)
3088 return count_trailing_zeros_l (val
);
3090 # if HAVE_UNSIGNED_LONG_LONG_INT
3091 verify (BITS_WORD_MAX
<= ULLONG_MAX
);
3092 return count_trailing_zeros_ll (val
);
3094 verify (BITS_WORD_MAX
<= ULONG_MAX
);
3100 bits_word_to_host_endian (bits_word val
)
3102 #ifndef WORDS_BIGENDIAN
3104 #elif BITS_WORD_MAX >> 31 == 1
3105 return bswap_32 (val
);
3106 #elif BITS_WORD_MAX >> 31 >> 31 >> 1 == 1
3107 return bswap_64 (val
);
3111 for (i
= 0; i
< sizeof val
; i
++)
3113 r
= (r
<< CHAR_BIT
) | (val
& ((1u << CHAR_BIT
) - 1));
3120 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3121 Sbool_vector_exclusive_or
, 2, 3, 0,
3122 doc
: /* Return A ^ B, bitwise exclusive or.
3123 If optional third argument C is given, store result into C.
3124 A, B, and C must be bool vectors of the same length.
3125 Return the destination vector if it changed or nil otherwise. */)
3126 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3128 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3131 DEFUN ("bool-vector-union", Fbool_vector_union
,
3132 Sbool_vector_union
, 2, 3, 0,
3133 doc
: /* Return A | B, bitwise or.
3134 If optional third argument C is given, store result into C.
3135 A, B, and C must be bool vectors of the same length.
3136 Return the destination vector if it changed or nil otherwise. */)
3137 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3139 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3142 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3143 Sbool_vector_intersection
, 2, 3, 0,
3144 doc
: /* Return A & B, bitwise and.
3145 If optional third argument C is given, store result into C.
3146 A, B, and C must be bool vectors of the same length.
3147 Return the destination vector if it changed or nil otherwise. */)
3148 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3150 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3153 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3154 Sbool_vector_set_difference
, 2, 3, 0,
3155 doc
: /* Return A &~ B, set difference.
3156 If optional third argument C is given, store result into C.
3157 A, B, and C must be bool vectors of the same length.
3158 Return the destination vector if it changed or nil otherwise. */)
3159 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3161 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3164 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3165 Sbool_vector_subsetp
, 2, 2, 0,
3167 (Lisp_Object a
, Lisp_Object b
)
3169 /* Like bool_vector_union, but doesn't modify b. */
3170 return bool_vector_binop_driver (b
, a
, b
, bool_vector_subsetp
);
3173 DEFUN ("bool-vector-not", Fbool_vector_not
,
3174 Sbool_vector_not
, 1, 2, 0,
3175 doc
: /* Compute ~A, set complement.
3176 If optional second argument B is given, store result into B.
3177 A and B must be bool vectors of the same length.
3178 Return the destination vector. */)
3179 (Lisp_Object a
, Lisp_Object b
)
3182 bits_word
*bdata
, *adata
;
3186 CHECK_BOOL_VECTOR (a
);
3187 nr_bits
= bool_vector_size (a
);
3190 b
= Fmake_bool_vector (make_number (nr_bits
), Qnil
);
3193 CHECK_BOOL_VECTOR (b
);
3194 if (bool_vector_size (b
) != nr_bits
)
3195 wrong_length_argument (a
, b
, Qnil
);
3198 bdata
= (bits_word
*) XBOOL_VECTOR (b
)->data
;
3199 adata
= (bits_word
*) XBOOL_VECTOR (a
)->data
;
3201 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3202 bdata
[i
] = ~adata
[i
];
3204 if (nr_bits
% BITS_PER_BITS_WORD
)
3206 mword
= bits_word_to_host_endian (adata
[i
]);
3208 mword
&= bool_vector_spare_mask (nr_bits
);
3209 bdata
[i
] = bits_word_to_host_endian (mword
);
3215 DEFUN ("bool-vector-count-matches", Fbool_vector_count_matches
,
3216 Sbool_vector_count_matches
, 2, 2, 0,
3217 doc
: /* Count how many elements in A equal B.
3218 A must be a bool vector. B is a generalized bool. */)
3219 (Lisp_Object a
, Lisp_Object b
)
3227 CHECK_BOOL_VECTOR (a
);
3229 nr_bits
= bool_vector_size (a
);
3231 match
= NILP (b
) ? -1 : 0;
3232 adata
= (bits_word
*) XBOOL_VECTOR (a
)->data
;
3234 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; ++i
)
3235 count
+= popcount_bits_word (adata
[i
] ^ match
);
3237 /* Mask out trailing parts of final mword. */
3238 if (nr_bits
% BITS_PER_BITS_WORD
)
3240 bits_word mword
= adata
[i
] ^ match
;
3241 mword
= bits_word_to_host_endian (mword
);
3242 count
+= popcount_bits_word (mword
& bool_vector_spare_mask (nr_bits
));
3245 return make_number (count
);
3248 DEFUN ("bool-vector-count-matches-at",
3249 Fbool_vector_count_matches_at
,
3250 Sbool_vector_count_matches_at
, 3, 3, 0,
3251 doc
: /* Count how many consecutive elements in A equal B at i.
3252 A must be a bool vector. B is a generalized boolean. i is an
3253 index into the vector. */)
3254 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3261 bits_word mword
; /* Machine word. */
3265 CHECK_BOOL_VECTOR (a
);
3268 nr_bits
= bool_vector_size (a
);
3269 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3270 args_out_of_range (a
, i
);
3272 adata
= (bits_word
*) XBOOL_VECTOR (a
)->data
;
3274 nr_words
= ROUNDUP (nr_bits
, BITS_PER_BITS_WORD
) / BITS_PER_BITS_WORD
;
3276 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3277 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3280 /* By XORing with twiddle, we transform the problem of "count
3281 consecutive equal values" into "count the zero bits". The latter
3282 operation usually has hardware support. */
3283 twiddle
= NILP (b
) ? 0 : -1;
3285 /* Scan the remainder of the mword at the current offset. */
3286 if (pos
< nr_words
&& offset
!= 0)
3288 mword
= bits_word_to_host_endian (adata
[pos
]);
3291 count
= count_trailing_zero_bits (mword
);
3292 count
= min (count
, BITS_PER_BITS_WORD
- offset
);
3294 if (count
+ offset
< BITS_PER_BITS_WORD
)
3295 return make_number (count
);
3298 /* Scan whole words until we either reach the end of the vector or
3299 find an mword that doesn't completely match. twiddle is
3300 endian-independent. */
3301 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3303 count
+= BITS_PER_BITS_WORD
;
3309 /* If we stopped because of a mismatch, see how many bits match
3310 in the current mword. */
3311 mword
= bits_word_to_host_endian (adata
[pos
]);
3313 count
+= count_trailing_zero_bits (mword
);
3315 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3317 /* If we hit the end, we might have overshot our count. Reduce
3318 the total by the number of spare bits at the end of the
3320 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3323 return make_number (count
);
3330 Lisp_Object error_tail
, arith_tail
;
3332 DEFSYM (Qquote
, "quote");
3333 DEFSYM (Qlambda
, "lambda");
3334 DEFSYM (Qsubr
, "subr");
3335 DEFSYM (Qerror_conditions
, "error-conditions");
3336 DEFSYM (Qerror_message
, "error-message");
3337 DEFSYM (Qtop_level
, "top-level");
3339 DEFSYM (Qerror
, "error");
3340 DEFSYM (Quser_error
, "user-error");
3341 DEFSYM (Qquit
, "quit");
3342 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3343 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3344 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3345 DEFSYM (Qvoid_function
, "void-function");
3346 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3347 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3348 DEFSYM (Qvoid_variable
, "void-variable");
3349 DEFSYM (Qsetting_constant
, "setting-constant");
3350 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3352 DEFSYM (Qinvalid_function
, "invalid-function");
3353 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3354 DEFSYM (Qno_catch
, "no-catch");
3355 DEFSYM (Qend_of_file
, "end-of-file");
3356 DEFSYM (Qarith_error
, "arith-error");
3357 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3358 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3359 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3360 DEFSYM (Qtext_read_only
, "text-read-only");
3361 DEFSYM (Qmark_inactive
, "mark-inactive");
3363 DEFSYM (Qlistp
, "listp");
3364 DEFSYM (Qconsp
, "consp");
3365 DEFSYM (Qsymbolp
, "symbolp");
3366 DEFSYM (Qkeywordp
, "keywordp");
3367 DEFSYM (Qintegerp
, "integerp");
3368 DEFSYM (Qnatnump
, "natnump");
3369 DEFSYM (Qwholenump
, "wholenump");
3370 DEFSYM (Qstringp
, "stringp");
3371 DEFSYM (Qarrayp
, "arrayp");
3372 DEFSYM (Qsequencep
, "sequencep");
3373 DEFSYM (Qbufferp
, "bufferp");
3374 DEFSYM (Qvectorp
, "vectorp");
3375 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3376 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3377 DEFSYM (Qmarkerp
, "markerp");
3378 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3379 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3380 DEFSYM (Qboundp
, "boundp");
3381 DEFSYM (Qfboundp
, "fboundp");
3383 DEFSYM (Qfloatp
, "floatp");
3384 DEFSYM (Qnumberp
, "numberp");
3385 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3387 DEFSYM (Qchar_table_p
, "char-table-p");
3388 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3390 DEFSYM (Qsubrp
, "subrp");
3391 DEFSYM (Qunevalled
, "unevalled");
3392 DEFSYM (Qmany
, "many");
3394 DEFSYM (Qcdr
, "cdr");
3396 /* Handle automatic advice activation. */
3397 DEFSYM (Qad_advice_info
, "ad-advice-info");
3398 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3400 error_tail
= pure_cons (Qerror
, Qnil
);
3402 /* ERROR is used as a signaler for random errors for which nothing else is
3405 Fput (Qerror
, Qerror_conditions
,
3407 Fput (Qerror
, Qerror_message
,
3408 build_pure_c_string ("error"));
3410 #define PUT_ERROR(sym, tail, msg) \
3411 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3412 Fput (sym, Qerror_message, build_pure_c_string (msg))
3414 PUT_ERROR (Qquit
, Qnil
, "Quit");
3416 PUT_ERROR (Quser_error
, error_tail
, "");
3417 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3418 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3419 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3420 PUT_ERROR (Qvoid_function
, error_tail
,
3421 "Symbol's function definition is void");
3422 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3423 "Symbol's chain of function indirections contains a loop");
3424 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3425 "Symbol's chain of variable indirections contains a loop");
3426 DEFSYM (Qcircular_list
, "circular-list");
3427 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3428 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3429 PUT_ERROR (Qsetting_constant
, error_tail
,
3430 "Attempt to set a constant symbol");
3431 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3432 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3433 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3434 "Wrong number of arguments");
3435 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3436 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3438 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3439 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3440 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3442 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3443 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3444 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3445 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3446 "Text is read-only");
3448 DEFSYM (Qrange_error
, "range-error");
3449 DEFSYM (Qdomain_error
, "domain-error");
3450 DEFSYM (Qsingularity_error
, "singularity-error");
3451 DEFSYM (Qoverflow_error
, "overflow-error");
3452 DEFSYM (Qunderflow_error
, "underflow-error");
3454 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3456 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3458 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3459 "Arithmetic singularity error");
3461 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3462 "Arithmetic overflow error");
3463 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3464 "Arithmetic underflow error");
3468 staticpro (&Qunbound
);
3470 /* Types that type-of returns. */
3471 DEFSYM (Qinteger
, "integer");
3472 DEFSYM (Qsymbol
, "symbol");
3473 DEFSYM (Qstring
, "string");
3474 DEFSYM (Qcons
, "cons");
3475 DEFSYM (Qmarker
, "marker");
3476 DEFSYM (Qoverlay
, "overlay");
3477 DEFSYM (Qfloat
, "float");
3478 DEFSYM (Qwindow_configuration
, "window-configuration");
3479 DEFSYM (Qprocess
, "process");
3480 DEFSYM (Qwindow
, "window");
3481 DEFSYM (Qcompiled_function
, "compiled-function");
3482 DEFSYM (Qbuffer
, "buffer");
3483 DEFSYM (Qframe
, "frame");
3484 DEFSYM (Qvector
, "vector");
3485 DEFSYM (Qchar_table
, "char-table");
3486 DEFSYM (Qbool_vector
, "bool-vector");
3487 DEFSYM (Qhash_table
, "hash-table");
3488 DEFSYM (Qmisc
, "misc");
3490 DEFSYM (Qdefun
, "defun");
3492 DEFSYM (Qfont_spec
, "font-spec");
3493 DEFSYM (Qfont_entity
, "font-entity");
3494 DEFSYM (Qfont_object
, "font-object");
3496 DEFSYM (Qinteractive_form
, "interactive-form");
3497 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3499 defsubr (&Sindirect_variable
);
3500 defsubr (&Sinteractive_form
);
3503 defsubr (&Stype_of
);
3508 defsubr (&Sintegerp
);
3509 defsubr (&Sinteger_or_marker_p
);
3510 defsubr (&Snumberp
);
3511 defsubr (&Snumber_or_marker_p
);
3513 defsubr (&Snatnump
);
3514 defsubr (&Ssymbolp
);
3515 defsubr (&Skeywordp
);
3516 defsubr (&Sstringp
);
3517 defsubr (&Smultibyte_string_p
);
3518 defsubr (&Svectorp
);
3519 defsubr (&Schar_table_p
);
3520 defsubr (&Svector_or_char_table_p
);
3521 defsubr (&Sbool_vector_p
);
3523 defsubr (&Ssequencep
);
3524 defsubr (&Sbufferp
);
3525 defsubr (&Smarkerp
);
3527 defsubr (&Sbyte_code_function_p
);
3528 defsubr (&Schar_or_string_p
);
3531 defsubr (&Scar_safe
);
3532 defsubr (&Scdr_safe
);
3535 defsubr (&Ssymbol_function
);
3536 defsubr (&Sindirect_function
);
3537 defsubr (&Ssymbol_plist
);
3538 defsubr (&Ssymbol_name
);
3539 defsubr (&Smakunbound
);
3540 defsubr (&Sfmakunbound
);
3542 defsubr (&Sfboundp
);
3544 defsubr (&Sdefalias
);
3545 defsubr (&Ssetplist
);
3546 defsubr (&Ssymbol_value
);
3548 defsubr (&Sdefault_boundp
);
3549 defsubr (&Sdefault_value
);
3550 defsubr (&Sset_default
);
3551 defsubr (&Ssetq_default
);
3552 defsubr (&Smake_variable_buffer_local
);
3553 defsubr (&Smake_local_variable
);
3554 defsubr (&Skill_local_variable
);
3555 defsubr (&Smake_variable_frame_local
);
3556 defsubr (&Slocal_variable_p
);
3557 defsubr (&Slocal_variable_if_set_p
);
3558 defsubr (&Svariable_binding_locus
);
3559 #if 0 /* XXX Remove this. --lorentey */
3560 defsubr (&Sterminal_local_value
);
3561 defsubr (&Sset_terminal_local_value
);
3565 defsubr (&Snumber_to_string
);
3566 defsubr (&Sstring_to_number
);
3567 defsubr (&Seqlsign
);
3590 defsubr (&Sbyteorder
);
3591 defsubr (&Ssubr_arity
);
3592 defsubr (&Ssubr_name
);
3594 defsubr (&Sbool_vector_exclusive_or
);
3595 defsubr (&Sbool_vector_union
);
3596 defsubr (&Sbool_vector_intersection
);
3597 defsubr (&Sbool_vector_set_difference
);
3598 defsubr (&Sbool_vector_not
);
3599 defsubr (&Sbool_vector_subsetp
);
3600 defsubr (&Sbool_vector_count_matches
);
3601 defsubr (&Sbool_vector_count_matches_at
);
3603 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3605 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3606 doc
: /* The largest value that is representable in a Lisp integer. */);
3607 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3608 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3610 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3611 doc
: /* The smallest value that is representable in a Lisp integer. */);
3612 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3613 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;