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 (sym_t
, 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
;
624 CHECK_SYMBOL (symbol
);
625 sym
= XSYMBOL (symbol
);
628 switch (SYMBOL_REDIRECT (sym
))
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 WRAP1 (Ffboundp
, "fboundp")
657 WRAP1 (Fmakunbound
, "makunbound")
658 WRAP1 (Ffmakunbound
, "fmakunbound")
659 WRAP1 (Fsymbol_function
, "symbol-function")
661 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
662 doc
: /* Return SYMBOL's property list. */)
663 (register Lisp_Object symbol
)
665 CHECK_SYMBOL (symbol
);
666 return symbol_plist (symbol
);
669 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
670 doc
: /* Return SYMBOL's name, a string. */)
671 (register Lisp_Object symbol
)
673 register Lisp_Object name
;
675 CHECK_SYMBOL (symbol
);
676 name
= SYMBOL_NAME (symbol
);
680 WRAP2 (Ffset
, "fset")
682 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
683 doc
: /* Set SYMBOL's function definition to DEFINITION.
684 Associates the function with the current load file, if any.
685 The optional third argument DOCSTRING specifies the documentation string
686 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
687 determined by DEFINITION.
689 Internally, this normally uses `fset', but if SYMBOL has a
690 `defalias-fset-function' property, the associated value is used instead.
692 The return value is undefined. */)
693 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
695 CHECK_SYMBOL (symbol
);
696 if (!NILP (Vpurify_flag
)
697 /* If `definition' is a keymap, immutable (and copying) is wrong. */
698 && !KEYMAPP (definition
))
699 definition
= Fpurecopy (definition
);
702 bool autoload
= AUTOLOADP (definition
);
703 if (NILP (Vpurify_flag
) || !autoload
)
704 { /* Only add autoload entries after dumping, because the ones before are
705 not useful and else we get loads of them from the loaddefs.el. */
707 if (AUTOLOADP (SYMBOL_FUNCTION (symbol
)))
708 /* Remember that the function was already an autoload. */
709 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
710 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
714 { /* Handle automatic advice activation. */
715 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
717 call2 (hook
, symbol
, definition
);
719 Ffset (symbol
, definition
);
722 if (!NILP (docstring
))
723 Fput (symbol
, Qfunction_documentation
, docstring
);
724 /* We used to return `definition', but now that `defun' and `defmacro' expand
725 to a call to `defalias', we return `symbol' for backward compatibility
730 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
731 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
732 (register Lisp_Object symbol
, Lisp_Object newplist
)
734 CHECK_SYMBOL (symbol
);
735 set_symbol_plist (symbol
, newplist
);
739 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
740 doc
: /* Return minimum and maximum number of args allowed for SUBR.
741 SUBR must be a built-in function.
742 The returned value is a pair (MIN . MAX). MIN is the minimum number
743 of args. MAX is the maximum number or the symbol `many', for a
744 function with `&rest' args, or `unevalled' for a special form. */)
747 Lisp_Object min
, max
;
749 bool special
= false;
752 if (CONSP (subr
) && EQ (XCAR (subr
), Qspecial_operator
))
757 arity
= scm_procedure_minimum_arity (subr
);
758 if (scm_is_false (arity
))
763 else if (scm_is_true (XCAR (XCDR (XCDR (arity
)))))
766 max
= scm_sum (min
, XCAR (XCDR (arity
)));
767 return Fcons (min
, max
);
770 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
771 doc
: /* Return name of subroutine SUBR.
772 SUBR must be a built-in function. */)
776 if (CONSP (subr
) && EQ (XCAR (subr
), Qspecial_operator
))
778 return Fsymbol_name (SCM_SUBR_NAME (subr
));
781 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
782 doc
: /* Return the interactive form of CMD or nil if none.
783 If CMD is not a command, the return value is nil.
784 Value, if non-nil, is a list \(interactive SPEC). */)
787 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
792 /* Use an `interactive-form' property if present, analogous to the
793 function-documentation property. */
795 while (SYMBOLP (fun
))
797 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
801 fun
= Fsymbol_function (fun
);
804 if (scm_is_true (scm_procedure_p (fun
)))
806 Lisp_Object tem
= scm_procedure_property (fun
, Qinteractive_form
);
807 if (scm_is_true (tem
))
808 return list2 (Qinteractive
, tem
);
810 else if (COMPILEDP (fun
))
812 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
813 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
815 else if (AUTOLOADP (fun
))
816 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
817 else if (CONSP (fun
))
819 Lisp_Object funcar
= XCAR (fun
);
820 if (EQ (funcar
, Qclosure
))
821 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
822 else if (EQ (funcar
, Qlambda
))
823 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
829 /***********************************************************************
830 Getting and Setting Values of Symbols
831 ***********************************************************************/
833 /* Return the symbol holding SYMBOL's value. Signal
834 `cyclic-variable-indirection' if SYMBOL's chain of variable
835 indirections contains a loop. */
838 indirect_variable (sym_t symbol
)
840 sym_t tortoise
, hare
;
842 hare
= tortoise
= symbol
;
844 while (SYMBOL_REDIRECT (hare
) == SYMBOL_VARALIAS
)
846 hare
= SYMBOL_ALIAS (hare
);
847 if (SYMBOL_REDIRECT (hare
) != SYMBOL_VARALIAS
)
850 hare
= SYMBOL_ALIAS (hare
);
851 tortoise
= SYMBOL_ALIAS (tortoise
);
853 if (hare
== tortoise
)
856 XSETSYMBOL (tem
, symbol
);
857 xsignal1 (Qcyclic_variable_indirection
, tem
);
865 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
866 doc
: /* Return the variable at the end of OBJECT's variable chain.
867 If OBJECT is a symbol, follow its variable indirections (if any), and
868 return the variable at the end of the chain of aliases. See Info node
869 `(elisp)Variable Aliases'.
871 If OBJECT is not a symbol, just return it. If there is a loop in the
872 chain of aliases, signal a `cyclic-variable-indirection' error. */)
875 if (SYMBOLP (object
))
877 sym_t sym
= indirect_variable (XSYMBOL (object
));
878 XSETSYMBOL (object
, sym
);
884 /* Given the raw contents of a symbol value cell,
885 return the Lisp value of the symbol.
886 This does not handle buffer-local variables; use
887 swap_in_symval_forwarding for that. */
890 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
892 register Lisp_Object val
;
893 switch (XFWDTYPE (valcontents
))
896 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
900 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
903 return *XOBJFWD (valcontents
)->objvar
;
905 case Lisp_Fwd_Buffer_Obj
:
906 return per_buffer_value (current_buffer
,
907 XBUFFER_OBJFWD (valcontents
)->offset
);
909 case Lisp_Fwd_Kboard_Obj
:
910 /* We used to simply use current_kboard here, but from Lisp
911 code, its value is often unexpected. It seems nicer to
912 allow constructions like this to work as intuitively expected:
914 (with-selected-frame frame
915 (define-key local-function-map "\eOP" [f1]))
917 On the other hand, this affects the semantics of
918 last-command and real-last-command, and people may rely on
919 that. I took a quick look at the Lisp codebase, and I
920 don't think anything will break. --lorentey */
921 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
922 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
923 default: emacs_abort ();
927 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
928 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
929 buffer-independent contents of the value cell: forwarded just one
930 step past the buffer-localness.
932 BUF non-zero means set the value in buffer BUF instead of the
933 current buffer. This only plays a role for per-buffer variables. */
936 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
938 switch (XFWDTYPE (valcontents
))
941 CHECK_NUMBER (newval
);
942 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
946 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
950 *XOBJFWD (valcontents
)->objvar
= newval
;
952 /* If this variable is a default for something stored
953 in the buffer itself, such as default-fill-column,
954 find the buffers that don't have local values for it
956 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
957 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
959 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
960 - (char *) &buffer_defaults
);
961 int idx
= PER_BUFFER_IDX (offset
);
963 Lisp_Object tail
, buf
;
968 FOR_EACH_LIVE_BUFFER (tail
, buf
)
970 struct buffer
*b
= XBUFFER (buf
);
972 if (! PER_BUFFER_VALUE_P (b
, idx
))
973 set_per_buffer_value (b
, offset
, newval
);
978 case Lisp_Fwd_Buffer_Obj
:
980 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
981 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
983 if (!NILP (predicate
) && !NILP (newval
)
984 && NILP (call1 (predicate
, newval
)))
985 wrong_type_argument (predicate
, newval
);
988 buf
= current_buffer
;
989 set_per_buffer_value (buf
, offset
, newval
);
993 case Lisp_Fwd_Kboard_Obj
:
995 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
996 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
997 *(Lisp_Object
*) p
= newval
;
1002 emacs_abort (); /* goto def; */
1006 /* Set up SYMBOL to refer to its global binding. This makes it safe
1007 to alter the status of other bindings. BEWARE: this may be called
1008 during the mark phase of GC, where we assume that Lisp_Object slots
1009 of BLV are marked after this function has changed them. */
1012 swap_in_global_binding (sym_t symbol
)
1014 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1016 /* Unload the previously loaded binding. */
1018 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1020 /* Select the global binding in the symbol. */
1021 set_blv_valcell (blv
, blv
->defcell
);
1023 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1025 /* Indicate that the global binding is set up now. */
1026 set_blv_where (blv
, Qnil
);
1027 set_blv_found (blv
, 0);
1030 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1031 VALCONTENTS is the contents of its value cell,
1032 which points to a struct Lisp_Buffer_Local_Value.
1034 Return the value forwarded one step past the buffer-local stage.
1035 This could be another forwarding pointer. */
1038 swap_in_symval_forwarding (sym_t symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1040 register Lisp_Object tem1
;
1042 eassert (blv
== SYMBOL_BLV (symbol
));
1047 || (blv
->frame_local
1048 ? !EQ (selected_frame
, tem1
)
1049 : current_buffer
!= XBUFFER (tem1
)))
1052 /* Unload the previously loaded binding. */
1053 tem1
= blv
->valcell
;
1055 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1056 /* Choose the new binding. */
1059 XSETSYMBOL (var
, symbol
);
1060 if (blv
->frame_local
)
1062 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1063 set_blv_where (blv
, selected_frame
);
1067 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1068 set_blv_where (blv
, Fcurrent_buffer ());
1071 if (!(blv
->found
= !NILP (tem1
)))
1072 tem1
= blv
->defcell
;
1074 /* Load the new binding. */
1075 set_blv_valcell (blv
, tem1
);
1077 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1081 /* Find the value of a symbol, returning Qunbound if it's not bound.
1082 This is helpful for code which just wants to get a variable's value
1083 if it has one, without signaling an error.
1084 Note that it must not be possible to quit
1085 within this function. Great care is required for this. */
1088 find_symbol_value (Lisp_Object symbol
)
1092 CHECK_SYMBOL (symbol
);
1093 sym
= XSYMBOL (symbol
);
1096 switch (SYMBOL_REDIRECT (sym
))
1098 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1099 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1100 case SYMBOL_LOCALIZED
:
1102 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1103 swap_in_symval_forwarding (sym
, blv
);
1104 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1107 case SYMBOL_FORWARDED
:
1108 return do_symval_forwarding (SYMBOL_FWD (sym
));
1109 default: emacs_abort ();
1113 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1114 doc
: /* Return SYMBOL's value. Error if that is void.
1115 Note that if `lexical-binding' is in effect, this returns the
1116 global value outside of any lexical scope. */)
1117 (Lisp_Object symbol
)
1121 val
= find_symbol_value (symbol
);
1122 if (!EQ (val
, Qunbound
))
1125 xsignal1 (Qvoid_variable
, symbol
);
1128 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1129 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1130 (register Lisp_Object symbol
, Lisp_Object newval
)
1132 set_internal (symbol
, newval
, Qnil
, 0);
1136 /* Store the value NEWVAL into SYMBOL.
1137 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1138 (nil stands for the current buffer/frame).
1140 If BINDFLAG is false, then if this symbol is supposed to become
1141 local in every buffer where it is set, then we make it local.
1142 If BINDFLAG is true, we don't do that. */
1145 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1148 bool voide
= EQ (newval
, Qunbound
);
1152 /* If restoring in a dead buffer, do nothing. */
1153 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1156 CHECK_SYMBOL (symbol
);
1157 if (SYMBOL_CONSTANT_P (symbol
))
1159 if (NILP (Fkeywordp (symbol
))
1160 || !EQ (newval
, Fsymbol_value (symbol
)))
1161 xsignal1 (Qsetting_constant
, symbol
);
1163 /* Allow setting keywords to their own value. */
1167 sym
= XSYMBOL (symbol
);
1170 switch (SYMBOL_REDIRECT (sym
))
1172 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1173 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1174 case SYMBOL_LOCALIZED
:
1176 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1179 if (blv
->frame_local
)
1180 where
= selected_frame
;
1182 XSETBUFFER (where
, current_buffer
);
1184 /* If the current buffer is not the buffer whose binding is
1185 loaded, or if there may be frame-local bindings and the frame
1186 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1187 the default binding is loaded, the loaded binding may be the
1189 if (!EQ (blv
->where
, where
)
1190 /* Also unload a global binding (if the var is local_if_set). */
1191 || (EQ (blv
->valcell
, blv
->defcell
)))
1193 /* The currently loaded binding is not necessarily valid.
1194 We need to unload it, and choose a new binding. */
1196 /* Write out `realvalue' to the old loaded binding. */
1198 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1200 /* Find the new binding. */
1201 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1202 tem1
= Fassq (symbol
,
1204 ? XFRAME (where
)->param_alist
1205 : BVAR (XBUFFER (where
), local_var_alist
)));
1206 set_blv_where (blv
, where
);
1211 /* This buffer still sees the default value. */
1213 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1214 or if this is `let' rather than `set',
1215 make CURRENT-ALIST-ELEMENT point to itself,
1216 indicating that we're seeing the default value.
1217 Likewise if the variable has been let-bound
1218 in the current buffer. */
1219 if (bindflag
|| !blv
->local_if_set
1220 || let_shadows_buffer_binding_p (sym
))
1223 tem1
= blv
->defcell
;
1225 /* If it's a local_if_set, being set not bound,
1226 and we're not within a let that was made for this buffer,
1227 create a new buffer-local binding for the variable.
1228 That means, give this buffer a new assoc for a local value
1229 and load that binding. */
1232 /* local_if_set is only supported for buffer-local
1233 bindings, not for frame-local bindings. */
1234 eassert (!blv
->frame_local
);
1235 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1236 bset_local_var_alist
1238 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1242 /* Record which binding is now loaded. */
1243 set_blv_valcell (blv
, tem1
);
1246 /* Store the new value in the cons cell. */
1247 set_blv_value (blv
, newval
);
1252 /* If storing void (making the symbol void), forward only through
1253 buffer-local indicator, not through Lisp_Objfwd, etc. */
1256 store_symval_forwarding (blv
->fwd
, newval
,
1258 ? XBUFFER (where
) : current_buffer
);
1262 case SYMBOL_FORWARDED
:
1265 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1266 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1267 if (BUFFER_OBJFWDP (innercontents
))
1269 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1270 int idx
= PER_BUFFER_IDX (offset
);
1273 && !let_shadows_buffer_binding_p (sym
))
1274 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1278 { /* If storing void (making the symbol void), forward only through
1279 buffer-local indicator, not through Lisp_Objfwd, etc. */
1280 SET_SYMBOL_REDIRECT (sym
, SYMBOL_PLAINVAL
);
1281 SET_SYMBOL_VAL (sym
, newval
);
1284 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1287 default: emacs_abort ();
1292 /* Access or set a buffer-local symbol's default value. */
1294 /* Return the default value of SYMBOL, but don't check for voidness.
1295 Return Qunbound if it is void. */
1298 default_value (Lisp_Object symbol
)
1302 CHECK_SYMBOL (symbol
);
1303 sym
= XSYMBOL (symbol
);
1306 switch (SYMBOL_REDIRECT (sym
))
1308 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1309 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1310 case SYMBOL_LOCALIZED
:
1312 /* If var is set up for a buffer that lacks a local value for it,
1313 the current value is nominally the default value.
1314 But the `realvalue' slot may be more up to date, since
1315 ordinary setq stores just that slot. So use that. */
1316 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1317 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1318 return do_symval_forwarding (blv
->fwd
);
1320 return XCDR (blv
->defcell
);
1322 case SYMBOL_FORWARDED
:
1324 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1326 /* For a built-in buffer-local variable, get the default value
1327 rather than letting do_symval_forwarding get the current value. */
1328 if (BUFFER_OBJFWDP (valcontents
))
1330 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1331 if (PER_BUFFER_IDX (offset
) != 0)
1332 return per_buffer_default (offset
);
1335 /* For other variables, get the current value. */
1336 return do_symval_forwarding (valcontents
);
1338 default: emacs_abort ();
1342 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1343 doc
: /* Return t if SYMBOL has a non-void default value.
1344 This is the value that is seen in buffers that do not have their own values
1345 for this variable. */)
1346 (Lisp_Object symbol
)
1348 register Lisp_Object value
;
1350 value
= default_value (symbol
);
1351 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1354 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1355 doc
: /* Return SYMBOL's default value.
1356 This is the value that is seen in buffers that do not have their own values
1357 for this variable. The default value is meaningful for variables with
1358 local bindings in certain buffers. */)
1359 (Lisp_Object symbol
)
1361 Lisp_Object value
= default_value (symbol
);
1362 if (!EQ (value
, Qunbound
))
1365 xsignal1 (Qvoid_variable
, symbol
);
1368 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1369 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1370 The default value is seen in buffers that do not have their own values
1371 for this variable. */)
1372 (Lisp_Object symbol
, Lisp_Object value
)
1376 CHECK_SYMBOL (symbol
);
1377 if (SYMBOL_CONSTANT_P (symbol
))
1379 if (NILP (Fkeywordp (symbol
))
1380 || !EQ (value
, Fdefault_value (symbol
)))
1381 xsignal1 (Qsetting_constant
, symbol
);
1383 /* Allow setting keywords to their own value. */
1386 sym
= XSYMBOL (symbol
);
1389 switch (SYMBOL_REDIRECT (sym
))
1391 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1392 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1393 case SYMBOL_LOCALIZED
:
1395 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1397 /* Store new value into the DEFAULT-VALUE slot. */
1398 XSETCDR (blv
->defcell
, value
);
1400 /* If the default binding is now loaded, set the REALVALUE slot too. */
1401 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1402 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1405 case SYMBOL_FORWARDED
:
1407 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1409 /* Handle variables like case-fold-search that have special slots
1411 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1412 if (BUFFER_OBJFWDP (valcontents
))
1414 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1415 int idx
= PER_BUFFER_IDX (offset
);
1417 set_per_buffer_default (offset
, value
);
1419 /* If this variable is not always local in all buffers,
1420 set it in the buffers that don't nominally have a local value. */
1426 if (!PER_BUFFER_VALUE_P (b
, idx
))
1427 set_per_buffer_value (b
, offset
, value
);
1432 return Fset (symbol
, value
);
1434 default: emacs_abort ();
1438 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1439 doc
: /* Set the default value of variable VAR to VALUE.
1440 VAR, the variable name, is literal (not evaluated);
1441 VALUE is an expression: it is evaluated and its value returned.
1442 The default value of a variable is seen in buffers
1443 that do not have their own values for the variable.
1445 More generally, you can use multiple variables and values, as in
1446 (setq-default VAR VALUE VAR VALUE...)
1447 This sets each VAR's default value to the corresponding VALUE.
1448 The VALUE for the Nth VAR can refer to the new default values
1450 usage: (setq-default [VAR VALUE]...) */)
1453 Lisp_Object args_left
, symbol
, val
;
1454 struct gcpro gcpro1
;
1456 args_left
= val
= args
;
1459 while (CONSP (args_left
))
1461 val
= eval_sub (Fcar (XCDR (args_left
)));
1462 symbol
= XCAR (args_left
);
1463 Fset_default (symbol
, val
);
1464 args_left
= Fcdr (XCDR (args_left
));
1471 /* Lisp functions for creating and removing buffer-local variables. */
1476 union Lisp_Fwd
*fwd
;
1479 static struct Lisp_Buffer_Local_Value
*
1480 make_blv (sym_t sym
, bool forwarded
,
1481 union Lisp_Val_Fwd valcontents
)
1483 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1487 XSETSYMBOL (symbol
, sym
);
1488 tem
= Fcons (symbol
, (forwarded
1489 ? do_symval_forwarding (valcontents
.fwd
)
1490 : valcontents
.value
));
1492 /* Buffer_Local_Values cannot have as realval a buffer-local
1493 or keyboard-local forwarding. */
1494 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1495 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1496 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1497 set_blv_where (blv
, Qnil
);
1498 blv
->frame_local
= 0;
1499 blv
->local_if_set
= 0;
1500 set_blv_defcell (blv
, tem
);
1501 set_blv_valcell (blv
, tem
);
1502 set_blv_found (blv
, 0);
1506 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1507 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1508 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1509 At any time, the value for the current buffer is in effect,
1510 unless the variable has never been set in this buffer,
1511 in which case the default value is in effect.
1512 Note that binding the variable with `let', or setting it while
1513 a `let'-style binding made in this buffer is in effect,
1514 does not make the variable buffer-local. Return VARIABLE.
1516 This globally affects all uses of this variable, so it belongs together with
1517 the variable declaration, rather than with its uses (if you just want to make
1518 a variable local to the current buffer for one particular use, use
1519 `make-local-variable'). Buffer-local bindings are normally cleared
1520 while setting up a new major mode, unless they have a `permanent-local'
1523 The function `default-value' gets the default value and `set-default' sets it. */)
1524 (register Lisp_Object variable
)
1527 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1528 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1529 bool forwarded
IF_LINT (= 0);
1531 CHECK_SYMBOL (variable
);
1532 sym
= XSYMBOL (variable
);
1535 switch (SYMBOL_REDIRECT (sym
))
1537 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1538 case SYMBOL_PLAINVAL
:
1539 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1540 if (EQ (valcontents
.value
, Qunbound
))
1541 valcontents
.value
= Qnil
;
1543 case SYMBOL_LOCALIZED
:
1544 blv
= SYMBOL_BLV (sym
);
1545 if (blv
->frame_local
)
1546 error ("Symbol %s may not be buffer-local",
1547 SDATA (SYMBOL_NAME (variable
)));
1549 case SYMBOL_FORWARDED
:
1550 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1551 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1552 error ("Symbol %s may not be buffer-local",
1553 SDATA (SYMBOL_NAME (variable
)));
1554 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1557 default: emacs_abort ();
1560 if (SYMBOL_CONSTANT (sym
))
1561 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1565 blv
= make_blv (sym
, forwarded
, valcontents
);
1566 SET_SYMBOL_REDIRECT (sym
, SYMBOL_LOCALIZED
);
1567 SET_SYMBOL_BLV (sym
, blv
);
1570 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1571 if (let_shadows_global_binding_p (symbol
))
1572 message ("Making %s buffer-local while let-bound!",
1573 SDATA (SYMBOL_NAME (variable
)));
1577 blv
->local_if_set
= 1;
1581 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1582 1, 1, "vMake Local Variable: ",
1583 doc
: /* Make VARIABLE have a separate value in the current buffer.
1584 Other buffers will continue to share a common default value.
1585 \(The buffer-local value of VARIABLE starts out as the same value
1586 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1589 If the variable is already arranged to become local when set,
1590 this function causes a local value to exist for this buffer,
1591 just as setting the variable would do.
1593 This function returns VARIABLE, and therefore
1594 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1597 See also `make-variable-buffer-local'.
1599 Do not use `make-local-variable' to make a hook variable buffer-local.
1600 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1601 (Lisp_Object variable
)
1604 bool forwarded
IF_LINT (= 0);
1605 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1607 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1609 CHECK_SYMBOL (variable
);
1610 sym
= XSYMBOL (variable
);
1613 switch (SYMBOL_REDIRECT (sym
))
1615 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1616 case SYMBOL_PLAINVAL
:
1617 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1618 case SYMBOL_LOCALIZED
:
1619 blv
= SYMBOL_BLV (sym
);
1620 if (blv
->frame_local
)
1621 error ("Symbol %s may not be buffer-local",
1622 SDATA (SYMBOL_NAME (variable
)));
1624 case SYMBOL_FORWARDED
:
1625 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1626 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1627 error ("Symbol %s may not be buffer-local",
1628 SDATA (SYMBOL_NAME (variable
)));
1630 default: emacs_abort ();
1633 if (SYMBOL_CONSTANT (sym
))
1634 error ("Symbol %s may not be buffer-local",
1635 SDATA (SYMBOL_NAME (variable
)));
1637 if (blv
? blv
->local_if_set
1638 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1640 tem
= Fboundp (variable
);
1641 /* Make sure the symbol has a local value in this particular buffer,
1642 by setting it to the same value it already has. */
1643 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1648 blv
= make_blv (sym
, forwarded
, valcontents
);
1649 SET_SYMBOL_REDIRECT (sym
, SYMBOL_LOCALIZED
);
1650 SET_SYMBOL_BLV (sym
, blv
);
1653 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1654 if (let_shadows_global_binding_p (symbol
))
1655 message ("Making %s local to %s while let-bound!",
1656 SDATA (SYMBOL_NAME (variable
)),
1657 SDATA (BVAR (current_buffer
, name
)));
1661 /* Make sure this buffer has its own value of symbol. */
1662 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1663 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1666 if (let_shadows_buffer_binding_p (sym
))
1667 message ("Making %s buffer-local while locally let-bound!",
1668 SDATA (SYMBOL_NAME (variable
)));
1670 /* Swap out any local binding for some other buffer, and make
1671 sure the current value is permanently recorded, if it's the
1673 find_symbol_value (variable
);
1675 bset_local_var_alist
1677 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1678 BVAR (current_buffer
, local_var_alist
)));
1680 /* Make sure symbol does not think it is set up for this buffer;
1681 force it to look once again for this buffer's value. */
1682 if (current_buffer
== XBUFFER (blv
->where
))
1683 set_blv_where (blv
, Qnil
);
1684 set_blv_found (blv
, 0);
1687 /* If the symbol forwards into a C variable, then load the binding
1688 for this buffer now. If C code modifies the variable before we
1689 load the binding in, then that new value will clobber the default
1690 binding the next time we unload it. */
1692 swap_in_symval_forwarding (sym
, blv
);
1697 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1698 1, 1, "vKill Local Variable: ",
1699 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1700 From now on the default value will apply in this buffer. Return VARIABLE. */)
1701 (register Lisp_Object variable
)
1703 register Lisp_Object tem
;
1704 struct Lisp_Buffer_Local_Value
*blv
;
1707 CHECK_SYMBOL (variable
);
1708 sym
= XSYMBOL (variable
);
1711 switch (SYMBOL_REDIRECT (sym
))
1713 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1714 case SYMBOL_PLAINVAL
: return variable
;
1715 case SYMBOL_FORWARDED
:
1717 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1718 if (BUFFER_OBJFWDP (valcontents
))
1720 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1721 int idx
= PER_BUFFER_IDX (offset
);
1725 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1726 set_per_buffer_value (current_buffer
, offset
,
1727 per_buffer_default (offset
));
1732 case SYMBOL_LOCALIZED
:
1733 blv
= SYMBOL_BLV (sym
);
1734 if (blv
->frame_local
)
1737 default: emacs_abort ();
1740 /* Get rid of this buffer's alist element, if any. */
1741 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1742 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1744 bset_local_var_alist
1746 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1748 /* If the symbol is set up with the current buffer's binding
1749 loaded, recompute its value. We have to do it now, or else
1750 forwarded objects won't work right. */
1752 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1753 if (EQ (buf
, blv
->where
))
1755 set_blv_where (blv
, Qnil
);
1757 find_symbol_value (variable
);
1764 /* Lisp functions for creating and removing buffer-local variables. */
1766 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1767 when/if this is removed. */
1769 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1770 1, 1, "vMake Variable Frame Local: ",
1771 doc
: /* Enable VARIABLE to have frame-local bindings.
1772 This does not create any frame-local bindings for VARIABLE,
1773 it just makes them possible.
1775 A frame-local binding is actually a frame parameter value.
1776 If a frame F has a value for the frame parameter named VARIABLE,
1777 that also acts as a frame-local binding for VARIABLE in F--
1778 provided this function has been called to enable VARIABLE
1779 to have frame-local bindings at all.
1781 The only way to create a frame-local binding for VARIABLE in a frame
1782 is to set the VARIABLE frame parameter of that frame. See
1783 `modify-frame-parameters' for how to set frame parameters.
1785 Note that since Emacs 23.1, variables cannot be both buffer-local and
1786 frame-local any more (buffer-local bindings used to take precedence over
1787 frame-local bindings). */)
1788 (Lisp_Object variable
)
1791 union Lisp_Val_Fwd valcontents
;
1793 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1795 CHECK_SYMBOL (variable
);
1796 sym
= XSYMBOL (variable
);
1799 switch (SYMBOL_REDIRECT (sym
))
1801 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1802 case SYMBOL_PLAINVAL
:
1803 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1804 if (EQ (valcontents
.value
, Qunbound
))
1805 valcontents
.value
= Qnil
;
1807 case SYMBOL_LOCALIZED
:
1808 if (SYMBOL_BLV (sym
)->frame_local
)
1811 error ("Symbol %s may not be frame-local",
1812 SDATA (SYMBOL_NAME (variable
)));
1813 case SYMBOL_FORWARDED
:
1814 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1815 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1816 error ("Symbol %s may not be frame-local",
1817 SDATA (SYMBOL_NAME (variable
)));
1819 default: emacs_abort ();
1822 if (SYMBOL_CONSTANT (sym
))
1823 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1825 blv
= make_blv (sym
, forwarded
, valcontents
);
1826 blv
->frame_local
= 1;
1827 SET_SYMBOL_REDIRECT (sym
, SYMBOL_LOCALIZED
);
1828 SET_SYMBOL_BLV (sym
, blv
);
1831 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1832 if (let_shadows_global_binding_p (symbol
))
1833 message ("Making %s frame-local while let-bound!",
1834 SDATA (SYMBOL_NAME (variable
)));
1839 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1841 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1842 BUFFER defaults to the current buffer. */)
1843 (register Lisp_Object variable
, Lisp_Object buffer
)
1845 register struct buffer
*buf
;
1849 buf
= current_buffer
;
1852 CHECK_BUFFER (buffer
);
1853 buf
= XBUFFER (buffer
);
1856 CHECK_SYMBOL (variable
);
1857 sym
= XSYMBOL (variable
);
1860 switch (SYMBOL_REDIRECT (sym
))
1862 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1863 case SYMBOL_PLAINVAL
: return Qnil
;
1864 case SYMBOL_LOCALIZED
:
1866 Lisp_Object tail
, elt
, tmp
;
1867 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1868 XSETBUFFER (tmp
, buf
);
1869 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1871 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1872 return blv_found (blv
) ? Qt
: Qnil
;
1874 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1877 if (EQ (variable
, XCAR (elt
)))
1879 eassert (!blv
->frame_local
);
1885 case SYMBOL_FORWARDED
:
1887 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1888 if (BUFFER_OBJFWDP (valcontents
))
1890 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1891 int idx
= PER_BUFFER_IDX (offset
);
1892 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1897 default: emacs_abort ();
1901 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1903 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1904 BUFFER defaults to the current buffer.
1906 More precisely, return non-nil if either VARIABLE already has a local
1907 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1908 `make-variable-buffer-local'). */)
1909 (register Lisp_Object variable
, Lisp_Object buffer
)
1913 CHECK_SYMBOL (variable
);
1914 sym
= XSYMBOL (variable
);
1917 switch (SYMBOL_REDIRECT (sym
))
1919 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1920 case SYMBOL_PLAINVAL
: return Qnil
;
1921 case SYMBOL_LOCALIZED
:
1923 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1924 if (blv
->local_if_set
)
1926 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1927 return Flocal_variable_p (variable
, buffer
);
1929 case SYMBOL_FORWARDED
:
1930 /* All BUFFER_OBJFWD slots become local if they are set. */
1931 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1932 default: emacs_abort ();
1936 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1938 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1939 If the current binding is buffer-local, the value is the current buffer.
1940 If the current binding is frame-local, the value is the selected frame.
1941 If the current binding is global (the default), the value is nil. */)
1942 (register Lisp_Object variable
)
1946 CHECK_SYMBOL (variable
);
1947 sym
= XSYMBOL (variable
);
1949 /* Make sure the current binding is actually swapped in. */
1950 find_symbol_value (variable
);
1953 switch (SYMBOL_REDIRECT (sym
))
1955 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1956 case SYMBOL_PLAINVAL
: return Qnil
;
1957 case SYMBOL_FORWARDED
:
1959 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1960 if (KBOARD_OBJFWDP (valcontents
))
1961 return Fframe_terminal (selected_frame
);
1962 else if (!BUFFER_OBJFWDP (valcontents
))
1966 case SYMBOL_LOCALIZED
:
1967 /* For a local variable, record both the symbol and which
1968 buffer's or frame's value we are saving. */
1969 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1970 return Fcurrent_buffer ();
1971 else if (SYMBOL_REDIRECT (sym
) == SYMBOL_LOCALIZED
1972 && blv_found (SYMBOL_BLV (sym
)))
1973 return SYMBOL_BLV (sym
)->where
;
1976 default: emacs_abort ();
1980 /* This code is disabled now that we use the selected frame to return
1981 keyboard-local-values. */
1983 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1985 DEFUN ("terminal-local-value", Fterminal_local_value
,
1986 Sterminal_local_value
, 2, 2, 0,
1987 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1988 If SYMBOL is not a terminal-local variable, then return its normal
1989 value, like `symbol-value'.
1991 TERMINAL may be a terminal object, a frame, or nil (meaning the
1992 selected frame's terminal device). */)
1993 (Lisp_Object symbol
, Lisp_Object terminal
)
1996 struct terminal
*t
= get_terminal (terminal
, 1);
1997 push_kboard (t
->kboard
);
1998 result
= Fsymbol_value (symbol
);
2003 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
2004 Sset_terminal_local_value
, 3, 3, 0,
2005 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2006 If VARIABLE is not a terminal-local variable, then set its normal
2007 binding, like `set'.
2009 TERMINAL may be a terminal object, a frame, or nil (meaning the
2010 selected frame's terminal device). */)
2011 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2014 struct terminal
*t
= get_terminal (terminal
, 1);
2015 push_kboard (d
->kboard
);
2016 result
= Fset (symbol
, value
);
2022 /* Find the function at the end of a chain of symbol function indirections. */
2024 /* If OBJECT is a symbol, find the end of its function chain and
2025 return the value found there. If OBJECT is not a symbol, just
2026 return it. If there is a cycle in the function chain, signal a
2027 cyclic-function-indirection error.
2029 This is like Findirect_function, except that it doesn't signal an
2030 error if the chain ends up unbound. */
2032 indirect_function (register Lisp_Object object
)
2034 Lisp_Object tortoise
, hare
;
2036 hare
= tortoise
= object
;
2040 if (!SYMBOLP (hare
) || NILP (hare
))
2042 hare
= SYMBOL_FUNCTION (hare
);
2043 if (!SYMBOLP (hare
) || NILP (hare
))
2045 hare
= SYMBOL_FUNCTION (hare
);
2047 tortoise
= SYMBOL_FUNCTION (tortoise
);
2049 if (EQ (hare
, tortoise
))
2050 xsignal1 (Qcyclic_function_indirection
, object
);
2056 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2057 doc
: /* Return the function at the end of OBJECT's function chain.
2058 If OBJECT is not a symbol, just return it. Otherwise, follow all
2059 function indirections to find the final function binding and return it.
2060 If the final symbol in the chain is unbound, signal a void-function error.
2061 Optional arg NOERROR non-nil means to return nil instead of signaling.
2062 Signal a cyclic-function-indirection error if there is a loop in the
2063 function chain of symbols. */)
2064 (register Lisp_Object object
, Lisp_Object noerror
)
2068 /* Optimize for no indirection. */
2070 if (SYMBOLP (result
) && !NILP (result
)
2071 && (result
= SYMBOL_FUNCTION (result
), SYMBOLP (result
)))
2072 result
= indirect_function (result
);
2077 xsignal1 (Qvoid_function
, object
);
2082 /* Extract and set vector and string elements. */
2084 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2085 doc
: /* Return the element of ARRAY at index IDX.
2086 ARRAY may be a vector, a string, a char-table, a bool-vector,
2087 or a byte-code object. IDX starts at 0. */)
2088 (register Lisp_Object array
, Lisp_Object idx
)
2090 register EMACS_INT idxval
;
2093 idxval
= XINT (idx
);
2094 if (STRINGP (array
))
2097 ptrdiff_t idxval_byte
;
2099 if (idxval
< 0 || idxval
>= SCHARS (array
))
2100 args_out_of_range (array
, idx
);
2101 if (! STRING_MULTIBYTE (array
))
2102 return make_number ((unsigned char) SREF (array
, idxval
));
2103 idxval_byte
= string_char_to_byte (array
, idxval
);
2105 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2106 return make_number (c
);
2108 else if (BOOL_VECTOR_P (array
))
2110 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2111 args_out_of_range (array
, idx
);
2112 return bool_vector_ref (array
, idxval
);
2114 else if (CHAR_TABLE_P (array
))
2116 CHECK_CHARACTER (idx
);
2117 return CHAR_TABLE_REF (array
, idxval
);
2122 if (VECTORP (array
))
2123 size
= ASIZE (array
);
2124 else if (COMPILEDP (array
))
2125 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2127 wrong_type_argument (Qarrayp
, array
);
2129 if (idxval
< 0 || idxval
>= size
)
2130 args_out_of_range (array
, idx
);
2131 return AREF (array
, idxval
);
2135 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2136 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2137 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2138 bool-vector. IDX starts at 0. */)
2139 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2141 register EMACS_INT idxval
;
2144 idxval
= XINT (idx
);
2145 CHECK_ARRAY (array
, Qarrayp
);
2146 CHECK_IMPURE (array
);
2148 if (VECTORP (array
))
2150 if (idxval
< 0 || idxval
>= ASIZE (array
))
2151 args_out_of_range (array
, idx
);
2152 ASET (array
, idxval
, newelt
);
2154 else if (BOOL_VECTOR_P (array
))
2156 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2157 args_out_of_range (array
, idx
);
2158 bool_vector_set (array
, idxval
, !NILP (newelt
));
2160 else if (CHAR_TABLE_P (array
))
2162 CHECK_CHARACTER (idx
);
2163 CHAR_TABLE_SET (array
, idxval
, newelt
);
2169 if (idxval
< 0 || idxval
>= SCHARS (array
))
2170 args_out_of_range (array
, idx
);
2171 CHECK_CHARACTER (newelt
);
2172 c
= XFASTINT (newelt
);
2174 if (STRING_MULTIBYTE (array
))
2176 ptrdiff_t idxval_byte
, nbytes
;
2177 int prev_bytes
, new_bytes
;
2178 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2180 nbytes
= SBYTES (array
);
2181 idxval_byte
= string_char_to_byte (array
, idxval
);
2182 p1
= SDATA (array
) + idxval_byte
;
2183 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2184 new_bytes
= CHAR_STRING (c
, p0
);
2185 if (prev_bytes
!= new_bytes
)
2187 /* We must relocate the string data. */
2188 ptrdiff_t nchars
= SCHARS (array
);
2190 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2192 memcpy (str
, SDATA (array
), nbytes
);
2193 allocate_string_data (XSTRING (array
), nchars
,
2194 nbytes
+ new_bytes
- prev_bytes
);
2195 memcpy (SDATA (array
), str
, idxval_byte
);
2196 p1
= SDATA (array
) + idxval_byte
;
2197 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2198 nbytes
- (idxval_byte
+ prev_bytes
));
2200 clear_string_char_byte_cache ();
2207 if (! SINGLE_BYTE_CHAR_P (c
))
2211 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2212 if (SREF (array
, i
) >= 0x80)
2213 args_out_of_range (array
, newelt
);
2214 /* ARRAY is an ASCII string. Convert it to a multibyte
2215 string, and try `aset' again. */
2216 STRING_SET_MULTIBYTE (array
);
2217 return Faset (array
, idx
, newelt
);
2219 SSET (array
, idxval
, c
);
2226 /* Arithmetic functions */
2229 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2231 double f1
= 0, f2
= 0;
2234 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2235 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2237 if (FLOATP (num1
) || FLOATP (num2
))
2240 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2241 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2247 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2251 case ARITH_NOTEQUAL
:
2252 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2257 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2261 case ARITH_LESS_OR_EQUAL
:
2262 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2267 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2271 case ARITH_GRTR_OR_EQUAL
:
2272 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2282 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2283 enum Arith_Comparison comparison
)
2286 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2288 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2294 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2295 doc
: /* Return t if args, all numbers or markers, are equal.
2296 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2297 (ptrdiff_t nargs
, Lisp_Object
*args
)
2299 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2302 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2303 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2304 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2305 (ptrdiff_t nargs
, Lisp_Object
*args
)
2307 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2310 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2311 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2312 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2313 (ptrdiff_t nargs
, Lisp_Object
*args
)
2315 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2318 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2319 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2320 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2321 (ptrdiff_t nargs
, Lisp_Object
*args
)
2323 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2326 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2327 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2328 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2329 (ptrdiff_t nargs
, Lisp_Object
*args
)
2331 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2334 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2335 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2336 (register Lisp_Object num1
, Lisp_Object num2
)
2338 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2341 /* Convert the cons-of-integers, integer, or float value C to an
2342 unsigned value with maximum value MAX. Signal an error if C does not
2343 have a valid format or is out of range. */
2345 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2348 uintmax_t val
IF_LINT (= 0);
2351 valid
= 0 <= XINT (c
);
2354 else if (FLOATP (c
))
2356 double d
= XFLOAT_DATA (c
);
2358 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2364 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2366 uintmax_t top
= XFASTINT (XCAR (c
));
2367 Lisp_Object rest
= XCDR (c
);
2368 if (top
<= UINTMAX_MAX
>> 24 >> 16
2370 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2371 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2373 uintmax_t mid
= XFASTINT (XCAR (rest
));
2374 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2377 else if (top
<= UINTMAX_MAX
>> 16)
2381 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2383 val
= top
<< 16 | XFASTINT (rest
);
2389 if (! (valid
&& val
<= max
))
2390 error ("Not an in-range integer, float, or cons of integers");
2394 /* Convert the cons-of-integers, integer, or float value C to a signed
2395 value with extrema MIN and MAX. Signal an error if C does not have
2396 a valid format or is out of range. */
2398 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2401 intmax_t val
IF_LINT (= 0);
2407 else if (FLOATP (c
))
2409 double d
= XFLOAT_DATA (c
);
2411 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2417 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2419 intmax_t top
= XINT (XCAR (c
));
2420 Lisp_Object rest
= XCDR (c
);
2421 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2423 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2424 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2426 intmax_t mid
= XFASTINT (XCAR (rest
));
2427 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2430 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2434 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2436 val
= top
<< 16 | XFASTINT (rest
);
2442 if (! (valid
&& min
<= val
&& val
<= max
))
2443 error ("Not an in-range integer, float, or cons of integers");
2447 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2448 doc
: /* Return the decimal representation of NUMBER as a string.
2449 Uses a minus sign if negative.
2450 NUMBER may be an integer or a floating point number. */)
2451 (Lisp_Object number
)
2453 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2456 CHECK_NUMBER_OR_FLOAT (number
);
2458 if (FLOATP (number
))
2459 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2461 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2463 return make_unibyte_string (buffer
, len
);
2466 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2467 doc
: /* Parse STRING as a decimal number and return the number.
2468 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2469 STRING cannot be parsed as an integer or floating point number.
2471 If BASE, interpret STRING as a number in that base. If BASE isn't
2472 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2473 If the base used is not 10, STRING is always parsed as an integer. */)
2474 (register Lisp_Object string
, Lisp_Object base
)
2480 CHECK_STRING (string
);
2486 CHECK_NUMBER (base
);
2487 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2488 xsignal1 (Qargs_out_of_range
, base
);
2492 p
= SSDATA (string
);
2493 while (*p
== ' ' || *p
== '\t')
2496 val
= string_to_number (p
, b
, 1);
2497 return NILP (val
) ? make_number (0) : val
;
2513 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2514 ptrdiff_t, Lisp_Object
*);
2516 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2519 ptrdiff_t argnum
, ok_args
;
2520 EMACS_INT accum
= 0;
2521 EMACS_INT next
, ok_accum
;
2542 for (argnum
= 0; argnum
< nargs
; argnum
++)
2550 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2552 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2555 return float_arith_driver (ok_accum
, ok_args
, code
,
2558 next
= XINT (args
[argnum
]);
2562 if (INT_ADD_OVERFLOW (accum
, next
))
2570 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2575 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2578 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2580 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2582 accum
= ab
& INTMASK
;
2593 xsignal0 (Qarith_error
);
2607 if (!argnum
|| next
> accum
)
2611 if (!argnum
|| next
< accum
)
2617 XSETINT (val
, accum
);
2622 #define isnan(x) ((x) != (x))
2625 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2626 ptrdiff_t nargs
, Lisp_Object
*args
)
2628 register Lisp_Object val
;
2631 for (; argnum
< nargs
; argnum
++)
2633 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2634 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2638 next
= XFLOAT_DATA (val
);
2642 args
[argnum
] = val
; /* runs into a compiler bug. */
2643 next
= XINT (args
[argnum
]);
2651 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2661 if (! IEEE_FLOATING_POINT
&& next
== 0)
2662 xsignal0 (Qarith_error
);
2669 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2671 if (!argnum
|| isnan (next
) || next
> accum
)
2675 if (!argnum
|| isnan (next
) || next
< accum
)
2681 return make_float (accum
);
2685 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2686 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2687 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2688 (ptrdiff_t nargs
, Lisp_Object
*args
)
2690 return arith_driver (Aadd
, nargs
, args
);
2693 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2694 doc
: /* Negate number or subtract numbers or markers and return the result.
2695 With one arg, negates it. With more than one arg,
2696 subtracts all but the first from the first.
2697 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2698 (ptrdiff_t nargs
, Lisp_Object
*args
)
2700 return arith_driver (Asub
, nargs
, args
);
2703 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2704 doc
: /* Return product of any number of arguments, which are numbers or markers.
2705 usage: (* &rest NUMBERS-OR-MARKERS) */)
2706 (ptrdiff_t nargs
, Lisp_Object
*args
)
2708 return arith_driver (Amult
, nargs
, args
);
2711 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2712 doc
: /* Return first argument divided by all the remaining arguments.
2713 The arguments must be numbers or markers.
2714 usage: (/ DIVIDEND &rest DIVISORS) */)
2715 (ptrdiff_t nargs
, Lisp_Object
*args
)
2718 for (argnum
= 2; argnum
< nargs
; argnum
++)
2719 if (FLOATP (args
[argnum
]))
2720 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2721 return arith_driver (Adiv
, nargs
, args
);
2724 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2725 doc
: /* Return remainder of X divided by Y.
2726 Both must be integers or markers. */)
2727 (register Lisp_Object x
, Lisp_Object y
)
2731 CHECK_NUMBER_COERCE_MARKER (x
);
2732 CHECK_NUMBER_COERCE_MARKER (y
);
2735 xsignal0 (Qarith_error
);
2737 XSETINT (val
, XINT (x
) % XINT (y
));
2741 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2742 doc
: /* Return X modulo Y.
2743 The result falls between zero (inclusive) and Y (exclusive).
2744 Both X and Y must be numbers or markers. */)
2745 (register Lisp_Object x
, Lisp_Object y
)
2750 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2751 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2753 if (FLOATP (x
) || FLOATP (y
))
2754 return fmod_float (x
, y
);
2760 xsignal0 (Qarith_error
);
2764 /* If the "remainder" comes out with the wrong sign, fix it. */
2765 if (i2
< 0 ? i1
> 0 : i1
< 0)
2772 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2773 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2774 The value is always a number; markers are converted to numbers.
2775 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2776 (ptrdiff_t nargs
, Lisp_Object
*args
)
2778 return arith_driver (Amax
, nargs
, args
);
2781 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2782 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2783 The value is always a number; markers are converted to numbers.
2784 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2785 (ptrdiff_t nargs
, Lisp_Object
*args
)
2787 return arith_driver (Amin
, nargs
, args
);
2790 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2791 doc
: /* Return bitwise-and of all the arguments.
2792 Arguments may be integers, or markers converted to integers.
2793 usage: (logand &rest INTS-OR-MARKERS) */)
2794 (ptrdiff_t nargs
, Lisp_Object
*args
)
2796 return arith_driver (Alogand
, nargs
, args
);
2799 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2800 doc
: /* Return bitwise-or of all the arguments.
2801 Arguments may be integers, or markers converted to integers.
2802 usage: (logior &rest INTS-OR-MARKERS) */)
2803 (ptrdiff_t nargs
, Lisp_Object
*args
)
2805 return arith_driver (Alogior
, nargs
, args
);
2808 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2809 doc
: /* Return bitwise-exclusive-or of all the arguments.
2810 Arguments may be integers, or markers converted to integers.
2811 usage: (logxor &rest INTS-OR-MARKERS) */)
2812 (ptrdiff_t nargs
, Lisp_Object
*args
)
2814 return arith_driver (Alogxor
, nargs
, args
);
2817 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2818 doc
: /* Return VALUE with its bits shifted left by COUNT.
2819 If COUNT is negative, shifting is actually to the right.
2820 In this case, the sign bit is duplicated. */)
2821 (register Lisp_Object value
, Lisp_Object count
)
2823 register Lisp_Object val
;
2825 CHECK_NUMBER (value
);
2826 CHECK_NUMBER (count
);
2828 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2830 else if (XINT (count
) > 0)
2831 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2832 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2833 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2835 XSETINT (val
, XINT (value
) >> -XINT (count
));
2839 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2840 doc
: /* Return VALUE with its bits shifted left by COUNT.
2841 If COUNT is negative, shifting is actually to the right.
2842 In this case, zeros are shifted in on the left. */)
2843 (register Lisp_Object value
, Lisp_Object count
)
2845 register Lisp_Object val
;
2847 CHECK_NUMBER (value
);
2848 CHECK_NUMBER (count
);
2850 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2852 else if (XINT (count
) > 0)
2853 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2854 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2857 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2861 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2862 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2863 Markers are converted to integers. */)
2864 (register Lisp_Object number
)
2866 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2868 if (FLOATP (number
))
2869 return (make_float (1.0 + XFLOAT_DATA (number
)));
2871 XSETINT (number
, XINT (number
) + 1);
2875 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2876 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2877 Markers are converted to integers. */)
2878 (register Lisp_Object number
)
2880 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2882 if (FLOATP (number
))
2883 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2885 XSETINT (number
, XINT (number
) - 1);
2889 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2890 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2891 (register Lisp_Object number
)
2893 CHECK_NUMBER (number
);
2894 XSETINT (number
, ~XINT (number
));
2898 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2899 doc
: /* Return the byteorder for the machine.
2900 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2901 lowercase l) for small endian machines. */)
2904 unsigned i
= 0x04030201;
2905 int order
= *(char *)&i
== 1 ? 108 : 66;
2907 return make_number (order
);
2910 /* Because we round up the bool vector allocate size to word_size
2911 units, we can safely read past the "end" of the vector in the
2912 operations below. These extra bits are always zero. */
2915 bool_vector_spare_mask (EMACS_INT nr_bits
)
2917 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2920 /* Info about unsigned long long, falling back on unsigned long
2921 if unsigned long long is not available. */
2923 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2924 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2925 # define ULL_MAX ULLONG_MAX
2927 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
2928 # define ULL_MAX ULONG_MAX
2929 # define count_one_bits_ll count_one_bits_l
2930 # define count_trailing_zeros_ll count_trailing_zeros_l
2933 /* Shift VAL right by the width of an unsigned long long.
2934 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
2937 shift_right_ull (bits_word w
)
2939 /* Pacify bogus GCC warning about shift count exceeding type width. */
2940 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
2944 /* Return the number of 1 bits in W. */
2947 count_one_bits_word (bits_word w
)
2949 if (BITS_WORD_MAX
<= UINT_MAX
)
2950 return count_one_bits (w
);
2951 else if (BITS_WORD_MAX
<= ULONG_MAX
)
2952 return count_one_bits_l (w
);
2955 int i
= 0, count
= 0;
2956 while (count
+= count_one_bits_ll (w
),
2957 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
2958 w
= shift_right_ull (w
);
2963 enum bool_vector_op
{ bool_vector_exclusive_or
,
2965 bool_vector_intersection
,
2966 bool_vector_set_difference
,
2967 bool_vector_subsetp
};
2970 bool_vector_binop_driver (Lisp_Object a
,
2973 enum bool_vector_op op
)
2976 bits_word
*adata
, *bdata
, *destdata
;
2980 CHECK_BOOL_VECTOR (a
);
2981 CHECK_BOOL_VECTOR (b
);
2983 nr_bits
= bool_vector_size (a
);
2984 if (bool_vector_size (b
) != nr_bits
)
2985 wrong_length_argument (a
, b
, dest
);
2987 nr_words
= bool_vector_words (nr_bits
);
2988 adata
= bool_vector_data (a
);
2989 bdata
= bool_vector_data (b
);
2993 dest
= make_uninit_bool_vector (nr_bits
);
2994 destdata
= bool_vector_data (dest
);
2998 CHECK_BOOL_VECTOR (dest
);
2999 destdata
= bool_vector_data (dest
);
3000 if (bool_vector_size (dest
) != nr_bits
)
3001 wrong_length_argument (a
, b
, dest
);
3005 case bool_vector_exclusive_or
:
3006 for (; i
< nr_words
; i
++)
3007 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
3011 case bool_vector_subsetp
:
3012 for (; i
< nr_words
; i
++)
3013 if (adata
[i
] &~ bdata
[i
])
3017 case bool_vector_union
:
3018 for (; i
< nr_words
; i
++)
3019 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
3023 case bool_vector_intersection
:
3024 for (; i
< nr_words
; i
++)
3025 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
3029 case bool_vector_set_difference
:
3030 for (; i
< nr_words
; i
++)
3031 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3042 case bool_vector_exclusive_or
:
3043 for (; i
< nr_words
; i
++)
3044 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3047 case bool_vector_union
:
3048 for (; i
< nr_words
; i
++)
3049 destdata
[i
] = adata
[i
] | bdata
[i
];
3052 case bool_vector_intersection
:
3053 for (; i
< nr_words
; i
++)
3054 destdata
[i
] = adata
[i
] & bdata
[i
];
3057 case bool_vector_set_difference
:
3058 for (; i
< nr_words
; i
++)
3059 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3069 /* PRECONDITION must be true. Return VALUE. This odd construction
3070 works around a bogus GCC diagnostic "shift count >= width of type". */
3073 pre_value (bool precondition
, int value
)
3075 eassume (precondition
);
3076 return precondition
? value
: 0;
3079 /* Compute the number of trailing zero bits in val. If val is zero,
3080 return the number of bits in val. */
3082 count_trailing_zero_bits (bits_word val
)
3084 if (BITS_WORD_MAX
== UINT_MAX
)
3085 return count_trailing_zeros (val
);
3086 if (BITS_WORD_MAX
== ULONG_MAX
)
3087 return count_trailing_zeros_l (val
);
3088 if (BITS_WORD_MAX
== ULL_MAX
)
3089 return count_trailing_zeros_ll (val
);
3091 /* The rest of this code is for the unlikely platform where bits_word differs
3092 in width from unsigned int, unsigned long, and unsigned long long. */
3093 val
|= ~ BITS_WORD_MAX
;
3094 if (BITS_WORD_MAX
<= UINT_MAX
)
3095 return count_trailing_zeros (val
);
3096 if (BITS_WORD_MAX
<= ULONG_MAX
)
3097 return count_trailing_zeros_l (val
);
3102 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3103 count
+= BITS_PER_ULL
)
3106 return count
+ count_trailing_zeros_ll (val
);
3107 val
= shift_right_ull (val
);
3110 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3111 && BITS_WORD_MAX
== (bits_word
) -1)
3112 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3113 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3114 return count
+ count_trailing_zeros_ll (val
);
3119 bits_word_to_host_endian (bits_word val
)
3121 #ifndef WORDS_BIGENDIAN
3124 if (BITS_WORD_MAX
>> 31 == 1)
3125 return bswap_32 (val
);
3126 # if HAVE_UNSIGNED_LONG_LONG
3127 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3128 return bswap_64 (val
);
3133 for (i
= 0; i
< sizeof val
; i
++)
3135 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3136 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3137 val
= val
>> 1 >> (CHAR_BIT
- 1);
3144 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3145 Sbool_vector_exclusive_or
, 2, 3, 0,
3146 doc
: /* Return A ^ B, bitwise exclusive or.
3147 If optional third argument C is given, store result into C.
3148 A, B, and C must be bool vectors of the same length.
3149 Return the destination vector if it changed or nil otherwise. */)
3150 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3152 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3155 DEFUN ("bool-vector-union", Fbool_vector_union
,
3156 Sbool_vector_union
, 2, 3, 0,
3157 doc
: /* Return A | B, bitwise or.
3158 If optional third argument C is given, store result into C.
3159 A, B, and C must be bool vectors of the same length.
3160 Return the destination vector if it changed or nil otherwise. */)
3161 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3163 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3166 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3167 Sbool_vector_intersection
, 2, 3, 0,
3168 doc
: /* Return A & B, bitwise and.
3169 If optional third argument C is given, store result into C.
3170 A, B, and C must be bool vectors of the same length.
3171 Return the destination vector if it changed or nil otherwise. */)
3172 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3174 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3177 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3178 Sbool_vector_set_difference
, 2, 3, 0,
3179 doc
: /* Return A &~ B, set difference.
3180 If optional third argument C is given, store result into C.
3181 A, B, and C must be bool vectors of the same length.
3182 Return the destination vector if it changed or nil otherwise. */)
3183 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3185 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3188 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3189 Sbool_vector_subsetp
, 2, 2, 0,
3190 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3191 A and B must be bool vectors of the same length. */)
3192 (Lisp_Object a
, Lisp_Object b
)
3194 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3197 DEFUN ("bool-vector-not", Fbool_vector_not
,
3198 Sbool_vector_not
, 1, 2, 0,
3199 doc
: /* Compute ~A, set complement.
3200 If optional second argument B is given, store result into B.
3201 A and B must be bool vectors of the same length.
3202 Return the destination vector. */)
3203 (Lisp_Object a
, Lisp_Object b
)
3206 bits_word
*bdata
, *adata
;
3209 CHECK_BOOL_VECTOR (a
);
3210 nr_bits
= bool_vector_size (a
);
3213 b
= make_uninit_bool_vector (nr_bits
);
3216 CHECK_BOOL_VECTOR (b
);
3217 if (bool_vector_size (b
) != nr_bits
)
3218 wrong_length_argument (a
, b
, Qnil
);
3221 bdata
= bool_vector_data (b
);
3222 adata
= bool_vector_data (a
);
3224 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3225 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3227 if (nr_bits
% BITS_PER_BITS_WORD
)
3229 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3231 mword
&= bool_vector_spare_mask (nr_bits
);
3232 bdata
[i
] = bits_word_to_host_endian (mword
);
3238 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3239 Sbool_vector_count_population
, 1, 1, 0,
3240 doc
: /* Count how many elements in A are t.
3241 A is a bool vector. To count A's nil elements, subtract the return
3242 value from A's length. */)
3248 ptrdiff_t i
, nwords
;
3250 CHECK_BOOL_VECTOR (a
);
3252 nr_bits
= bool_vector_size (a
);
3253 nwords
= bool_vector_words (nr_bits
);
3255 adata
= bool_vector_data (a
);
3257 for (i
= 0; i
< nwords
; i
++)
3258 count
+= count_one_bits_word (adata
[i
]);
3260 return make_number (count
);
3263 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3264 Sbool_vector_count_consecutive
, 3, 3, 0,
3265 doc
: /* Count how many consecutive elements in A equal B starting at I.
3266 A is a bool vector, B is t or nil, and I is an index into A. */)
3267 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3274 bits_word mword
; /* Machine word. */
3275 ptrdiff_t pos
, pos0
;
3278 CHECK_BOOL_VECTOR (a
);
3281 nr_bits
= bool_vector_size (a
);
3282 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3283 args_out_of_range (a
, i
);
3285 adata
= bool_vector_data (a
);
3286 nr_words
= bool_vector_words (nr_bits
);
3287 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3288 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3291 /* By XORing with twiddle, we transform the problem of "count
3292 consecutive equal values" into "count the zero bits". The latter
3293 operation usually has hardware support. */
3294 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3296 /* Scan the remainder of the mword at the current offset. */
3297 if (pos
< nr_words
&& offset
!= 0)
3299 mword
= bits_word_to_host_endian (adata
[pos
]);
3303 /* Do not count the pad bits. */
3304 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3306 count
= count_trailing_zero_bits (mword
);
3308 if (count
+ offset
< BITS_PER_BITS_WORD
)
3309 return make_number (count
);
3312 /* Scan whole words until we either reach the end of the vector or
3313 find an mword that doesn't completely match. twiddle is
3314 endian-independent. */
3316 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3318 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3322 /* If we stopped because of a mismatch, see how many bits match
3323 in the current mword. */
3324 mword
= bits_word_to_host_endian (adata
[pos
]);
3326 count
+= count_trailing_zero_bits (mword
);
3328 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3330 /* If we hit the end, we might have overshot our count. Reduce
3331 the total by the number of spare bits at the end of the
3333 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3336 return make_number (count
);
3340 DEFUN ("bind-symbol", Fbind_symbol
, Sbind_symbol
, 3, 3, 0,
3341 doc
: /* Bind symbol. */)
3342 (Lisp_Object symbol
, Lisp_Object value
, Lisp_Object thunk
)
3346 specbind (symbol
, value
);
3347 val
= call0 (thunk
);
3355 Lisp_Object error_tail
, arith_tail
;
3357 /* Used by defsubr. */
3358 DEFSYM (Qspecial_operator
, "special-operator");
3359 DEFSYM (Qinteractive_form
, "interactive-form");
3363 DEFSYM (Qquote
, "quote");
3364 DEFSYM (Qlambda
, "lambda");
3365 DEFSYM (Qsubr
, "subr");
3366 DEFSYM (Qerror_conditions
, "error-conditions");
3367 DEFSYM (Qerror_message
, "error-message");
3368 DEFSYM (Qtop_level
, "top-level");
3370 DEFSYM (Qerror
, "error");
3371 DEFSYM (Quser_error
, "user-error");
3372 DEFSYM (Qquit
, "quit");
3373 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3374 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3375 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3376 DEFSYM (Qvoid_function
, "void-function");
3377 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3378 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3379 DEFSYM (Qvoid_variable
, "void-variable");
3380 DEFSYM (Qsetting_constant
, "setting-constant");
3381 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3383 DEFSYM (Qinvalid_function
, "invalid-function");
3384 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3385 DEFSYM (Qno_catch
, "no-catch");
3386 DEFSYM (Qend_of_file
, "end-of-file");
3387 DEFSYM (Qarith_error
, "arith-error");
3388 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3389 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3390 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3391 DEFSYM (Qtext_read_only
, "text-read-only");
3392 DEFSYM (Qmark_inactive
, "mark-inactive");
3394 DEFSYM (Qlistp
, "listp");
3395 DEFSYM (Qconsp
, "consp");
3396 DEFSYM (Qsymbolp
, "symbolp");
3397 DEFSYM (Qkeywordp
, "keywordp");
3398 DEFSYM (Qintegerp
, "integerp");
3399 DEFSYM (Qnatnump
, "natnump");
3400 DEFSYM (Qwholenump
, "wholenump");
3401 DEFSYM (Qstringp
, "stringp");
3402 DEFSYM (Qarrayp
, "arrayp");
3403 DEFSYM (Qsequencep
, "sequencep");
3404 DEFSYM (Qbufferp
, "bufferp");
3405 DEFSYM (Qvectorp
, "vectorp");
3406 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3407 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3408 DEFSYM (Qmarkerp
, "markerp");
3409 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3410 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3411 DEFSYM (Qboundp
, "boundp");
3412 DEFSYM (Qfboundp
, "fboundp");
3414 DEFSYM (Qfloatp
, "floatp");
3415 DEFSYM (Qnumberp
, "numberp");
3416 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3418 DEFSYM (Qchar_table_p
, "char-table-p");
3419 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3421 DEFSYM (Qsubrp
, "subrp");
3422 DEFSYM (Qunevalled
, "unevalled");
3423 DEFSYM (Qmany
, "many");
3425 DEFSYM (Qcdr
, "cdr");
3427 /* Handle automatic advice activation. */
3428 DEFSYM (Qad_advice_info
, "ad-advice-info");
3429 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3431 error_tail
= pure_cons (Qerror
, Qnil
);
3433 /* ERROR is used as a signaler for random errors for which nothing else is
3436 Fput (Qerror
, Qerror_conditions
,
3438 Fput (Qerror
, Qerror_message
,
3439 build_pure_c_string ("error"));
3441 #define PUT_ERROR(sym, tail, msg) \
3442 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3443 Fput (sym, Qerror_message, build_pure_c_string (msg))
3445 PUT_ERROR (Qquit
, Qnil
, "Quit");
3447 PUT_ERROR (Quser_error
, error_tail
, "");
3448 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3449 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3450 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3451 PUT_ERROR (Qvoid_function
, error_tail
,
3452 "Symbol's function definition is void");
3453 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3454 "Symbol's chain of function indirections contains a loop");
3455 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3456 "Symbol's chain of variable indirections contains a loop");
3457 DEFSYM (Qcircular_list
, "circular-list");
3458 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3459 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3460 PUT_ERROR (Qsetting_constant
, error_tail
,
3461 "Attempt to set a constant symbol");
3462 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3463 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3464 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3465 "Wrong number of arguments");
3466 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3467 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3469 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3470 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3471 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3473 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3474 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3475 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3476 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3477 "Text is read-only");
3479 DEFSYM (Qrange_error
, "range-error");
3480 DEFSYM (Qdomain_error
, "domain-error");
3481 DEFSYM (Qsingularity_error
, "singularity-error");
3482 DEFSYM (Qoverflow_error
, "overflow-error");
3483 DEFSYM (Qunderflow_error
, "underflow-error");
3485 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3487 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3489 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3490 "Arithmetic singularity error");
3492 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3493 "Arithmetic overflow error");
3494 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3495 "Arithmetic underflow error");
3499 staticpro (&Qunbound
);
3501 /* Types that type-of returns. */
3502 DEFSYM (Qinteger
, "integer");
3503 DEFSYM (Qsymbol
, "symbol");
3504 DEFSYM (Qstring
, "string");
3505 DEFSYM (Qcons
, "cons");
3506 DEFSYM (Qmarker
, "marker");
3507 DEFSYM (Qoverlay
, "overlay");
3508 DEFSYM (Qfloat
, "float");
3509 DEFSYM (Qwindow_configuration
, "window-configuration");
3510 DEFSYM (Qprocess
, "process");
3511 DEFSYM (Qwindow
, "window");
3512 DEFSYM (Qcompiled_function
, "compiled-function");
3513 DEFSYM (Qbuffer
, "buffer");
3514 DEFSYM (Qframe
, "frame");
3515 DEFSYM (Qvector
, "vector");
3516 DEFSYM (Qchar_table
, "char-table");
3517 DEFSYM (Qbool_vector
, "bool-vector");
3518 DEFSYM (Qhash_table
, "hash-table");
3519 DEFSYM (Qmisc
, "misc");
3521 DEFSYM (Qdefun
, "defun");
3523 DEFSYM (Qfont_spec
, "font-spec");
3524 DEFSYM (Qfont_entity
, "font-entity");
3525 DEFSYM (Qfont_object
, "font-object");
3527 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3529 set_symbol_function (Qwholenump
, SYMBOL_FUNCTION (Qnatnump
));
3531 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3532 doc
: /* The largest value that is representable in a Lisp integer. */);
3533 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3534 SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-positive-fixnum")), 1);
3536 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3537 doc
: /* The smallest value that is representable in a Lisp integer. */);
3538 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3539 SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-negative-fixnum")), 1);