1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include <count-one-bits.h>
26 #include <count-trailing-zeros.h>
31 #include "character.h"
35 #include "syssignal.h"
36 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
41 Lisp_Object Qnil_
, Qt_
;
42 static Lisp_Object Qsubr
;
43 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
44 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
45 static Lisp_Object Qwrong_length_argument
;
46 static Lisp_Object Qwrong_type_argument
;
47 Lisp_Object Qvoid_variable
, Qvoid_function
;
48 static Lisp_Object Qcyclic_function_indirection
;
49 static Lisp_Object Qcyclic_variable_indirection
;
50 Lisp_Object Qcircular_list
;
51 static Lisp_Object Qsetting_constant
;
52 Lisp_Object Qinvalid_read_syntax
;
53 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
54 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
55 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
56 Lisp_Object Qtext_read_only
;
58 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
59 static Lisp_Object Qnatnump
;
60 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
61 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
62 Lisp_Object Qbool_vector_p
;
63 Lisp_Object Qbuffer_or_string_p
;
64 static Lisp_Object Qkeywordp
, Qboundp
;
66 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
69 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
71 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
72 Lisp_Object Qrange_error
, Qoverflow_error
;
75 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
77 Lisp_Object Qinteger
, Qsymbol
;
78 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
80 static Lisp_Object Qoverlay
, Qwindow_configuration
;
81 static Lisp_Object Qprocess
, Qmarker
;
82 static Lisp_Object Qcompiled_function
, Qframe
;
84 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
85 static Lisp_Object Qsubrp
;
86 static Lisp_Object Qmany
, Qunevalled
;
87 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
88 static Lisp_Object Qdefun
;
90 Lisp_Object Qspecial_operator
;
91 Lisp_Object Qinteractive_form
;
92 static Lisp_Object Qdefalias_fset_function
;
94 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
97 BOOLFWDP (union Lisp_Fwd
*a
)
99 return XFWDTYPE (a
) == Lisp_Fwd_Bool
;
102 INTFWDP (union Lisp_Fwd
*a
)
104 return XFWDTYPE (a
) == Lisp_Fwd_Int
;
107 KBOARD_OBJFWDP (union Lisp_Fwd
*a
)
109 return XFWDTYPE (a
) == Lisp_Fwd_Kboard_Obj
;
112 OBJFWDP (union Lisp_Fwd
*a
)
114 return XFWDTYPE (a
) == Lisp_Fwd_Obj
;
117 static struct Lisp_Boolfwd
*
118 XBOOLFWD (union Lisp_Fwd
*a
)
120 eassert (BOOLFWDP (a
));
121 return &a
->u_boolfwd
;
123 static struct Lisp_Kboard_Objfwd
*
124 XKBOARD_OBJFWD (union Lisp_Fwd
*a
)
126 eassert (KBOARD_OBJFWDP (a
));
127 return &a
->u_kboard_objfwd
;
129 static struct Lisp_Intfwd
*
130 XINTFWD (union Lisp_Fwd
*a
)
132 eassert (INTFWDP (a
));
135 static struct Lisp_Objfwd
*
136 XOBJFWD (union Lisp_Fwd
*a
)
138 eassert (OBJFWDP (a
));
143 CHECK_SUBR (Lisp_Object x
)
145 CHECK_TYPE (! NILP (Fsubrp (x
)), Qsubrp
, x
);
149 set_blv_found (struct Lisp_Buffer_Local_Value
*blv
, int found
)
151 eassert (found
== !EQ (blv
->defcell
, blv
->valcell
));
156 blv_value (struct Lisp_Buffer_Local_Value
*blv
)
158 return XCDR (blv
->valcell
);
162 set_blv_value (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
164 XSETCDR (blv
->valcell
, val
);
168 set_blv_where (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
174 set_blv_defcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
180 set_blv_valcell (struct Lisp_Buffer_Local_Value
*blv
, Lisp_Object val
)
185 static _Noreturn
void
186 wrong_length_argument (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
188 Lisp_Object size1
= make_number (bool_vector_size (a1
));
189 Lisp_Object size2
= make_number (bool_vector_size (a2
));
191 xsignal2 (Qwrong_length_argument
, size1
, size2
);
193 xsignal3 (Qwrong_length_argument
, size1
, size2
,
194 make_number (bool_vector_size (a3
)));
198 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
200 /* If VALUE is not even a valid Lisp object, we'd want to abort here
201 where we can get a backtrace showing where it came from. We used
202 to try and do that by checking the tagbits, but nowadays all
203 tagbits are potentially valid. */
204 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
207 xsignal2 (Qwrong_type_argument
, predicate
, value
);
211 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
213 xsignal2 (Qargs_out_of_range
, a1
, a2
);
217 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
219 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
223 /* Data type predicates. */
225 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
226 doc
: /* Return t if the two args are the same Lisp object. */)
227 (Lisp_Object obj1
, Lisp_Object obj2
)
234 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
235 doc
: /* Return t if OBJECT is nil. */)
243 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
244 doc
: /* Return a symbol representing the type of OBJECT.
245 The symbol returned names the object's basic type;
246 for example, (type-of 1) returns `integer'. */)
249 if (INTEGERP (object
))
251 else if (SYMBOLP (object
))
253 else if (STRINGP (object
))
255 else if (CONSP (object
))
257 else if (MISCP (object
))
259 switch (XMISCTYPE (object
))
261 case Lisp_Misc_Marker
:
263 case Lisp_Misc_Overlay
:
265 case Lisp_Misc_Float
:
270 else if (VECTORLIKEP (object
))
272 if (WINDOW_CONFIGURATIONP (object
))
273 return Qwindow_configuration
;
274 if (PROCESSP (object
))
276 if (WINDOWP (object
))
278 if (COMPILEDP (object
))
279 return Qcompiled_function
;
280 if (BUFFERP (object
))
282 if (CHAR_TABLE_P (object
))
284 if (BOOL_VECTOR_P (object
))
288 if (HASH_TABLE_P (object
))
290 if (FONT_SPEC_P (object
))
292 if (FONT_ENTITY_P (object
))
294 if (FONT_OBJECT_P (object
))
298 else if (FLOATP (object
))
300 else if (! NILP (Fsubrp (object
)))
306 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is a cons cell. */)
315 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
324 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
326 Otherwise, return nil. */)
329 if (CONSP (object
) || NILP (object
))
334 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
335 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
338 if (CONSP (object
) || NILP (object
))
343 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
344 doc
: /* Return t if OBJECT is a symbol. */)
347 if (SYMBOLP (object
))
353 SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym
)
355 /* Should be initial_obarray */
356 Lisp_Object tem
= Ffind_symbol (SYMBOL_NAME (sym
), Vobarray
);
357 return (! NILP (scm_c_value_ref (tem
, 1))
358 && (EQ (sym
, scm_c_value_ref (tem
, 0))));
361 /* Define this in C to avoid unnecessarily consing up the symbol
363 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
364 doc
: /* Return t if OBJECT is a keyword.
365 This means that it is a symbol with a print name beginning with `:'
366 interned in the initial obarray. */)
370 && SREF (SYMBOL_NAME (object
), 0) == ':'
371 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
376 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is a vector. */)
380 if (VECTORP (object
))
385 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
386 doc
: /* Return t if OBJECT is a string. */)
389 if (STRINGP (object
))
394 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
396 doc
: /* Return t if OBJECT is a multibyte string.
397 Return nil if OBJECT is either a unibyte string, or not a string. */)
400 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
405 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
406 doc
: /* Return t if OBJECT is a char-table. */)
409 if (CHAR_TABLE_P (object
))
414 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
415 Svector_or_char_table_p
, 1, 1, 0,
416 doc
: /* Return t if OBJECT is a char-table or vector. */)
419 if (VECTORP (object
) || CHAR_TABLE_P (object
))
424 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a bool-vector. */)
428 if (BOOL_VECTOR_P (object
))
433 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
434 doc
: /* Return t if OBJECT is an array (string or vector). */)
442 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
443 doc
: /* Return t if OBJECT is a sequence (list or array). */)
444 (register Lisp_Object object
)
446 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
451 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
452 doc
: /* Return t if OBJECT is an editor buffer. */)
455 if (BUFFERP (object
))
460 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
461 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
464 if (MARKERP (object
))
469 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
470 doc
: /* Return t if OBJECT is a built-in function. */)
473 if (CONSP (object
) && EQ (XCAR (object
), Qspecial_operator
))
474 object
= XCDR (object
);
475 if (SCM_PRIMITIVE_P (object
))
480 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
482 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
485 if (COMPILEDP (object
))
490 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
491 doc
: /* Return t if OBJECT is a character or a string. */)
492 (register Lisp_Object object
)
494 if (CHARACTERP (object
) || STRINGP (object
))
499 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
500 doc
: /* Return t if OBJECT is an integer. */)
503 if (INTEGERP (object
))
508 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
509 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
510 (register Lisp_Object object
)
512 if (MARKERP (object
) || INTEGERP (object
))
517 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
518 doc
: /* Return t if OBJECT is a nonnegative integer. */)
521 if (NATNUMP (object
))
526 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
527 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
530 if (NUMBERP (object
))
536 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
537 Snumber_or_marker_p
, 1, 1, 0,
538 doc
: /* Return t if OBJECT is a number or a marker. */)
541 if (NUMBERP (object
) || MARKERP (object
))
546 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
547 doc
: /* Return t if OBJECT is a floating point number. */)
556 /* Extract and set components of lists. */
558 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
559 doc
: /* Return the car of LIST. If arg is nil, return nil.
560 Error if arg is not nil and not a cons cell. See also `car-safe'.
562 See Info node `(elisp)Cons Cells' for a discussion of related basic
563 Lisp concepts such as car, cdr, cons cell and list. */)
564 (register Lisp_Object list
)
569 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
570 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
573 return CAR_SAFE (object
);
576 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
577 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
578 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
580 See Info node `(elisp)Cons Cells' for a discussion of related basic
581 Lisp concepts such as cdr, car, cons cell and list. */)
582 (register Lisp_Object list
)
587 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
588 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
591 return CDR_SAFE (object
);
594 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
595 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
596 (register Lisp_Object cell
, Lisp_Object newcar
)
600 XSETCAR (cell
, newcar
);
604 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
605 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
606 (register Lisp_Object cell
, Lisp_Object newcdr
)
610 XSETCDR (cell
, newcdr
);
614 /* Extract and set components of symbols. */
616 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
617 doc
: /* Return t if SYMBOL's value is not void.
618 Note that if `lexical-binding' is in effect, this refers to the
619 global value outside of any lexical scope. */)
620 (register Lisp_Object symbol
)
622 Lisp_Object valcontents
;
623 struct Lisp_Symbol
*sym
;
624 CHECK_SYMBOL (symbol
);
625 sym
= XSYMBOL (symbol
);
628 switch (sym
->redirect
)
630 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
631 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
632 case SYMBOL_LOCALIZED
:
634 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
636 /* In set_internal, we un-forward vars when their value is
641 swap_in_symval_forwarding (sym
, blv
);
642 valcontents
= blv_value (blv
);
646 case SYMBOL_FORWARDED
:
647 /* In set_internal, we un-forward vars when their value is
650 default: emacs_abort ();
653 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
656 /* FIXME: Make it an alias for function-symbol! */
657 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
658 doc
: /* Return t if SYMBOL's function definition is not void. */)
659 (register Lisp_Object symbol
)
661 CHECK_SYMBOL (symbol
);
662 return NILP (SYMBOL_FUNCTION (symbol
)) ? Qnil
: Qt
;
665 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
666 doc
: /* Make SYMBOL's value be void.
668 (register Lisp_Object symbol
)
670 CHECK_SYMBOL (symbol
);
671 if (SYMBOL_CONSTANT_P (symbol
))
672 xsignal1 (Qsetting_constant
, symbol
);
673 Fset (symbol
, Qunbound
);
677 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
678 doc
: /* Make SYMBOL's function definition be nil.
680 (register Lisp_Object symbol
)
682 CHECK_SYMBOL (symbol
);
683 if (NILP (symbol
) || EQ (symbol
, Qt
))
684 xsignal1 (Qsetting_constant
, symbol
);
685 set_symbol_function (symbol
, Qnil
);
689 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
690 doc
: /* Return SYMBOL's function definition, or nil if that is void. */)
691 (register Lisp_Object symbol
)
693 CHECK_SYMBOL (symbol
);
694 return SYMBOL_FUNCTION (symbol
);
697 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
698 doc
: /* Return SYMBOL's property list. */)
699 (register Lisp_Object symbol
)
701 CHECK_SYMBOL (symbol
);
702 return symbol_plist (symbol
);
705 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
706 doc
: /* Return SYMBOL's name, a string. */)
707 (register Lisp_Object symbol
)
709 register Lisp_Object name
;
711 CHECK_SYMBOL (symbol
);
712 name
= SYMBOL_NAME (symbol
);
716 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
717 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
718 (register Lisp_Object symbol
, Lisp_Object definition
)
720 register Lisp_Object function
;
721 CHECK_SYMBOL (symbol
);
723 function
= SYMBOL_FUNCTION (symbol
);
725 if (!NILP (Vautoload_queue
) && !NILP (function
))
726 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
728 if (AUTOLOADP (function
))
729 Fput (symbol
, Qautoload
, XCDR (function
));
731 /* Convert to eassert or remove after GC bug is found. In the
732 meantime, check unconditionally, at a slight perf hit. */
733 if (valid_lisp_object_p (definition
) < 1)
736 set_symbol_function (symbol
, definition
);
741 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
742 doc
: /* Set SYMBOL's function definition to DEFINITION.
743 Associates the function with the current load file, if any.
744 The optional third argument DOCSTRING specifies the documentation string
745 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
746 determined by DEFINITION.
748 Internally, this normally uses `fset', but if SYMBOL has a
749 `defalias-fset-function' property, the associated value is used instead.
751 The return value is undefined. */)
752 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
754 CHECK_SYMBOL (symbol
);
755 if (!NILP (Vpurify_flag
)
756 /* If `definition' is a keymap, immutable (and copying) is wrong. */
757 && !KEYMAPP (definition
))
758 definition
= Fpurecopy (definition
);
761 bool autoload
= AUTOLOADP (definition
);
762 if (NILP (Vpurify_flag
) || !autoload
)
763 { /* Only add autoload entries after dumping, because the ones before are
764 not useful and else we get loads of them from the loaddefs.el. */
766 if (AUTOLOADP (SYMBOL_FUNCTION (symbol
)))
767 /* Remember that the function was already an autoload. */
768 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
769 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
773 { /* Handle automatic advice activation. */
774 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
776 call2 (hook
, symbol
, definition
);
778 Ffset (symbol
, definition
);
781 if (!NILP (docstring
))
782 Fput (symbol
, Qfunction_documentation
, docstring
);
783 /* We used to return `definition', but now that `defun' and `defmacro' expand
784 to a call to `defalias', we return `symbol' for backward compatibility
789 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
790 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
791 (register Lisp_Object symbol
, Lisp_Object newplist
)
793 CHECK_SYMBOL (symbol
);
794 set_symbol_plist (symbol
, newplist
);
798 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
799 doc
: /* Return minimum and maximum number of args allowed for SUBR.
800 SUBR must be a built-in function.
801 The returned value is a pair (MIN . MAX). MIN is the minimum number
802 of args. MAX is the maximum number or the symbol `many', for a
803 function with `&rest' args, or `unevalled' for a special form. */)
806 Lisp_Object min
, max
;
808 bool special
= false;
811 if (CONSP (subr
) && EQ (XCAR (subr
), Qspecial_operator
))
816 arity
= scm_procedure_minimum_arity (subr
);
817 if (scm_is_false (arity
))
822 else if (scm_is_true (XCAR (XCDR (XCDR (arity
)))))
825 max
= scm_sum (min
, XCAR (XCDR (arity
)));
826 return Fcons (min
, max
);
829 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
830 doc
: /* Return name of subroutine SUBR.
831 SUBR must be a built-in function. */)
835 if (CONSP (subr
) && EQ (XCAR (subr
), Qspecial_operator
))
837 return Fsymbol_name (SCM_SUBR_NAME (subr
));
840 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
841 doc
: /* Return the interactive form of CMD or nil if none.
842 If CMD is not a command, the return value is nil.
843 Value, if non-nil, is a list \(interactive SPEC). */)
846 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
851 /* Use an `interactive-form' property if present, analogous to the
852 function-documentation property. */
854 while (SYMBOLP (fun
))
856 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
860 fun
= Fsymbol_function (fun
);
863 if (scm_is_true (scm_procedure_p (fun
)))
865 Lisp_Object tem
= scm_procedure_property (fun
, Qinteractive_form
);
866 if (scm_is_true (tem
))
867 return list2 (Qinteractive
, tem
);
869 else if (COMPILEDP (fun
))
871 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
872 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
874 else if (AUTOLOADP (fun
))
875 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
876 else if (CONSP (fun
))
878 Lisp_Object funcar
= XCAR (fun
);
879 if (EQ (funcar
, Qclosure
))
880 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
881 else if (EQ (funcar
, Qlambda
))
882 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
888 /***********************************************************************
889 Getting and Setting Values of Symbols
890 ***********************************************************************/
892 /* Return the symbol holding SYMBOL's value. Signal
893 `cyclic-variable-indirection' if SYMBOL's chain of variable
894 indirections contains a loop. */
897 indirect_variable (struct Lisp_Symbol
*symbol
)
899 struct Lisp_Symbol
*tortoise
, *hare
;
901 hare
= tortoise
= symbol
;
903 while (hare
->redirect
== SYMBOL_VARALIAS
)
905 hare
= SYMBOL_ALIAS (hare
);
906 if (hare
->redirect
!= SYMBOL_VARALIAS
)
909 hare
= SYMBOL_ALIAS (hare
);
910 tortoise
= SYMBOL_ALIAS (tortoise
);
912 if (hare
== tortoise
)
915 XSETSYMBOL (tem
, symbol
);
916 xsignal1 (Qcyclic_variable_indirection
, tem
);
924 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
925 doc
: /* Return the variable at the end of OBJECT's variable chain.
926 If OBJECT is a symbol, follow its variable indirections (if any), and
927 return the variable at the end of the chain of aliases. See Info node
928 `(elisp)Variable Aliases'.
930 If OBJECT is not a symbol, just return it. If there is a loop in the
931 chain of aliases, signal a `cyclic-variable-indirection' error. */)
934 if (SYMBOLP (object
))
936 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
937 XSETSYMBOL (object
, sym
);
943 /* Given the raw contents of a symbol value cell,
944 return the Lisp value of the symbol.
945 This does not handle buffer-local variables; use
946 swap_in_symval_forwarding for that. */
949 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
951 register Lisp_Object val
;
952 switch (XFWDTYPE (valcontents
))
955 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
959 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
962 return *XOBJFWD (valcontents
)->objvar
;
964 case Lisp_Fwd_Buffer_Obj
:
965 return per_buffer_value (current_buffer
,
966 XBUFFER_OBJFWD (valcontents
)->offset
);
968 case Lisp_Fwd_Kboard_Obj
:
969 /* We used to simply use current_kboard here, but from Lisp
970 code, its value is often unexpected. It seems nicer to
971 allow constructions like this to work as intuitively expected:
973 (with-selected-frame frame
974 (define-key local-function-map "\eOP" [f1]))
976 On the other hand, this affects the semantics of
977 last-command and real-last-command, and people may rely on
978 that. I took a quick look at the Lisp codebase, and I
979 don't think anything will break. --lorentey */
980 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
981 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
982 default: emacs_abort ();
986 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
987 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
988 buffer-independent contents of the value cell: forwarded just one
989 step past the buffer-localness.
991 BUF non-zero means set the value in buffer BUF instead of the
992 current buffer. This only plays a role for per-buffer variables. */
995 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
997 switch (XFWDTYPE (valcontents
))
1000 CHECK_NUMBER (newval
);
1001 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1005 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1009 *XOBJFWD (valcontents
)->objvar
= newval
;
1011 /* If this variable is a default for something stored
1012 in the buffer itself, such as default-fill-column,
1013 find the buffers that don't have local values for it
1015 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1016 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1018 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1019 - (char *) &buffer_defaults
);
1020 int idx
= PER_BUFFER_IDX (offset
);
1022 Lisp_Object tail
, buf
;
1027 FOR_EACH_LIVE_BUFFER (tail
, buf
)
1029 struct buffer
*b
= XBUFFER (buf
);
1031 if (! PER_BUFFER_VALUE_P (b
, idx
))
1032 set_per_buffer_value (b
, offset
, newval
);
1037 case Lisp_Fwd_Buffer_Obj
:
1039 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1040 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
1042 if (!NILP (predicate
) && !NILP (newval
)
1043 && NILP (call1 (predicate
, newval
)))
1044 wrong_type_argument (predicate
, newval
);
1047 buf
= current_buffer
;
1048 set_per_buffer_value (buf
, offset
, newval
);
1052 case Lisp_Fwd_Kboard_Obj
:
1054 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1055 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1056 *(Lisp_Object
*) p
= newval
;
1061 emacs_abort (); /* goto def; */
1065 /* Set up SYMBOL to refer to its global binding. This makes it safe
1066 to alter the status of other bindings. BEWARE: this may be called
1067 during the mark phase of GC, where we assume that Lisp_Object slots
1068 of BLV are marked after this function has changed them. */
1071 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1073 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1075 /* Unload the previously loaded binding. */
1077 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1079 /* Select the global binding in the symbol. */
1080 set_blv_valcell (blv
, blv
->defcell
);
1082 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1084 /* Indicate that the global binding is set up now. */
1085 set_blv_where (blv
, Qnil
);
1086 set_blv_found (blv
, 0);
1089 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1090 VALCONTENTS is the contents of its value cell,
1091 which points to a struct Lisp_Buffer_Local_Value.
1093 Return the value forwarded one step past the buffer-local stage.
1094 This could be another forwarding pointer. */
1097 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1099 register Lisp_Object tem1
;
1101 eassert (blv
== SYMBOL_BLV (symbol
));
1106 || (blv
->frame_local
1107 ? !EQ (selected_frame
, tem1
)
1108 : current_buffer
!= XBUFFER (tem1
)))
1111 /* Unload the previously loaded binding. */
1112 tem1
= blv
->valcell
;
1114 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1115 /* Choose the new binding. */
1118 XSETSYMBOL (var
, symbol
);
1119 if (blv
->frame_local
)
1121 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1122 set_blv_where (blv
, selected_frame
);
1126 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1127 set_blv_where (blv
, Fcurrent_buffer ());
1130 if (!(blv
->found
= !NILP (tem1
)))
1131 tem1
= blv
->defcell
;
1133 /* Load the new binding. */
1134 set_blv_valcell (blv
, tem1
);
1136 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1140 /* Find the value of a symbol, returning Qunbound if it's not bound.
1141 This is helpful for code which just wants to get a variable's value
1142 if it has one, without signaling an error.
1143 Note that it must not be possible to quit
1144 within this function. Great care is required for this. */
1147 find_symbol_value (Lisp_Object symbol
)
1149 struct Lisp_Symbol
*sym
;
1151 CHECK_SYMBOL (symbol
);
1152 sym
= XSYMBOL (symbol
);
1155 switch (sym
->redirect
)
1157 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1158 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1159 case SYMBOL_LOCALIZED
:
1161 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1162 swap_in_symval_forwarding (sym
, blv
);
1163 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1166 case SYMBOL_FORWARDED
:
1167 return do_symval_forwarding (SYMBOL_FWD (sym
));
1168 default: emacs_abort ();
1172 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1173 doc
: /* Return SYMBOL's value. Error if that is void.
1174 Note that if `lexical-binding' is in effect, this returns the
1175 global value outside of any lexical scope. */)
1176 (Lisp_Object symbol
)
1180 val
= find_symbol_value (symbol
);
1181 if (!EQ (val
, Qunbound
))
1184 xsignal1 (Qvoid_variable
, symbol
);
1187 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1188 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1189 (register Lisp_Object symbol
, Lisp_Object newval
)
1191 set_internal (symbol
, newval
, Qnil
, 0);
1195 /* Store the value NEWVAL into SYMBOL.
1196 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1197 (nil stands for the current buffer/frame).
1199 If BINDFLAG is false, then if this symbol is supposed to become
1200 local in every buffer where it is set, then we make it local.
1201 If BINDFLAG is true, we don't do that. */
1204 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1207 bool voide
= EQ (newval
, Qunbound
);
1208 struct Lisp_Symbol
*sym
;
1211 /* If restoring in a dead buffer, do nothing. */
1212 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1215 CHECK_SYMBOL (symbol
);
1216 if (SYMBOL_CONSTANT_P (symbol
))
1218 if (NILP (Fkeywordp (symbol
))
1219 || !EQ (newval
, Fsymbol_value (symbol
)))
1220 xsignal1 (Qsetting_constant
, symbol
);
1222 /* Allow setting keywords to their own value. */
1226 sym
= XSYMBOL (symbol
);
1229 switch (sym
->redirect
)
1231 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1232 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1233 case SYMBOL_LOCALIZED
:
1235 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1238 if (blv
->frame_local
)
1239 where
= selected_frame
;
1241 XSETBUFFER (where
, current_buffer
);
1243 /* If the current buffer is not the buffer whose binding is
1244 loaded, or if there may be frame-local bindings and the frame
1245 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1246 the default binding is loaded, the loaded binding may be the
1248 if (!EQ (blv
->where
, where
)
1249 /* Also unload a global binding (if the var is local_if_set). */
1250 || (EQ (blv
->valcell
, blv
->defcell
)))
1252 /* The currently loaded binding is not necessarily valid.
1253 We need to unload it, and choose a new binding. */
1255 /* Write out `realvalue' to the old loaded binding. */
1257 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1259 /* Find the new binding. */
1260 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1261 tem1
= Fassq (symbol
,
1263 ? XFRAME (where
)->param_alist
1264 : BVAR (XBUFFER (where
), local_var_alist
)));
1265 set_blv_where (blv
, where
);
1270 /* This buffer still sees the default value. */
1272 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1273 or if this is `let' rather than `set',
1274 make CURRENT-ALIST-ELEMENT point to itself,
1275 indicating that we're seeing the default value.
1276 Likewise if the variable has been let-bound
1277 in the current buffer. */
1278 if (bindflag
|| !blv
->local_if_set
1279 || let_shadows_buffer_binding_p (sym
))
1282 tem1
= blv
->defcell
;
1284 /* If it's a local_if_set, being set not bound,
1285 and we're not within a let that was made for this buffer,
1286 create a new buffer-local binding for the variable.
1287 That means, give this buffer a new assoc for a local value
1288 and load that binding. */
1291 /* local_if_set is only supported for buffer-local
1292 bindings, not for frame-local bindings. */
1293 eassert (!blv
->frame_local
);
1294 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1295 bset_local_var_alist
1297 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1301 /* Record which binding is now loaded. */
1302 set_blv_valcell (blv
, tem1
);
1305 /* Store the new value in the cons cell. */
1306 set_blv_value (blv
, newval
);
1311 /* If storing void (making the symbol void), forward only through
1312 buffer-local indicator, not through Lisp_Objfwd, etc. */
1315 store_symval_forwarding (blv
->fwd
, newval
,
1317 ? XBUFFER (where
) : current_buffer
);
1321 case SYMBOL_FORWARDED
:
1324 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1325 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1326 if (BUFFER_OBJFWDP (innercontents
))
1328 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1329 int idx
= PER_BUFFER_IDX (offset
);
1332 && !let_shadows_buffer_binding_p (sym
))
1333 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1337 { /* If storing void (making the symbol void), forward only through
1338 buffer-local indicator, not through Lisp_Objfwd, etc. */
1339 sym
->redirect
= SYMBOL_PLAINVAL
;
1340 SET_SYMBOL_VAL (sym
, newval
);
1343 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1346 default: emacs_abort ();
1351 /* Access or set a buffer-local symbol's default value. */
1353 /* Return the default value of SYMBOL, but don't check for voidness.
1354 Return Qunbound if it is void. */
1357 default_value (Lisp_Object symbol
)
1359 struct Lisp_Symbol
*sym
;
1361 CHECK_SYMBOL (symbol
);
1362 sym
= XSYMBOL (symbol
);
1365 switch (sym
->redirect
)
1367 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1368 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1369 case SYMBOL_LOCALIZED
:
1371 /* If var is set up for a buffer that lacks a local value for it,
1372 the current value is nominally the default value.
1373 But the `realvalue' slot may be more up to date, since
1374 ordinary setq stores just that slot. So use that. */
1375 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1376 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1377 return do_symval_forwarding (blv
->fwd
);
1379 return XCDR (blv
->defcell
);
1381 case SYMBOL_FORWARDED
:
1383 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1385 /* For a built-in buffer-local variable, get the default value
1386 rather than letting do_symval_forwarding get the current value. */
1387 if (BUFFER_OBJFWDP (valcontents
))
1389 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1390 if (PER_BUFFER_IDX (offset
) != 0)
1391 return per_buffer_default (offset
);
1394 /* For other variables, get the current value. */
1395 return do_symval_forwarding (valcontents
);
1397 default: emacs_abort ();
1401 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1402 doc
: /* Return t if SYMBOL has a non-void default value.
1403 This is the value that is seen in buffers that do not have their own values
1404 for this variable. */)
1405 (Lisp_Object symbol
)
1407 register Lisp_Object value
;
1409 value
= default_value (symbol
);
1410 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1413 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1414 doc
: /* Return SYMBOL's default value.
1415 This is the value that is seen in buffers that do not have their own values
1416 for this variable. The default value is meaningful for variables with
1417 local bindings in certain buffers. */)
1418 (Lisp_Object symbol
)
1420 Lisp_Object value
= default_value (symbol
);
1421 if (!EQ (value
, Qunbound
))
1424 xsignal1 (Qvoid_variable
, symbol
);
1427 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1428 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1429 The default value is seen in buffers that do not have their own values
1430 for this variable. */)
1431 (Lisp_Object symbol
, Lisp_Object value
)
1433 struct Lisp_Symbol
*sym
;
1435 CHECK_SYMBOL (symbol
);
1436 if (SYMBOL_CONSTANT_P (symbol
))
1438 if (NILP (Fkeywordp (symbol
))
1439 || !EQ (value
, Fdefault_value (symbol
)))
1440 xsignal1 (Qsetting_constant
, symbol
);
1442 /* Allow setting keywords to their own value. */
1445 sym
= XSYMBOL (symbol
);
1448 switch (sym
->redirect
)
1450 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1451 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1452 case SYMBOL_LOCALIZED
:
1454 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1456 /* Store new value into the DEFAULT-VALUE slot. */
1457 XSETCDR (blv
->defcell
, value
);
1459 /* If the default binding is now loaded, set the REALVALUE slot too. */
1460 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1461 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1464 case SYMBOL_FORWARDED
:
1466 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1468 /* Handle variables like case-fold-search that have special slots
1470 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1471 if (BUFFER_OBJFWDP (valcontents
))
1473 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1474 int idx
= PER_BUFFER_IDX (offset
);
1476 set_per_buffer_default (offset
, value
);
1478 /* If this variable is not always local in all buffers,
1479 set it in the buffers that don't nominally have a local value. */
1485 if (!PER_BUFFER_VALUE_P (b
, idx
))
1486 set_per_buffer_value (b
, offset
, value
);
1491 return Fset (symbol
, value
);
1493 default: emacs_abort ();
1497 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1498 doc
: /* Set the default value of variable VAR to VALUE.
1499 VAR, the variable name, is literal (not evaluated);
1500 VALUE is an expression: it is evaluated and its value returned.
1501 The default value of a variable is seen in buffers
1502 that do not have their own values for the variable.
1504 More generally, you can use multiple variables and values, as in
1505 (setq-default VAR VALUE VAR VALUE...)
1506 This sets each VAR's default value to the corresponding VALUE.
1507 The VALUE for the Nth VAR can refer to the new default values
1509 usage: (setq-default [VAR VALUE]...) */)
1512 Lisp_Object args_left
, symbol
, val
;
1513 struct gcpro gcpro1
;
1515 args_left
= val
= args
;
1518 while (CONSP (args_left
))
1520 val
= eval_sub (Fcar (XCDR (args_left
)));
1521 symbol
= XCAR (args_left
);
1522 Fset_default (symbol
, val
);
1523 args_left
= Fcdr (XCDR (args_left
));
1530 /* Lisp functions for creating and removing buffer-local variables. */
1535 union Lisp_Fwd
*fwd
;
1538 static struct Lisp_Buffer_Local_Value
*
1539 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1540 union Lisp_Val_Fwd valcontents
)
1542 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1546 XSETSYMBOL (symbol
, sym
);
1547 tem
= Fcons (symbol
, (forwarded
1548 ? do_symval_forwarding (valcontents
.fwd
)
1549 : valcontents
.value
));
1551 /* Buffer_Local_Values cannot have as realval a buffer-local
1552 or keyboard-local forwarding. */
1553 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1554 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1555 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1556 set_blv_where (blv
, Qnil
);
1557 blv
->frame_local
= 0;
1558 blv
->local_if_set
= 0;
1559 set_blv_defcell (blv
, tem
);
1560 set_blv_valcell (blv
, tem
);
1561 set_blv_found (blv
, 0);
1565 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1566 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1567 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1568 At any time, the value for the current buffer is in effect,
1569 unless the variable has never been set in this buffer,
1570 in which case the default value is in effect.
1571 Note that binding the variable with `let', or setting it while
1572 a `let'-style binding made in this buffer is in effect,
1573 does not make the variable buffer-local. Return VARIABLE.
1575 This globally affects all uses of this variable, so it belongs together with
1576 the variable declaration, rather than with its uses (if you just want to make
1577 a variable local to the current buffer for one particular use, use
1578 `make-local-variable'). Buffer-local bindings are normally cleared
1579 while setting up a new major mode, unless they have a `permanent-local'
1582 The function `default-value' gets the default value and `set-default' sets it. */)
1583 (register Lisp_Object variable
)
1585 struct Lisp_Symbol
*sym
;
1586 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1587 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1588 bool forwarded
IF_LINT (= 0);
1590 CHECK_SYMBOL (variable
);
1591 sym
= XSYMBOL (variable
);
1594 switch (sym
->redirect
)
1596 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1597 case SYMBOL_PLAINVAL
:
1598 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1599 if (EQ (valcontents
.value
, Qunbound
))
1600 valcontents
.value
= Qnil
;
1602 case SYMBOL_LOCALIZED
:
1603 blv
= SYMBOL_BLV (sym
);
1604 if (blv
->frame_local
)
1605 error ("Symbol %s may not be buffer-local",
1606 SDATA (SYMBOL_NAME (variable
)));
1608 case SYMBOL_FORWARDED
:
1609 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1610 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1611 error ("Symbol %s may not be buffer-local",
1612 SDATA (SYMBOL_NAME (variable
)));
1613 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1616 default: emacs_abort ();
1620 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1624 blv
= make_blv (sym
, forwarded
, valcontents
);
1625 sym
->redirect
= SYMBOL_LOCALIZED
;
1626 SET_SYMBOL_BLV (sym
, blv
);
1629 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1630 if (let_shadows_global_binding_p (symbol
))
1631 message ("Making %s buffer-local while let-bound!",
1632 SDATA (SYMBOL_NAME (variable
)));
1636 blv
->local_if_set
= 1;
1640 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1641 1, 1, "vMake Local Variable: ",
1642 doc
: /* Make VARIABLE have a separate value in the current buffer.
1643 Other buffers will continue to share a common default value.
1644 \(The buffer-local value of VARIABLE starts out as the same value
1645 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1648 If the variable is already arranged to become local when set,
1649 this function causes a local value to exist for this buffer,
1650 just as setting the variable would do.
1652 This function returns VARIABLE, and therefore
1653 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1656 See also `make-variable-buffer-local'.
1658 Do not use `make-local-variable' to make a hook variable buffer-local.
1659 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1660 (Lisp_Object variable
)
1663 bool forwarded
IF_LINT (= 0);
1664 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1665 struct Lisp_Symbol
*sym
;
1666 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1668 CHECK_SYMBOL (variable
);
1669 sym
= XSYMBOL (variable
);
1672 switch (sym
->redirect
)
1674 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1675 case SYMBOL_PLAINVAL
:
1676 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1677 case SYMBOL_LOCALIZED
:
1678 blv
= SYMBOL_BLV (sym
);
1679 if (blv
->frame_local
)
1680 error ("Symbol %s may not be buffer-local",
1681 SDATA (SYMBOL_NAME (variable
)));
1683 case SYMBOL_FORWARDED
:
1684 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1685 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1686 error ("Symbol %s may not be buffer-local",
1687 SDATA (SYMBOL_NAME (variable
)));
1689 default: emacs_abort ();
1693 error ("Symbol %s may not be buffer-local",
1694 SDATA (SYMBOL_NAME (variable
)));
1696 if (blv
? blv
->local_if_set
1697 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1699 tem
= Fboundp (variable
);
1700 /* Make sure the symbol has a local value in this particular buffer,
1701 by setting it to the same value it already has. */
1702 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1707 blv
= make_blv (sym
, forwarded
, valcontents
);
1708 sym
->redirect
= SYMBOL_LOCALIZED
;
1709 SET_SYMBOL_BLV (sym
, blv
);
1712 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1713 if (let_shadows_global_binding_p (symbol
))
1714 message ("Making %s local to %s while let-bound!",
1715 SDATA (SYMBOL_NAME (variable
)),
1716 SDATA (BVAR (current_buffer
, name
)));
1720 /* Make sure this buffer has its own value of symbol. */
1721 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1722 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1725 if (let_shadows_buffer_binding_p (sym
))
1726 message ("Making %s buffer-local while locally let-bound!",
1727 SDATA (SYMBOL_NAME (variable
)));
1729 /* Swap out any local binding for some other buffer, and make
1730 sure the current value is permanently recorded, if it's the
1732 find_symbol_value (variable
);
1734 bset_local_var_alist
1736 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1737 BVAR (current_buffer
, local_var_alist
)));
1739 /* Make sure symbol does not think it is set up for this buffer;
1740 force it to look once again for this buffer's value. */
1741 if (current_buffer
== XBUFFER (blv
->where
))
1742 set_blv_where (blv
, Qnil
);
1743 set_blv_found (blv
, 0);
1746 /* If the symbol forwards into a C variable, then load the binding
1747 for this buffer now. If C code modifies the variable before we
1748 load the binding in, then that new value will clobber the default
1749 binding the next time we unload it. */
1751 swap_in_symval_forwarding (sym
, blv
);
1756 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1757 1, 1, "vKill Local Variable: ",
1758 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1759 From now on the default value will apply in this buffer. Return VARIABLE. */)
1760 (register Lisp_Object variable
)
1762 register Lisp_Object tem
;
1763 struct Lisp_Buffer_Local_Value
*blv
;
1764 struct Lisp_Symbol
*sym
;
1766 CHECK_SYMBOL (variable
);
1767 sym
= XSYMBOL (variable
);
1770 switch (sym
->redirect
)
1772 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1773 case SYMBOL_PLAINVAL
: return variable
;
1774 case SYMBOL_FORWARDED
:
1776 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1777 if (BUFFER_OBJFWDP (valcontents
))
1779 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1780 int idx
= PER_BUFFER_IDX (offset
);
1784 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1785 set_per_buffer_value (current_buffer
, offset
,
1786 per_buffer_default (offset
));
1791 case SYMBOL_LOCALIZED
:
1792 blv
= SYMBOL_BLV (sym
);
1793 if (blv
->frame_local
)
1796 default: emacs_abort ();
1799 /* Get rid of this buffer's alist element, if any. */
1800 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1801 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1803 bset_local_var_alist
1805 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1807 /* If the symbol is set up with the current buffer's binding
1808 loaded, recompute its value. We have to do it now, or else
1809 forwarded objects won't work right. */
1811 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1812 if (EQ (buf
, blv
->where
))
1814 set_blv_where (blv
, Qnil
);
1816 find_symbol_value (variable
);
1823 /* Lisp functions for creating and removing buffer-local variables. */
1825 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1826 when/if this is removed. */
1828 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1829 1, 1, "vMake Variable Frame Local: ",
1830 doc
: /* Enable VARIABLE to have frame-local bindings.
1831 This does not create any frame-local bindings for VARIABLE,
1832 it just makes them possible.
1834 A frame-local binding is actually a frame parameter value.
1835 If a frame F has a value for the frame parameter named VARIABLE,
1836 that also acts as a frame-local binding for VARIABLE in F--
1837 provided this function has been called to enable VARIABLE
1838 to have frame-local bindings at all.
1840 The only way to create a frame-local binding for VARIABLE in a frame
1841 is to set the VARIABLE frame parameter of that frame. See
1842 `modify-frame-parameters' for how to set frame parameters.
1844 Note that since Emacs 23.1, variables cannot be both buffer-local and
1845 frame-local any more (buffer-local bindings used to take precedence over
1846 frame-local bindings). */)
1847 (Lisp_Object variable
)
1850 union Lisp_Val_Fwd valcontents
;
1851 struct Lisp_Symbol
*sym
;
1852 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1854 CHECK_SYMBOL (variable
);
1855 sym
= XSYMBOL (variable
);
1858 switch (sym
->redirect
)
1860 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1861 case SYMBOL_PLAINVAL
:
1862 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1863 if (EQ (valcontents
.value
, Qunbound
))
1864 valcontents
.value
= Qnil
;
1866 case SYMBOL_LOCALIZED
:
1867 if (SYMBOL_BLV (sym
)->frame_local
)
1870 error ("Symbol %s may not be frame-local",
1871 SDATA (SYMBOL_NAME (variable
)));
1872 case SYMBOL_FORWARDED
:
1873 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1874 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1875 error ("Symbol %s may not be frame-local",
1876 SDATA (SYMBOL_NAME (variable
)));
1878 default: emacs_abort ();
1882 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1884 blv
= make_blv (sym
, forwarded
, valcontents
);
1885 blv
->frame_local
= 1;
1886 sym
->redirect
= SYMBOL_LOCALIZED
;
1887 SET_SYMBOL_BLV (sym
, blv
);
1890 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1891 if (let_shadows_global_binding_p (symbol
))
1892 message ("Making %s frame-local while let-bound!",
1893 SDATA (SYMBOL_NAME (variable
)));
1898 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1900 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1901 BUFFER defaults to the current buffer. */)
1902 (register Lisp_Object variable
, Lisp_Object buffer
)
1904 register struct buffer
*buf
;
1905 struct Lisp_Symbol
*sym
;
1908 buf
= current_buffer
;
1911 CHECK_BUFFER (buffer
);
1912 buf
= XBUFFER (buffer
);
1915 CHECK_SYMBOL (variable
);
1916 sym
= XSYMBOL (variable
);
1919 switch (sym
->redirect
)
1921 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1922 case SYMBOL_PLAINVAL
: return Qnil
;
1923 case SYMBOL_LOCALIZED
:
1925 Lisp_Object tail
, elt
, tmp
;
1926 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1927 XSETBUFFER (tmp
, buf
);
1928 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1930 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1931 return blv_found (blv
) ? Qt
: Qnil
;
1933 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1936 if (EQ (variable
, XCAR (elt
)))
1938 eassert (!blv
->frame_local
);
1944 case SYMBOL_FORWARDED
:
1946 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1947 if (BUFFER_OBJFWDP (valcontents
))
1949 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1950 int idx
= PER_BUFFER_IDX (offset
);
1951 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1956 default: emacs_abort ();
1960 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1962 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1963 BUFFER defaults to the current buffer.
1965 More precisely, return non-nil if either VARIABLE already has a local
1966 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1967 `make-variable-buffer-local'). */)
1968 (register Lisp_Object variable
, Lisp_Object buffer
)
1970 struct Lisp_Symbol
*sym
;
1972 CHECK_SYMBOL (variable
);
1973 sym
= XSYMBOL (variable
);
1976 switch (sym
->redirect
)
1978 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1979 case SYMBOL_PLAINVAL
: return Qnil
;
1980 case SYMBOL_LOCALIZED
:
1982 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1983 if (blv
->local_if_set
)
1985 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1986 return Flocal_variable_p (variable
, buffer
);
1988 case SYMBOL_FORWARDED
:
1989 /* All BUFFER_OBJFWD slots become local if they are set. */
1990 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1991 default: emacs_abort ();
1995 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1997 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1998 If the current binding is buffer-local, the value is the current buffer.
1999 If the current binding is frame-local, the value is the selected frame.
2000 If the current binding is global (the default), the value is nil. */)
2001 (register Lisp_Object variable
)
2003 struct Lisp_Symbol
*sym
;
2005 CHECK_SYMBOL (variable
);
2006 sym
= XSYMBOL (variable
);
2008 /* Make sure the current binding is actually swapped in. */
2009 find_symbol_value (variable
);
2012 switch (sym
->redirect
)
2014 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2015 case SYMBOL_PLAINVAL
: return Qnil
;
2016 case SYMBOL_FORWARDED
:
2018 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2019 if (KBOARD_OBJFWDP (valcontents
))
2020 return Fframe_terminal (selected_frame
);
2021 else if (!BUFFER_OBJFWDP (valcontents
))
2025 case SYMBOL_LOCALIZED
:
2026 /* For a local variable, record both the symbol and which
2027 buffer's or frame's value we are saving. */
2028 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2029 return Fcurrent_buffer ();
2030 else if (sym
->redirect
== SYMBOL_LOCALIZED
2031 && blv_found (SYMBOL_BLV (sym
)))
2032 return SYMBOL_BLV (sym
)->where
;
2035 default: emacs_abort ();
2039 /* This code is disabled now that we use the selected frame to return
2040 keyboard-local-values. */
2042 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2044 DEFUN ("terminal-local-value", Fterminal_local_value
,
2045 Sterminal_local_value
, 2, 2, 0,
2046 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2047 If SYMBOL is not a terminal-local variable, then return its normal
2048 value, like `symbol-value'.
2050 TERMINAL may be a terminal object, a frame, or nil (meaning the
2051 selected frame's terminal device). */)
2052 (Lisp_Object symbol
, Lisp_Object terminal
)
2055 struct terminal
*t
= get_terminal (terminal
, 1);
2056 push_kboard (t
->kboard
);
2057 result
= Fsymbol_value (symbol
);
2062 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2063 Sset_terminal_local_value
, 3, 3, 0,
2064 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2065 If VARIABLE is not a terminal-local variable, then set its normal
2066 binding, like `set'.
2068 TERMINAL may be a terminal object, a frame, or nil (meaning the
2069 selected frame's terminal device). */)
2070 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2073 struct terminal
*t
= get_terminal (terminal
, 1);
2074 push_kboard (d
->kboard
);
2075 result
= Fset (symbol
, value
);
2081 /* Find the function at the end of a chain of symbol function indirections. */
2083 /* If OBJECT is a symbol, find the end of its function chain and
2084 return the value found there. If OBJECT is not a symbol, just
2085 return it. If there is a cycle in the function chain, signal a
2086 cyclic-function-indirection error.
2088 This is like Findirect_function, except that it doesn't signal an
2089 error if the chain ends up unbound. */
2091 indirect_function (register Lisp_Object object
)
2093 Lisp_Object tortoise
, hare
;
2095 hare
= tortoise
= object
;
2099 if (!SYMBOLP (hare
) || NILP (hare
))
2101 hare
= SYMBOL_FUNCTION (hare
);
2102 if (!SYMBOLP (hare
) || NILP (hare
))
2104 hare
= SYMBOL_FUNCTION (hare
);
2106 tortoise
= SYMBOL_FUNCTION (tortoise
);
2108 if (EQ (hare
, tortoise
))
2109 xsignal1 (Qcyclic_function_indirection
, object
);
2115 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2116 doc
: /* Return the function at the end of OBJECT's function chain.
2117 If OBJECT is not a symbol, just return it. Otherwise, follow all
2118 function indirections to find the final function binding and return it.
2119 If the final symbol in the chain is unbound, signal a void-function error.
2120 Optional arg NOERROR non-nil means to return nil instead of signaling.
2121 Signal a cyclic-function-indirection error if there is a loop in the
2122 function chain of symbols. */)
2123 (register Lisp_Object object
, Lisp_Object noerror
)
2127 /* Optimize for no indirection. */
2129 if (SYMBOLP (result
) && !NILP (result
)
2130 && (result
= SYMBOL_FUNCTION (result
), SYMBOLP (result
)))
2131 result
= indirect_function (result
);
2136 xsignal1 (Qvoid_function
, object
);
2141 /* Extract and set vector and string elements. */
2143 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2144 doc
: /* Return the element of ARRAY at index IDX.
2145 ARRAY may be a vector, a string, a char-table, a bool-vector,
2146 or a byte-code object. IDX starts at 0. */)
2147 (register Lisp_Object array
, Lisp_Object idx
)
2149 register EMACS_INT idxval
;
2152 idxval
= XINT (idx
);
2153 if (STRINGP (array
))
2156 ptrdiff_t idxval_byte
;
2158 if (idxval
< 0 || idxval
>= SCHARS (array
))
2159 args_out_of_range (array
, idx
);
2160 if (! STRING_MULTIBYTE (array
))
2161 return make_number ((unsigned char) SREF (array
, idxval
));
2162 idxval_byte
= string_char_to_byte (array
, idxval
);
2164 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2165 return make_number (c
);
2167 else if (BOOL_VECTOR_P (array
))
2169 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2170 args_out_of_range (array
, idx
);
2171 return bool_vector_ref (array
, idxval
);
2173 else if (CHAR_TABLE_P (array
))
2175 CHECK_CHARACTER (idx
);
2176 return CHAR_TABLE_REF (array
, idxval
);
2181 if (VECTORP (array
))
2182 size
= ASIZE (array
);
2183 else if (COMPILEDP (array
))
2184 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2186 wrong_type_argument (Qarrayp
, array
);
2188 if (idxval
< 0 || idxval
>= size
)
2189 args_out_of_range (array
, idx
);
2190 return AREF (array
, idxval
);
2194 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2195 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2196 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2197 bool-vector. IDX starts at 0. */)
2198 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2200 register EMACS_INT idxval
;
2203 idxval
= XINT (idx
);
2204 CHECK_ARRAY (array
, Qarrayp
);
2205 CHECK_IMPURE (array
);
2207 if (VECTORP (array
))
2209 if (idxval
< 0 || idxval
>= ASIZE (array
))
2210 args_out_of_range (array
, idx
);
2211 ASET (array
, idxval
, newelt
);
2213 else if (BOOL_VECTOR_P (array
))
2215 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2216 args_out_of_range (array
, idx
);
2217 bool_vector_set (array
, idxval
, !NILP (newelt
));
2219 else if (CHAR_TABLE_P (array
))
2221 CHECK_CHARACTER (idx
);
2222 CHAR_TABLE_SET (array
, idxval
, newelt
);
2228 if (idxval
< 0 || idxval
>= SCHARS (array
))
2229 args_out_of_range (array
, idx
);
2230 CHECK_CHARACTER (newelt
);
2231 c
= XFASTINT (newelt
);
2233 if (STRING_MULTIBYTE (array
))
2235 ptrdiff_t idxval_byte
, nbytes
;
2236 int prev_bytes
, new_bytes
;
2237 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2239 nbytes
= SBYTES (array
);
2240 idxval_byte
= string_char_to_byte (array
, idxval
);
2241 p1
= SDATA (array
) + idxval_byte
;
2242 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2243 new_bytes
= CHAR_STRING (c
, p0
);
2244 if (prev_bytes
!= new_bytes
)
2246 /* We must relocate the string data. */
2247 ptrdiff_t nchars
= SCHARS (array
);
2249 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2251 memcpy (str
, SDATA (array
), nbytes
);
2252 allocate_string_data (XSTRING (array
), nchars
,
2253 nbytes
+ new_bytes
- prev_bytes
);
2254 memcpy (SDATA (array
), str
, idxval_byte
);
2255 p1
= SDATA (array
) + idxval_byte
;
2256 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2257 nbytes
- (idxval_byte
+ prev_bytes
));
2259 clear_string_char_byte_cache ();
2266 if (! SINGLE_BYTE_CHAR_P (c
))
2270 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2271 if (SREF (array
, i
) >= 0x80)
2272 args_out_of_range (array
, newelt
);
2273 /* ARRAY is an ASCII string. Convert it to a multibyte
2274 string, and try `aset' again. */
2275 STRING_SET_MULTIBYTE (array
);
2276 return Faset (array
, idx
, newelt
);
2278 SSET (array
, idxval
, c
);
2285 /* Arithmetic functions */
2288 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2290 double f1
= 0, f2
= 0;
2293 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2294 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2296 if (FLOATP (num1
) || FLOATP (num2
))
2299 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2300 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2306 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2310 case ARITH_NOTEQUAL
:
2311 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2316 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2320 case ARITH_LESS_OR_EQUAL
:
2321 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2326 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2330 case ARITH_GRTR_OR_EQUAL
:
2331 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2341 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2342 enum Arith_Comparison comparison
)
2345 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2347 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2353 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2354 doc
: /* Return t if args, all numbers or markers, are equal.
2355 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2356 (ptrdiff_t nargs
, Lisp_Object
*args
)
2358 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2361 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2362 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2363 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2364 (ptrdiff_t nargs
, Lisp_Object
*args
)
2366 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2369 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2370 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2371 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2372 (ptrdiff_t nargs
, Lisp_Object
*args
)
2374 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2377 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2378 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2379 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2380 (ptrdiff_t nargs
, Lisp_Object
*args
)
2382 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2385 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2386 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2387 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2388 (ptrdiff_t nargs
, Lisp_Object
*args
)
2390 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2393 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2394 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2395 (register Lisp_Object num1
, Lisp_Object num2
)
2397 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2400 /* Convert the cons-of-integers, integer, or float value C to an
2401 unsigned value with maximum value MAX. Signal an error if C does not
2402 have a valid format or is out of range. */
2404 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2407 uintmax_t val
IF_LINT (= 0);
2410 valid
= 0 <= XINT (c
);
2413 else if (FLOATP (c
))
2415 double d
= XFLOAT_DATA (c
);
2417 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2423 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2425 uintmax_t top
= XFASTINT (XCAR (c
));
2426 Lisp_Object rest
= XCDR (c
);
2427 if (top
<= UINTMAX_MAX
>> 24 >> 16
2429 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2430 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2432 uintmax_t mid
= XFASTINT (XCAR (rest
));
2433 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2436 else if (top
<= UINTMAX_MAX
>> 16)
2440 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2442 val
= top
<< 16 | XFASTINT (rest
);
2448 if (! (valid
&& val
<= max
))
2449 error ("Not an in-range integer, float, or cons of integers");
2453 /* Convert the cons-of-integers, integer, or float value C to a signed
2454 value with extrema MIN and MAX. Signal an error if C does not have
2455 a valid format or is out of range. */
2457 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2460 intmax_t val
IF_LINT (= 0);
2466 else if (FLOATP (c
))
2468 double d
= XFLOAT_DATA (c
);
2470 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2476 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2478 intmax_t top
= XINT (XCAR (c
));
2479 Lisp_Object rest
= XCDR (c
);
2480 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2482 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2483 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2485 intmax_t mid
= XFASTINT (XCAR (rest
));
2486 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2489 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2493 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2495 val
= top
<< 16 | XFASTINT (rest
);
2501 if (! (valid
&& min
<= val
&& val
<= max
))
2502 error ("Not an in-range integer, float, or cons of integers");
2506 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2507 doc
: /* Return the decimal representation of NUMBER as a string.
2508 Uses a minus sign if negative.
2509 NUMBER may be an integer or a floating point number. */)
2510 (Lisp_Object number
)
2512 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2515 CHECK_NUMBER_OR_FLOAT (number
);
2517 if (FLOATP (number
))
2518 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2520 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2522 return make_unibyte_string (buffer
, len
);
2525 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2526 doc
: /* Parse STRING as a decimal number and return the number.
2527 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2528 STRING cannot be parsed as an integer or floating point number.
2530 If BASE, interpret STRING as a number in that base. If BASE isn't
2531 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2532 If the base used is not 10, STRING is always parsed as an integer. */)
2533 (register Lisp_Object string
, Lisp_Object base
)
2539 CHECK_STRING (string
);
2545 CHECK_NUMBER (base
);
2546 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2547 xsignal1 (Qargs_out_of_range
, base
);
2551 p
= SSDATA (string
);
2552 while (*p
== ' ' || *p
== '\t')
2555 val
= string_to_number (p
, b
, 1);
2556 return NILP (val
) ? make_number (0) : val
;
2572 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2573 ptrdiff_t, Lisp_Object
*);
2575 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2578 ptrdiff_t argnum
, ok_args
;
2579 EMACS_INT accum
= 0;
2580 EMACS_INT next
, ok_accum
;
2601 for (argnum
= 0; argnum
< nargs
; argnum
++)
2609 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2611 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2614 return float_arith_driver (ok_accum
, ok_args
, code
,
2617 next
= XINT (args
[argnum
]);
2621 if (INT_ADD_OVERFLOW (accum
, next
))
2629 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2634 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2637 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2639 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2641 accum
= ab
& INTMASK
;
2652 xsignal0 (Qarith_error
);
2666 if (!argnum
|| next
> accum
)
2670 if (!argnum
|| next
< accum
)
2676 XSETINT (val
, accum
);
2681 #define isnan(x) ((x) != (x))
2684 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2685 ptrdiff_t nargs
, Lisp_Object
*args
)
2687 register Lisp_Object val
;
2690 for (; argnum
< nargs
; argnum
++)
2692 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2693 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2697 next
= XFLOAT_DATA (val
);
2701 args
[argnum
] = val
; /* runs into a compiler bug. */
2702 next
= XINT (args
[argnum
]);
2710 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2720 if (! IEEE_FLOATING_POINT
&& next
== 0)
2721 xsignal0 (Qarith_error
);
2728 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2730 if (!argnum
|| isnan (next
) || next
> accum
)
2734 if (!argnum
|| isnan (next
) || next
< accum
)
2740 return make_float (accum
);
2744 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2745 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2746 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2747 (ptrdiff_t nargs
, Lisp_Object
*args
)
2749 return arith_driver (Aadd
, nargs
, args
);
2752 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2753 doc
: /* Negate number or subtract numbers or markers and return the result.
2754 With one arg, negates it. With more than one arg,
2755 subtracts all but the first from the first.
2756 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2757 (ptrdiff_t nargs
, Lisp_Object
*args
)
2759 return arith_driver (Asub
, nargs
, args
);
2762 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2763 doc
: /* Return product of any number of arguments, which are numbers or markers.
2764 usage: (* &rest NUMBERS-OR-MARKERS) */)
2765 (ptrdiff_t nargs
, Lisp_Object
*args
)
2767 return arith_driver (Amult
, nargs
, args
);
2770 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2771 doc
: /* Return first argument divided by all the remaining arguments.
2772 The arguments must be numbers or markers.
2773 usage: (/ DIVIDEND &rest DIVISORS) */)
2774 (ptrdiff_t nargs
, Lisp_Object
*args
)
2777 for (argnum
= 2; argnum
< nargs
; argnum
++)
2778 if (FLOATP (args
[argnum
]))
2779 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2780 return arith_driver (Adiv
, nargs
, args
);
2783 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2784 doc
: /* Return remainder of X divided by Y.
2785 Both must be integers or markers. */)
2786 (register Lisp_Object x
, Lisp_Object y
)
2790 CHECK_NUMBER_COERCE_MARKER (x
);
2791 CHECK_NUMBER_COERCE_MARKER (y
);
2794 xsignal0 (Qarith_error
);
2796 XSETINT (val
, XINT (x
) % XINT (y
));
2800 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2801 doc
: /* Return X modulo Y.
2802 The result falls between zero (inclusive) and Y (exclusive).
2803 Both X and Y must be numbers or markers. */)
2804 (register Lisp_Object x
, Lisp_Object y
)
2809 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2810 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2812 if (FLOATP (x
) || FLOATP (y
))
2813 return fmod_float (x
, y
);
2819 xsignal0 (Qarith_error
);
2823 /* If the "remainder" comes out with the wrong sign, fix it. */
2824 if (i2
< 0 ? i1
> 0 : i1
< 0)
2831 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2832 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2833 The value is always a number; markers are converted to numbers.
2834 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2835 (ptrdiff_t nargs
, Lisp_Object
*args
)
2837 return arith_driver (Amax
, nargs
, args
);
2840 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2841 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2842 The value is always a number; markers are converted to numbers.
2843 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2844 (ptrdiff_t nargs
, Lisp_Object
*args
)
2846 return arith_driver (Amin
, nargs
, args
);
2849 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2850 doc
: /* Return bitwise-and of all the arguments.
2851 Arguments may be integers, or markers converted to integers.
2852 usage: (logand &rest INTS-OR-MARKERS) */)
2853 (ptrdiff_t nargs
, Lisp_Object
*args
)
2855 return arith_driver (Alogand
, nargs
, args
);
2858 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2859 doc
: /* Return bitwise-or of all the arguments.
2860 Arguments may be integers, or markers converted to integers.
2861 usage: (logior &rest INTS-OR-MARKERS) */)
2862 (ptrdiff_t nargs
, Lisp_Object
*args
)
2864 return arith_driver (Alogior
, nargs
, args
);
2867 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2868 doc
: /* Return bitwise-exclusive-or of all the arguments.
2869 Arguments may be integers, or markers converted to integers.
2870 usage: (logxor &rest INTS-OR-MARKERS) */)
2871 (ptrdiff_t nargs
, Lisp_Object
*args
)
2873 return arith_driver (Alogxor
, nargs
, args
);
2876 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2877 doc
: /* Return VALUE with its bits shifted left by COUNT.
2878 If COUNT is negative, shifting is actually to the right.
2879 In this case, the sign bit is duplicated. */)
2880 (register Lisp_Object value
, Lisp_Object count
)
2882 register Lisp_Object val
;
2884 CHECK_NUMBER (value
);
2885 CHECK_NUMBER (count
);
2887 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2889 else if (XINT (count
) > 0)
2890 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2891 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2892 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2894 XSETINT (val
, XINT (value
) >> -XINT (count
));
2898 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2899 doc
: /* Return VALUE with its bits shifted left by COUNT.
2900 If COUNT is negative, shifting is actually to the right.
2901 In this case, zeros are shifted in on the left. */)
2902 (register Lisp_Object value
, Lisp_Object count
)
2904 register Lisp_Object val
;
2906 CHECK_NUMBER (value
);
2907 CHECK_NUMBER (count
);
2909 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2911 else if (XINT (count
) > 0)
2912 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2913 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2916 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2920 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2921 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2922 Markers are converted to integers. */)
2923 (register Lisp_Object number
)
2925 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2927 if (FLOATP (number
))
2928 return (make_float (1.0 + XFLOAT_DATA (number
)));
2930 XSETINT (number
, XINT (number
) + 1);
2934 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2935 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2936 Markers are converted to integers. */)
2937 (register Lisp_Object number
)
2939 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2941 if (FLOATP (number
))
2942 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2944 XSETINT (number
, XINT (number
) - 1);
2948 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2949 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2950 (register Lisp_Object number
)
2952 CHECK_NUMBER (number
);
2953 XSETINT (number
, ~XINT (number
));
2957 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2958 doc
: /* Return the byteorder for the machine.
2959 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2960 lowercase l) for small endian machines. */)
2963 unsigned i
= 0x04030201;
2964 int order
= *(char *)&i
== 1 ? 108 : 66;
2966 return make_number (order
);
2969 /* Because we round up the bool vector allocate size to word_size
2970 units, we can safely read past the "end" of the vector in the
2971 operations below. These extra bits are always zero. */
2974 bool_vector_spare_mask (EMACS_INT nr_bits
)
2976 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2979 /* Info about unsigned long long, falling back on unsigned long
2980 if unsigned long long is not available. */
2982 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2983 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2984 # define ULL_MAX ULLONG_MAX
2986 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
2987 # define ULL_MAX ULONG_MAX
2988 # define count_one_bits_ll count_one_bits_l
2989 # define count_trailing_zeros_ll count_trailing_zeros_l
2992 /* Shift VAL right by the width of an unsigned long long.
2993 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
2996 shift_right_ull (bits_word w
)
2998 /* Pacify bogus GCC warning about shift count exceeding type width. */
2999 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
3003 /* Return the number of 1 bits in W. */
3006 count_one_bits_word (bits_word w
)
3008 if (BITS_WORD_MAX
<= UINT_MAX
)
3009 return count_one_bits (w
);
3010 else if (BITS_WORD_MAX
<= ULONG_MAX
)
3011 return count_one_bits_l (w
);
3014 int i
= 0, count
= 0;
3015 while (count
+= count_one_bits_ll (w
),
3016 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
3017 w
= shift_right_ull (w
);
3022 enum bool_vector_op
{ bool_vector_exclusive_or
,
3024 bool_vector_intersection
,
3025 bool_vector_set_difference
,
3026 bool_vector_subsetp
};
3029 bool_vector_binop_driver (Lisp_Object a
,
3032 enum bool_vector_op op
)
3035 bits_word
*adata
, *bdata
, *destdata
;
3039 CHECK_BOOL_VECTOR (a
);
3040 CHECK_BOOL_VECTOR (b
);
3042 nr_bits
= bool_vector_size (a
);
3043 if (bool_vector_size (b
) != nr_bits
)
3044 wrong_length_argument (a
, b
, dest
);
3046 nr_words
= bool_vector_words (nr_bits
);
3047 adata
= bool_vector_data (a
);
3048 bdata
= bool_vector_data (b
);
3052 dest
= make_uninit_bool_vector (nr_bits
);
3053 destdata
= bool_vector_data (dest
);
3057 CHECK_BOOL_VECTOR (dest
);
3058 destdata
= bool_vector_data (dest
);
3059 if (bool_vector_size (dest
) != nr_bits
)
3060 wrong_length_argument (a
, b
, dest
);
3064 case bool_vector_exclusive_or
:
3065 for (; i
< nr_words
; i
++)
3066 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3070 case bool_vector_subsetp
:
3071 for (; i
< nr_words
; i
++)
3072 if (adata
[i
] &~ bdata
[i
])
3076 case bool_vector_union
:
3077 for (; i
< nr_words
; i
++)
3078 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3082 case bool_vector_intersection
:
3083 for (; i
< nr_words
; i
++)
3084 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3088 case bool_vector_set_difference
:
3089 for (; i
< nr_words
; i
++)
3090 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3101 case bool_vector_exclusive_or
:
3102 for (; i
< nr_words
; i
++)
3103 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3106 case bool_vector_union
:
3107 for (; i
< nr_words
; i
++)
3108 destdata
[i
] = adata
[i
] | bdata
[i
];
3111 case bool_vector_intersection
:
3112 for (; i
< nr_words
; i
++)
3113 destdata
[i
] = adata
[i
] & bdata
[i
];
3116 case bool_vector_set_difference
:
3117 for (; i
< nr_words
; i
++)
3118 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3128 /* PRECONDITION must be true. Return VALUE. This odd construction
3129 works around a bogus GCC diagnostic "shift count >= width of type". */
3132 pre_value (bool precondition
, int value
)
3134 eassume (precondition
);
3135 return precondition
? value
: 0;
3138 /* Compute the number of trailing zero bits in val. If val is zero,
3139 return the number of bits in val. */
3141 count_trailing_zero_bits (bits_word val
)
3143 if (BITS_WORD_MAX
== UINT_MAX
)
3144 return count_trailing_zeros (val
);
3145 if (BITS_WORD_MAX
== ULONG_MAX
)
3146 return count_trailing_zeros_l (val
);
3147 if (BITS_WORD_MAX
== ULL_MAX
)
3148 return count_trailing_zeros_ll (val
);
3150 /* The rest of this code is for the unlikely platform where bits_word differs
3151 in width from unsigned int, unsigned long, and unsigned long long. */
3152 val
|= ~ BITS_WORD_MAX
;
3153 if (BITS_WORD_MAX
<= UINT_MAX
)
3154 return count_trailing_zeros (val
);
3155 if (BITS_WORD_MAX
<= ULONG_MAX
)
3156 return count_trailing_zeros_l (val
);
3161 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3162 count
+= BITS_PER_ULL
)
3165 return count
+ count_trailing_zeros_ll (val
);
3166 val
= shift_right_ull (val
);
3169 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3170 && BITS_WORD_MAX
== (bits_word
) -1)
3171 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3172 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3173 return count
+ count_trailing_zeros_ll (val
);
3178 bits_word_to_host_endian (bits_word val
)
3180 #ifndef WORDS_BIGENDIAN
3183 if (BITS_WORD_MAX
>> 31 == 1)
3184 return bswap_32 (val
);
3185 # if HAVE_UNSIGNED_LONG_LONG
3186 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3187 return bswap_64 (val
);
3192 for (i
= 0; i
< sizeof val
; i
++)
3194 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3195 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3196 val
= val
>> 1 >> (CHAR_BIT
- 1);
3203 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3204 Sbool_vector_exclusive_or
, 2, 3, 0,
3205 doc
: /* Return A ^ B, bitwise exclusive or.
3206 If optional third argument C is given, store result into C.
3207 A, B, and C must be bool vectors of the same length.
3208 Return the destination vector if it changed or nil otherwise. */)
3209 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3211 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3214 DEFUN ("bool-vector-union", Fbool_vector_union
,
3215 Sbool_vector_union
, 2, 3, 0,
3216 doc
: /* Return A | B, bitwise or.
3217 If optional third argument C is given, store result into C.
3218 A, B, and C must be bool vectors of the same length.
3219 Return the destination vector if it changed or nil otherwise. */)
3220 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3222 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3225 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3226 Sbool_vector_intersection
, 2, 3, 0,
3227 doc
: /* Return A & B, bitwise and.
3228 If optional third argument C is given, store result into C.
3229 A, B, and C must be bool vectors of the same length.
3230 Return the destination vector if it changed or nil otherwise. */)
3231 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3233 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3236 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3237 Sbool_vector_set_difference
, 2, 3, 0,
3238 doc
: /* Return A &~ B, set difference.
3239 If optional third argument C is given, store result into C.
3240 A, B, and C must be bool vectors of the same length.
3241 Return the destination vector if it changed or nil otherwise. */)
3242 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3244 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3247 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3248 Sbool_vector_subsetp
, 2, 2, 0,
3249 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3250 A and B must be bool vectors of the same length. */)
3251 (Lisp_Object a
, Lisp_Object b
)
3253 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3256 DEFUN ("bool-vector-not", Fbool_vector_not
,
3257 Sbool_vector_not
, 1, 2, 0,
3258 doc
: /* Compute ~A, set complement.
3259 If optional second argument B is given, store result into B.
3260 A and B must be bool vectors of the same length.
3261 Return the destination vector. */)
3262 (Lisp_Object a
, Lisp_Object b
)
3265 bits_word
*bdata
, *adata
;
3268 CHECK_BOOL_VECTOR (a
);
3269 nr_bits
= bool_vector_size (a
);
3272 b
= make_uninit_bool_vector (nr_bits
);
3275 CHECK_BOOL_VECTOR (b
);
3276 if (bool_vector_size (b
) != nr_bits
)
3277 wrong_length_argument (a
, b
, Qnil
);
3280 bdata
= bool_vector_data (b
);
3281 adata
= bool_vector_data (a
);
3283 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3284 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3286 if (nr_bits
% BITS_PER_BITS_WORD
)
3288 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3290 mword
&= bool_vector_spare_mask (nr_bits
);
3291 bdata
[i
] = bits_word_to_host_endian (mword
);
3297 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3298 Sbool_vector_count_population
, 1, 1, 0,
3299 doc
: /* Count how many elements in A are t.
3300 A is a bool vector. To count A's nil elements, subtract the return
3301 value from A's length. */)
3307 ptrdiff_t i
, nwords
;
3309 CHECK_BOOL_VECTOR (a
);
3311 nr_bits
= bool_vector_size (a
);
3312 nwords
= bool_vector_words (nr_bits
);
3314 adata
= bool_vector_data (a
);
3316 for (i
= 0; i
< nwords
; i
++)
3317 count
+= count_one_bits_word (adata
[i
]);
3319 return make_number (count
);
3322 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3323 Sbool_vector_count_consecutive
, 3, 3, 0,
3324 doc
: /* Count how many consecutive elements in A equal B starting at I.
3325 A is a bool vector, B is t or nil, and I is an index into A. */)
3326 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3333 bits_word mword
; /* Machine word. */
3334 ptrdiff_t pos
, pos0
;
3337 CHECK_BOOL_VECTOR (a
);
3340 nr_bits
= bool_vector_size (a
);
3341 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3342 args_out_of_range (a
, i
);
3344 adata
= bool_vector_data (a
);
3345 nr_words
= bool_vector_words (nr_bits
);
3346 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3347 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3350 /* By XORing with twiddle, we transform the problem of "count
3351 consecutive equal values" into "count the zero bits". The latter
3352 operation usually has hardware support. */
3353 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3355 /* Scan the remainder of the mword at the current offset. */
3356 if (pos
< nr_words
&& offset
!= 0)
3358 mword
= bits_word_to_host_endian (adata
[pos
]);
3362 /* Do not count the pad bits. */
3363 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3365 count
= count_trailing_zero_bits (mword
);
3367 if (count
+ offset
< BITS_PER_BITS_WORD
)
3368 return make_number (count
);
3371 /* Scan whole words until we either reach the end of the vector or
3372 find an mword that doesn't completely match. twiddle is
3373 endian-independent. */
3375 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3377 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3381 /* If we stopped because of a mismatch, see how many bits match
3382 in the current mword. */
3383 mword
= bits_word_to_host_endian (adata
[pos
]);
3385 count
+= count_trailing_zero_bits (mword
);
3387 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3389 /* If we hit the end, we might have overshot our count. Reduce
3390 the total by the number of spare bits at the end of the
3392 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3395 return make_number (count
);
3402 Lisp_Object error_tail
, arith_tail
;
3404 /* Used by defsubr. */
3405 DEFSYM (Qspecial_operator
, "special-operator");
3406 DEFSYM (Qinteractive_form
, "interactive-form");
3410 DEFSYM (Qquote
, "quote");
3411 DEFSYM (Qlambda
, "lambda");
3412 DEFSYM (Qsubr
, "subr");
3413 DEFSYM (Qerror_conditions
, "error-conditions");
3414 DEFSYM (Qerror_message
, "error-message");
3415 DEFSYM (Qtop_level
, "top-level");
3417 DEFSYM (Qerror
, "error");
3418 DEFSYM (Quser_error
, "user-error");
3419 DEFSYM (Qquit
, "quit");
3420 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3421 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3422 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3423 DEFSYM (Qvoid_function
, "void-function");
3424 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3425 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3426 DEFSYM (Qvoid_variable
, "void-variable");
3427 DEFSYM (Qsetting_constant
, "setting-constant");
3428 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3430 DEFSYM (Qinvalid_function
, "invalid-function");
3431 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3432 DEFSYM (Qno_catch
, "no-catch");
3433 DEFSYM (Qend_of_file
, "end-of-file");
3434 DEFSYM (Qarith_error
, "arith-error");
3435 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3436 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3437 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3438 DEFSYM (Qtext_read_only
, "text-read-only");
3439 DEFSYM (Qmark_inactive
, "mark-inactive");
3441 DEFSYM (Qlistp
, "listp");
3442 DEFSYM (Qconsp
, "consp");
3443 DEFSYM (Qsymbolp
, "symbolp");
3444 DEFSYM (Qkeywordp
, "keywordp");
3445 DEFSYM (Qintegerp
, "integerp");
3446 DEFSYM (Qnatnump
, "natnump");
3447 DEFSYM (Qwholenump
, "wholenump");
3448 DEFSYM (Qstringp
, "stringp");
3449 DEFSYM (Qarrayp
, "arrayp");
3450 DEFSYM (Qsequencep
, "sequencep");
3451 DEFSYM (Qbufferp
, "bufferp");
3452 DEFSYM (Qvectorp
, "vectorp");
3453 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3454 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3455 DEFSYM (Qmarkerp
, "markerp");
3456 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3457 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3458 DEFSYM (Qboundp
, "boundp");
3459 DEFSYM (Qfboundp
, "fboundp");
3461 DEFSYM (Qfloatp
, "floatp");
3462 DEFSYM (Qnumberp
, "numberp");
3463 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3465 DEFSYM (Qchar_table_p
, "char-table-p");
3466 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3468 DEFSYM (Qsubrp
, "subrp");
3469 DEFSYM (Qunevalled
, "unevalled");
3470 DEFSYM (Qmany
, "many");
3472 DEFSYM (Qcdr
, "cdr");
3474 /* Handle automatic advice activation. */
3475 DEFSYM (Qad_advice_info
, "ad-advice-info");
3476 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3478 error_tail
= pure_cons (Qerror
, Qnil
);
3480 /* ERROR is used as a signaler for random errors for which nothing else is
3483 Fput (Qerror
, Qerror_conditions
,
3485 Fput (Qerror
, Qerror_message
,
3486 build_pure_c_string ("error"));
3488 #define PUT_ERROR(sym, tail, msg) \
3489 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3490 Fput (sym, Qerror_message, build_pure_c_string (msg))
3492 PUT_ERROR (Qquit
, Qnil
, "Quit");
3494 PUT_ERROR (Quser_error
, error_tail
, "");
3495 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3496 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3497 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3498 PUT_ERROR (Qvoid_function
, error_tail
,
3499 "Symbol's function definition is void");
3500 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3501 "Symbol's chain of function indirections contains a loop");
3502 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3503 "Symbol's chain of variable indirections contains a loop");
3504 DEFSYM (Qcircular_list
, "circular-list");
3505 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3506 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3507 PUT_ERROR (Qsetting_constant
, error_tail
,
3508 "Attempt to set a constant symbol");
3509 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3510 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3511 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3512 "Wrong number of arguments");
3513 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3514 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3516 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3517 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3518 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3520 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3521 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3522 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3523 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3524 "Text is read-only");
3526 DEFSYM (Qrange_error
, "range-error");
3527 DEFSYM (Qdomain_error
, "domain-error");
3528 DEFSYM (Qsingularity_error
, "singularity-error");
3529 DEFSYM (Qoverflow_error
, "overflow-error");
3530 DEFSYM (Qunderflow_error
, "underflow-error");
3532 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3534 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3536 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3537 "Arithmetic singularity error");
3539 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3540 "Arithmetic overflow error");
3541 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3542 "Arithmetic underflow error");
3546 staticpro (&Qunbound
);
3548 /* Types that type-of returns. */
3549 DEFSYM (Qinteger
, "integer");
3550 DEFSYM (Qsymbol
, "symbol");
3551 DEFSYM (Qstring
, "string");
3552 DEFSYM (Qcons
, "cons");
3553 DEFSYM (Qmarker
, "marker");
3554 DEFSYM (Qoverlay
, "overlay");
3555 DEFSYM (Qfloat
, "float");
3556 DEFSYM (Qwindow_configuration
, "window-configuration");
3557 DEFSYM (Qprocess
, "process");
3558 DEFSYM (Qwindow
, "window");
3559 DEFSYM (Qcompiled_function
, "compiled-function");
3560 DEFSYM (Qbuffer
, "buffer");
3561 DEFSYM (Qframe
, "frame");
3562 DEFSYM (Qvector
, "vector");
3563 DEFSYM (Qchar_table
, "char-table");
3564 DEFSYM (Qbool_vector
, "bool-vector");
3565 DEFSYM (Qhash_table
, "hash-table");
3566 DEFSYM (Qmisc
, "misc");
3568 DEFSYM (Qdefun
, "defun");
3570 DEFSYM (Qfont_spec
, "font-spec");
3571 DEFSYM (Qfont_entity
, "font-entity");
3572 DEFSYM (Qfont_object
, "font-object");
3574 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3576 set_symbol_function (Qwholenump
, SYMBOL_FUNCTION (Qnatnump
));
3578 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3579 doc
: /* The largest value that is representable in a Lisp integer. */);
3580 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3581 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3583 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3584 doc
: /* The smallest value that is representable in a Lisp integer. */);
3585 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3586 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;