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
);
806 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
807 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
809 else if (scm_is_true (scm_procedure_p (fun
)))
811 Lisp_Object tem
= scm_assq (Qinteractive_form
,
812 scm_procedure_properties (fun
));
813 if (scm_is_pair (tem
))
814 return list2 (Qinteractive
, scm_cdr (tem
));
816 else if (AUTOLOADP (fun
))
817 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
818 else if (CONSP (fun
))
820 Lisp_Object funcar
= XCAR (fun
);
821 if (EQ (funcar
, Qclosure
))
822 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
823 else if (EQ (funcar
, Qlambda
))
824 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
830 /***********************************************************************
831 Getting and Setting Values of Symbols
832 ***********************************************************************/
834 /* Return the symbol holding SYMBOL's value. Signal
835 `cyclic-variable-indirection' if SYMBOL's chain of variable
836 indirections contains a loop. */
839 indirect_variable (sym_t symbol
)
841 sym_t tortoise
, hare
;
843 hare
= tortoise
= symbol
;
845 while (SYMBOL_REDIRECT (hare
) == SYMBOL_VARALIAS
)
847 hare
= SYMBOL_ALIAS (hare
);
848 if (SYMBOL_REDIRECT (hare
) != SYMBOL_VARALIAS
)
851 hare
= SYMBOL_ALIAS (hare
);
852 tortoise
= SYMBOL_ALIAS (tortoise
);
854 if (hare
== tortoise
)
857 XSETSYMBOL (tem
, symbol
);
858 xsignal1 (Qcyclic_variable_indirection
, tem
);
866 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
867 doc
: /* Return the variable at the end of OBJECT's variable chain.
868 If OBJECT is a symbol, follow its variable indirections (if any), and
869 return the variable at the end of the chain of aliases. See Info node
870 `(elisp)Variable Aliases'.
872 If OBJECT is not a symbol, just return it. If there is a loop in the
873 chain of aliases, signal a `cyclic-variable-indirection' error. */)
876 if (SYMBOLP (object
))
878 sym_t sym
= indirect_variable (XSYMBOL (object
));
879 XSETSYMBOL (object
, sym
);
885 /* Given the raw contents of a symbol value cell,
886 return the Lisp value of the symbol.
887 This does not handle buffer-local variables; use
888 swap_in_symval_forwarding for that. */
891 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
893 register Lisp_Object val
;
894 switch (XFWDTYPE (valcontents
))
897 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
901 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
904 return *XOBJFWD (valcontents
)->objvar
;
906 case Lisp_Fwd_Buffer_Obj
:
907 return per_buffer_value (current_buffer
,
908 XBUFFER_OBJFWD (valcontents
)->offset
);
910 case Lisp_Fwd_Kboard_Obj
:
911 /* We used to simply use current_kboard here, but from Lisp
912 code, its value is often unexpected. It seems nicer to
913 allow constructions like this to work as intuitively expected:
915 (with-selected-frame frame
916 (define-key local-function-map "\eOP" [f1]))
918 On the other hand, this affects the semantics of
919 last-command and real-last-command, and people may rely on
920 that. I took a quick look at the Lisp codebase, and I
921 don't think anything will break. --lorentey */
922 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
923 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
924 default: emacs_abort ();
928 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
929 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
930 buffer-independent contents of the value cell: forwarded just one
931 step past the buffer-localness.
933 BUF non-zero means set the value in buffer BUF instead of the
934 current buffer. This only plays a role for per-buffer variables. */
937 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
939 switch (XFWDTYPE (valcontents
))
942 CHECK_NUMBER (newval
);
943 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
947 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
951 *XOBJFWD (valcontents
)->objvar
= newval
;
953 /* If this variable is a default for something stored
954 in the buffer itself, such as default-fill-column,
955 find the buffers that don't have local values for it
957 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
958 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
960 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
961 - (char *) &buffer_defaults
);
962 int idx
= PER_BUFFER_IDX (offset
);
964 Lisp_Object tail
, buf
;
969 FOR_EACH_LIVE_BUFFER (tail
, buf
)
971 struct buffer
*b
= XBUFFER (buf
);
973 if (! PER_BUFFER_VALUE_P (b
, idx
))
974 set_per_buffer_value (b
, offset
, newval
);
979 case Lisp_Fwd_Buffer_Obj
:
981 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
982 Lisp_Object predicate
= XBUFFER_OBJFWD (valcontents
)->predicate
;
984 if (!NILP (predicate
) && !NILP (newval
)
985 && NILP (call1 (predicate
, newval
)))
986 wrong_type_argument (predicate
, newval
);
989 buf
= current_buffer
;
990 set_per_buffer_value (buf
, offset
, newval
);
994 case Lisp_Fwd_Kboard_Obj
:
996 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
997 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
998 *(Lisp_Object
*) p
= newval
;
1003 emacs_abort (); /* goto def; */
1007 /* Set up SYMBOL to refer to its global binding. This makes it safe
1008 to alter the status of other bindings. BEWARE: this may be called
1009 during the mark phase of GC, where we assume that Lisp_Object slots
1010 of BLV are marked after this function has changed them. */
1013 swap_in_global_binding (sym_t symbol
)
1015 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1017 /* Unload the previously loaded binding. */
1019 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1021 /* Select the global binding in the symbol. */
1022 set_blv_valcell (blv
, blv
->defcell
);
1024 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1026 /* Indicate that the global binding is set up now. */
1027 set_blv_where (blv
, Qnil
);
1028 set_blv_found (blv
, 0);
1031 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1032 VALCONTENTS is the contents of its value cell,
1033 which points to a struct Lisp_Buffer_Local_Value.
1035 Return the value forwarded one step past the buffer-local stage.
1036 This could be another forwarding pointer. */
1039 swap_in_symval_forwarding (sym_t symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1041 register Lisp_Object tem1
;
1043 eassert (blv
== SYMBOL_BLV (symbol
));
1048 || (blv
->frame_local
1049 ? !EQ (selected_frame
, tem1
)
1050 : current_buffer
!= XBUFFER (tem1
)))
1053 /* Unload the previously loaded binding. */
1054 tem1
= blv
->valcell
;
1056 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1057 /* Choose the new binding. */
1060 XSETSYMBOL (var
, symbol
);
1061 if (blv
->frame_local
)
1063 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1064 set_blv_where (blv
, selected_frame
);
1068 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1069 set_blv_where (blv
, Fcurrent_buffer ());
1072 if (!(blv
->found
= !NILP (tem1
)))
1073 tem1
= blv
->defcell
;
1075 /* Load the new binding. */
1076 set_blv_valcell (blv
, tem1
);
1078 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1082 /* Find the value of a symbol, returning Qunbound if it's not bound.
1083 This is helpful for code which just wants to get a variable's value
1084 if it has one, without signaling an error.
1085 Note that it must not be possible to quit
1086 within this function. Great care is required for this. */
1089 find_symbol_value (Lisp_Object symbol
)
1093 CHECK_SYMBOL (symbol
);
1094 sym
= XSYMBOL (symbol
);
1097 switch (SYMBOL_REDIRECT (sym
))
1099 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1100 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1101 case SYMBOL_LOCALIZED
:
1103 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1104 swap_in_symval_forwarding (sym
, blv
);
1105 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1108 case SYMBOL_FORWARDED
:
1109 return do_symval_forwarding (SYMBOL_FWD (sym
));
1110 default: emacs_abort ();
1114 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1115 doc
: /* Return SYMBOL's value. Error if that is void.
1116 Note that if `lexical-binding' is in effect, this returns the
1117 global value outside of any lexical scope. */)
1118 (Lisp_Object symbol
)
1122 val
= find_symbol_value (symbol
);
1123 if (!EQ (val
, Qunbound
))
1126 xsignal1 (Qvoid_variable
, symbol
);
1129 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1130 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1131 (register Lisp_Object symbol
, Lisp_Object newval
)
1133 set_internal (symbol
, newval
, Qnil
, 0);
1137 /* Store the value NEWVAL into SYMBOL.
1138 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1139 (nil stands for the current buffer/frame).
1141 If BINDFLAG is false, then if this symbol is supposed to become
1142 local in every buffer where it is set, then we make it local.
1143 If BINDFLAG is true, we don't do that. */
1146 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1149 bool voide
= EQ (newval
, Qunbound
);
1153 /* If restoring in a dead buffer, do nothing. */
1154 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1157 CHECK_SYMBOL (symbol
);
1158 if (SYMBOL_CONSTANT_P (symbol
))
1160 if (NILP (Fkeywordp (symbol
))
1161 || !EQ (newval
, Fsymbol_value (symbol
)))
1162 xsignal1 (Qsetting_constant
, symbol
);
1164 /* Allow setting keywords to their own value. */
1168 sym
= XSYMBOL (symbol
);
1171 switch (SYMBOL_REDIRECT (sym
))
1173 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1174 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1175 case SYMBOL_LOCALIZED
:
1177 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1180 if (blv
->frame_local
)
1181 where
= selected_frame
;
1183 XSETBUFFER (where
, current_buffer
);
1185 /* If the current buffer is not the buffer whose binding is
1186 loaded, or if there may be frame-local bindings and the frame
1187 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1188 the default binding is loaded, the loaded binding may be the
1190 if (!EQ (blv
->where
, where
)
1191 /* Also unload a global binding (if the var is local_if_set). */
1192 || (EQ (blv
->valcell
, blv
->defcell
)))
1194 /* The currently loaded binding is not necessarily valid.
1195 We need to unload it, and choose a new binding. */
1197 /* Write out `realvalue' to the old loaded binding. */
1199 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1201 /* Find the new binding. */
1202 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1203 tem1
= Fassq (symbol
,
1205 ? XFRAME (where
)->param_alist
1206 : BVAR (XBUFFER (where
), local_var_alist
)));
1207 set_blv_where (blv
, where
);
1212 /* This buffer still sees the default value. */
1214 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1215 or if this is `let' rather than `set',
1216 make CURRENT-ALIST-ELEMENT point to itself,
1217 indicating that we're seeing the default value.
1218 Likewise if the variable has been let-bound
1219 in the current buffer. */
1220 if (bindflag
|| !blv
->local_if_set
1221 || let_shadows_buffer_binding_p (sym
))
1224 tem1
= blv
->defcell
;
1226 /* If it's a local_if_set, being set not bound,
1227 and we're not within a let that was made for this buffer,
1228 create a new buffer-local binding for the variable.
1229 That means, give this buffer a new assoc for a local value
1230 and load that binding. */
1233 /* local_if_set is only supported for buffer-local
1234 bindings, not for frame-local bindings. */
1235 eassert (!blv
->frame_local
);
1236 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1237 bset_local_var_alist
1239 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1243 /* Record which binding is now loaded. */
1244 set_blv_valcell (blv
, tem1
);
1247 /* Store the new value in the cons cell. */
1248 set_blv_value (blv
, newval
);
1253 /* If storing void (making the symbol void), forward only through
1254 buffer-local indicator, not through Lisp_Objfwd, etc. */
1257 store_symval_forwarding (blv
->fwd
, newval
,
1259 ? XBUFFER (where
) : current_buffer
);
1263 case SYMBOL_FORWARDED
:
1266 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1267 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1268 if (BUFFER_OBJFWDP (innercontents
))
1270 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1271 int idx
= PER_BUFFER_IDX (offset
);
1274 && !let_shadows_buffer_binding_p (sym
))
1275 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1279 { /* If storing void (making the symbol void), forward only through
1280 buffer-local indicator, not through Lisp_Objfwd, etc. */
1281 SET_SYMBOL_REDIRECT (sym
, SYMBOL_PLAINVAL
);
1282 SET_SYMBOL_VAL (sym
, newval
);
1285 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1288 default: emacs_abort ();
1293 /* Access or set a buffer-local symbol's default value. */
1295 /* Return the default value of SYMBOL, but don't check for voidness.
1296 Return Qunbound if it is void. */
1299 default_value (Lisp_Object symbol
)
1303 CHECK_SYMBOL (symbol
);
1304 sym
= XSYMBOL (symbol
);
1307 switch (SYMBOL_REDIRECT (sym
))
1309 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1310 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1311 case SYMBOL_LOCALIZED
:
1313 /* If var is set up for a buffer that lacks a local value for it,
1314 the current value is nominally the default value.
1315 But the `realvalue' slot may be more up to date, since
1316 ordinary setq stores just that slot. So use that. */
1317 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1318 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1319 return do_symval_forwarding (blv
->fwd
);
1321 return XCDR (blv
->defcell
);
1323 case SYMBOL_FORWARDED
:
1325 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1327 /* For a built-in buffer-local variable, get the default value
1328 rather than letting do_symval_forwarding get the current value. */
1329 if (BUFFER_OBJFWDP (valcontents
))
1331 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1332 if (PER_BUFFER_IDX (offset
) != 0)
1333 return per_buffer_default (offset
);
1336 /* For other variables, get the current value. */
1337 return do_symval_forwarding (valcontents
);
1339 default: emacs_abort ();
1343 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1344 doc
: /* Return t if SYMBOL has a non-void default value.
1345 This is the value that is seen in buffers that do not have their own values
1346 for this variable. */)
1347 (Lisp_Object symbol
)
1349 register Lisp_Object value
;
1351 value
= default_value (symbol
);
1352 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1355 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1356 doc
: /* Return SYMBOL's default value.
1357 This is the value that is seen in buffers that do not have their own values
1358 for this variable. The default value is meaningful for variables with
1359 local bindings in certain buffers. */)
1360 (Lisp_Object symbol
)
1362 Lisp_Object value
= default_value (symbol
);
1363 if (!EQ (value
, Qunbound
))
1366 xsignal1 (Qvoid_variable
, symbol
);
1369 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1370 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1371 The default value is seen in buffers that do not have their own values
1372 for this variable. */)
1373 (Lisp_Object symbol
, Lisp_Object value
)
1377 CHECK_SYMBOL (symbol
);
1378 if (SYMBOL_CONSTANT_P (symbol
))
1380 if (NILP (Fkeywordp (symbol
))
1381 || !EQ (value
, Fdefault_value (symbol
)))
1382 xsignal1 (Qsetting_constant
, symbol
);
1384 /* Allow setting keywords to their own value. */
1387 sym
= XSYMBOL (symbol
);
1390 switch (SYMBOL_REDIRECT (sym
))
1392 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1393 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1394 case SYMBOL_LOCALIZED
:
1396 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1398 /* Store new value into the DEFAULT-VALUE slot. */
1399 XSETCDR (blv
->defcell
, value
);
1401 /* If the default binding is now loaded, set the REALVALUE slot too. */
1402 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1403 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1406 case SYMBOL_FORWARDED
:
1408 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1410 /* Handle variables like case-fold-search that have special slots
1412 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1413 if (BUFFER_OBJFWDP (valcontents
))
1415 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1416 int idx
= PER_BUFFER_IDX (offset
);
1418 set_per_buffer_default (offset
, value
);
1420 /* If this variable is not always local in all buffers,
1421 set it in the buffers that don't nominally have a local value. */
1427 if (!PER_BUFFER_VALUE_P (b
, idx
))
1428 set_per_buffer_value (b
, offset
, value
);
1433 return Fset (symbol
, value
);
1435 default: emacs_abort ();
1439 /* Lisp functions for creating and removing buffer-local variables. */
1444 union Lisp_Fwd
*fwd
;
1447 static struct Lisp_Buffer_Local_Value
*
1448 make_blv (sym_t sym
, bool forwarded
,
1449 union Lisp_Val_Fwd valcontents
)
1451 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1455 XSETSYMBOL (symbol
, sym
);
1456 tem
= Fcons (symbol
, (forwarded
1457 ? do_symval_forwarding (valcontents
.fwd
)
1458 : valcontents
.value
));
1460 /* Buffer_Local_Values cannot have as realval a buffer-local
1461 or keyboard-local forwarding. */
1462 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1463 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1464 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1465 set_blv_where (blv
, Qnil
);
1466 blv
->frame_local
= 0;
1467 blv
->local_if_set
= 0;
1468 set_blv_defcell (blv
, tem
);
1469 set_blv_valcell (blv
, tem
);
1470 set_blv_found (blv
, 0);
1474 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1475 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1476 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1477 At any time, the value for the current buffer is in effect,
1478 unless the variable has never been set in this buffer,
1479 in which case the default value is in effect.
1480 Note that binding the variable with `let', or setting it while
1481 a `let'-style binding made in this buffer is in effect,
1482 does not make the variable buffer-local. Return VARIABLE.
1484 This globally affects all uses of this variable, so it belongs together with
1485 the variable declaration, rather than with its uses (if you just want to make
1486 a variable local to the current buffer for one particular use, use
1487 `make-local-variable'). Buffer-local bindings are normally cleared
1488 while setting up a new major mode, unless they have a `permanent-local'
1491 The function `default-value' gets the default value and `set-default' sets it. */)
1492 (register Lisp_Object variable
)
1495 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1496 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1497 bool forwarded
IF_LINT (= 0);
1499 CHECK_SYMBOL (variable
);
1500 sym
= XSYMBOL (variable
);
1503 switch (SYMBOL_REDIRECT (sym
))
1505 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1506 case SYMBOL_PLAINVAL
:
1507 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1508 if (EQ (valcontents
.value
, Qunbound
))
1509 valcontents
.value
= Qnil
;
1511 case SYMBOL_LOCALIZED
:
1512 blv
= SYMBOL_BLV (sym
);
1513 if (blv
->frame_local
)
1514 error ("Symbol %s may not be buffer-local",
1515 SDATA (SYMBOL_NAME (variable
)));
1517 case SYMBOL_FORWARDED
:
1518 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1519 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1520 error ("Symbol %s may not be buffer-local",
1521 SDATA (SYMBOL_NAME (variable
)));
1522 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1525 default: emacs_abort ();
1528 if (SYMBOL_CONSTANT (sym
))
1529 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1533 blv
= make_blv (sym
, forwarded
, valcontents
);
1534 SET_SYMBOL_REDIRECT (sym
, SYMBOL_LOCALIZED
);
1535 SET_SYMBOL_BLV (sym
, blv
);
1538 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1539 if (let_shadows_global_binding_p (symbol
))
1540 message ("Making %s buffer-local while let-bound!",
1541 SDATA (SYMBOL_NAME (variable
)));
1545 blv
->local_if_set
= 1;
1549 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1550 1, 1, "vMake Local Variable: ",
1551 doc
: /* Make VARIABLE have a separate value in the current buffer.
1552 Other buffers will continue to share a common default value.
1553 \(The buffer-local value of VARIABLE starts out as the same value
1554 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1557 If the variable is already arranged to become local when set,
1558 this function causes a local value to exist for this buffer,
1559 just as setting the variable would do.
1561 This function returns VARIABLE, and therefore
1562 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1565 See also `make-variable-buffer-local'.
1567 Do not use `make-local-variable' to make a hook variable buffer-local.
1568 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1569 (Lisp_Object variable
)
1572 bool forwarded
IF_LINT (= 0);
1573 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1575 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1577 CHECK_SYMBOL (variable
);
1578 sym
= XSYMBOL (variable
);
1581 switch (SYMBOL_REDIRECT (sym
))
1583 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1584 case SYMBOL_PLAINVAL
:
1585 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1586 case SYMBOL_LOCALIZED
:
1587 blv
= SYMBOL_BLV (sym
);
1588 if (blv
->frame_local
)
1589 error ("Symbol %s may not be buffer-local",
1590 SDATA (SYMBOL_NAME (variable
)));
1592 case SYMBOL_FORWARDED
:
1593 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1594 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1595 error ("Symbol %s may not be buffer-local",
1596 SDATA (SYMBOL_NAME (variable
)));
1598 default: emacs_abort ();
1601 if (SYMBOL_CONSTANT (sym
))
1602 error ("Symbol %s may not be buffer-local",
1603 SDATA (SYMBOL_NAME (variable
)));
1605 if (blv
? blv
->local_if_set
1606 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1608 tem
= Fboundp (variable
);
1609 /* Make sure the symbol has a local value in this particular buffer,
1610 by setting it to the same value it already has. */
1611 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1616 blv
= make_blv (sym
, forwarded
, valcontents
);
1617 SET_SYMBOL_REDIRECT (sym
, SYMBOL_LOCALIZED
);
1618 SET_SYMBOL_BLV (sym
, blv
);
1621 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1622 if (let_shadows_global_binding_p (symbol
))
1623 message ("Making %s local to %s while let-bound!",
1624 SDATA (SYMBOL_NAME (variable
)),
1625 SDATA (BVAR (current_buffer
, name
)));
1629 /* Make sure this buffer has its own value of symbol. */
1630 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1631 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1634 if (let_shadows_buffer_binding_p (sym
))
1635 message ("Making %s buffer-local while locally let-bound!",
1636 SDATA (SYMBOL_NAME (variable
)));
1638 /* Swap out any local binding for some other buffer, and make
1639 sure the current value is permanently recorded, if it's the
1641 find_symbol_value (variable
);
1643 bset_local_var_alist
1645 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1646 BVAR (current_buffer
, local_var_alist
)));
1648 /* Make sure symbol does not think it is set up for this buffer;
1649 force it to look once again for this buffer's value. */
1650 if (current_buffer
== XBUFFER (blv
->where
))
1651 set_blv_where (blv
, Qnil
);
1652 set_blv_found (blv
, 0);
1655 /* If the symbol forwards into a C variable, then load the binding
1656 for this buffer now. If C code modifies the variable before we
1657 load the binding in, then that new value will clobber the default
1658 binding the next time we unload it. */
1660 swap_in_symval_forwarding (sym
, blv
);
1665 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1666 1, 1, "vKill Local Variable: ",
1667 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1668 From now on the default value will apply in this buffer. Return VARIABLE. */)
1669 (register Lisp_Object variable
)
1671 register Lisp_Object tem
;
1672 struct Lisp_Buffer_Local_Value
*blv
;
1675 CHECK_SYMBOL (variable
);
1676 sym
= XSYMBOL (variable
);
1679 switch (SYMBOL_REDIRECT (sym
))
1681 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1682 case SYMBOL_PLAINVAL
: return variable
;
1683 case SYMBOL_FORWARDED
:
1685 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1686 if (BUFFER_OBJFWDP (valcontents
))
1688 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1689 int idx
= PER_BUFFER_IDX (offset
);
1693 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1694 set_per_buffer_value (current_buffer
, offset
,
1695 per_buffer_default (offset
));
1700 case SYMBOL_LOCALIZED
:
1701 blv
= SYMBOL_BLV (sym
);
1702 if (blv
->frame_local
)
1705 default: emacs_abort ();
1708 /* Get rid of this buffer's alist element, if any. */
1709 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1710 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1712 bset_local_var_alist
1714 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1716 /* If the symbol is set up with the current buffer's binding
1717 loaded, recompute its value. We have to do it now, or else
1718 forwarded objects won't work right. */
1720 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1721 if (EQ (buf
, blv
->where
))
1723 set_blv_where (blv
, Qnil
);
1725 find_symbol_value (variable
);
1732 /* Lisp functions for creating and removing buffer-local variables. */
1734 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1735 when/if this is removed. */
1737 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1738 1, 1, "vMake Variable Frame Local: ",
1739 doc
: /* Enable VARIABLE to have frame-local bindings.
1740 This does not create any frame-local bindings for VARIABLE,
1741 it just makes them possible.
1743 A frame-local binding is actually a frame parameter value.
1744 If a frame F has a value for the frame parameter named VARIABLE,
1745 that also acts as a frame-local binding for VARIABLE in F--
1746 provided this function has been called to enable VARIABLE
1747 to have frame-local bindings at all.
1749 The only way to create a frame-local binding for VARIABLE in a frame
1750 is to set the VARIABLE frame parameter of that frame. See
1751 `modify-frame-parameters' for how to set frame parameters.
1753 Note that since Emacs 23.1, variables cannot be both buffer-local and
1754 frame-local any more (buffer-local bindings used to take precedence over
1755 frame-local bindings). */)
1756 (Lisp_Object variable
)
1759 union Lisp_Val_Fwd valcontents
;
1761 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1763 CHECK_SYMBOL (variable
);
1764 sym
= XSYMBOL (variable
);
1767 switch (SYMBOL_REDIRECT (sym
))
1769 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1770 case SYMBOL_PLAINVAL
:
1771 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1772 if (EQ (valcontents
.value
, Qunbound
))
1773 valcontents
.value
= Qnil
;
1775 case SYMBOL_LOCALIZED
:
1776 if (SYMBOL_BLV (sym
)->frame_local
)
1779 error ("Symbol %s may not be frame-local",
1780 SDATA (SYMBOL_NAME (variable
)));
1781 case SYMBOL_FORWARDED
:
1782 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1783 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1784 error ("Symbol %s may not be frame-local",
1785 SDATA (SYMBOL_NAME (variable
)));
1787 default: emacs_abort ();
1790 if (SYMBOL_CONSTANT (sym
))
1791 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1793 blv
= make_blv (sym
, forwarded
, valcontents
);
1794 blv
->frame_local
= 1;
1795 SET_SYMBOL_REDIRECT (sym
, SYMBOL_LOCALIZED
);
1796 SET_SYMBOL_BLV (sym
, blv
);
1799 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1800 if (let_shadows_global_binding_p (symbol
))
1801 message ("Making %s frame-local while let-bound!",
1802 SDATA (SYMBOL_NAME (variable
)));
1807 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1809 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1810 BUFFER defaults to the current buffer. */)
1811 (register Lisp_Object variable
, Lisp_Object buffer
)
1813 register struct buffer
*buf
;
1817 buf
= current_buffer
;
1820 CHECK_BUFFER (buffer
);
1821 buf
= XBUFFER (buffer
);
1824 CHECK_SYMBOL (variable
);
1825 sym
= XSYMBOL (variable
);
1828 switch (SYMBOL_REDIRECT (sym
))
1830 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1831 case SYMBOL_PLAINVAL
: return Qnil
;
1832 case SYMBOL_LOCALIZED
:
1834 Lisp_Object tail
, elt
, tmp
;
1835 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1836 XSETBUFFER (tmp
, buf
);
1837 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1839 if (EQ (blv
->where
, tmp
)) /* The binding is already loaded. */
1840 return blv_found (blv
) ? Qt
: Qnil
;
1842 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1845 if (EQ (variable
, XCAR (elt
)))
1847 eassert (!blv
->frame_local
);
1853 case SYMBOL_FORWARDED
:
1855 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1856 if (BUFFER_OBJFWDP (valcontents
))
1858 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1859 int idx
= PER_BUFFER_IDX (offset
);
1860 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1865 default: emacs_abort ();
1869 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1871 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1872 BUFFER defaults to the current buffer.
1874 More precisely, return non-nil if either VARIABLE already has a local
1875 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1876 `make-variable-buffer-local'). */)
1877 (register Lisp_Object variable
, Lisp_Object buffer
)
1881 CHECK_SYMBOL (variable
);
1882 sym
= XSYMBOL (variable
);
1885 switch (SYMBOL_REDIRECT (sym
))
1887 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1888 case SYMBOL_PLAINVAL
: return Qnil
;
1889 case SYMBOL_LOCALIZED
:
1891 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1892 if (blv
->local_if_set
)
1894 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1895 return Flocal_variable_p (variable
, buffer
);
1897 case SYMBOL_FORWARDED
:
1898 /* All BUFFER_OBJFWD slots become local if they are set. */
1899 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1900 default: emacs_abort ();
1904 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1906 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1907 If the current binding is buffer-local, the value is the current buffer.
1908 If the current binding is frame-local, the value is the selected frame.
1909 If the current binding is global (the default), the value is nil. */)
1910 (register Lisp_Object variable
)
1914 CHECK_SYMBOL (variable
);
1915 sym
= XSYMBOL (variable
);
1917 /* Make sure the current binding is actually swapped in. */
1918 find_symbol_value (variable
);
1921 switch (SYMBOL_REDIRECT (sym
))
1923 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1924 case SYMBOL_PLAINVAL
: return Qnil
;
1925 case SYMBOL_FORWARDED
:
1927 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1928 if (KBOARD_OBJFWDP (valcontents
))
1929 return Fframe_terminal (selected_frame
);
1930 else if (!BUFFER_OBJFWDP (valcontents
))
1934 case SYMBOL_LOCALIZED
:
1935 /* For a local variable, record both the symbol and which
1936 buffer's or frame's value we are saving. */
1937 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1938 return Fcurrent_buffer ();
1939 else if (SYMBOL_REDIRECT (sym
) == SYMBOL_LOCALIZED
1940 && blv_found (SYMBOL_BLV (sym
)))
1941 return SYMBOL_BLV (sym
)->where
;
1944 default: emacs_abort ();
1948 /* This code is disabled now that we use the selected frame to return
1949 keyboard-local-values. */
1951 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1953 DEFUN ("terminal-local-value", Fterminal_local_value
,
1954 Sterminal_local_value
, 2, 2, 0,
1955 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1956 If SYMBOL is not a terminal-local variable, then return its normal
1957 value, like `symbol-value'.
1959 TERMINAL may be a terminal object, a frame, or nil (meaning the
1960 selected frame's terminal device). */)
1961 (Lisp_Object symbol
, Lisp_Object terminal
)
1964 struct terminal
*t
= get_terminal (terminal
, 1);
1965 push_kboard (t
->kboard
);
1966 result
= Fsymbol_value (symbol
);
1971 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1972 Sset_terminal_local_value
, 3, 3, 0,
1973 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1974 If VARIABLE is not a terminal-local variable, then set its normal
1975 binding, like `set'.
1977 TERMINAL may be a terminal object, a frame, or nil (meaning the
1978 selected frame's terminal device). */)
1979 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1982 struct terminal
*t
= get_terminal (terminal
, 1);
1983 push_kboard (d
->kboard
);
1984 result
= Fset (symbol
, value
);
1990 /* Find the function at the end of a chain of symbol function indirections. */
1992 /* If OBJECT is a symbol, find the end of its function chain and
1993 return the value found there. If OBJECT is not a symbol, just
1994 return it. If there is a cycle in the function chain, signal a
1995 cyclic-function-indirection error.
1997 This is like Findirect_function, except that it doesn't signal an
1998 error if the chain ends up unbound. */
2000 indirect_function (register Lisp_Object object
)
2002 Lisp_Object tortoise
, hare
;
2004 hare
= tortoise
= object
;
2008 if (!SYMBOLP (hare
) || NILP (hare
))
2010 hare
= SYMBOL_FUNCTION (hare
);
2011 if (!SYMBOLP (hare
) || NILP (hare
))
2013 hare
= SYMBOL_FUNCTION (hare
);
2015 tortoise
= SYMBOL_FUNCTION (tortoise
);
2017 if (EQ (hare
, tortoise
))
2018 xsignal1 (Qcyclic_function_indirection
, object
);
2024 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2025 doc
: /* Return the function at the end of OBJECT's function chain.
2026 If OBJECT is not a symbol, just return it. Otherwise, follow all
2027 function indirections to find the final function binding and return it.
2028 If the final symbol in the chain is unbound, signal a void-function error.
2029 Optional arg NOERROR non-nil means to return nil instead of signaling.
2030 Signal a cyclic-function-indirection error if there is a loop in the
2031 function chain of symbols. */)
2032 (register Lisp_Object object
, Lisp_Object noerror
)
2036 /* Optimize for no indirection. */
2038 if (SYMBOLP (result
) && !NILP (result
)
2039 && (result
= SYMBOL_FUNCTION (result
), SYMBOLP (result
)))
2040 result
= indirect_function (result
);
2045 xsignal1 (Qvoid_function
, object
);
2050 /* Extract and set vector and string elements. */
2052 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2053 doc
: /* Return the element of ARRAY at index IDX.
2054 ARRAY may be a vector, a string, a char-table, a bool-vector,
2055 or a byte-code object. IDX starts at 0. */)
2056 (register Lisp_Object array
, Lisp_Object idx
)
2058 register EMACS_INT idxval
;
2061 idxval
= XINT (idx
);
2062 if (STRINGP (array
))
2065 ptrdiff_t idxval_byte
;
2067 if (idxval
< 0 || idxval
>= SCHARS (array
))
2068 args_out_of_range (array
, idx
);
2069 if (! STRING_MULTIBYTE (array
))
2070 return make_number ((unsigned char) SREF (array
, idxval
));
2071 idxval_byte
= string_char_to_byte (array
, idxval
);
2073 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2074 return make_number (c
);
2076 else if (BOOL_VECTOR_P (array
))
2078 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2079 args_out_of_range (array
, idx
);
2080 return bool_vector_ref (array
, idxval
);
2082 else if (CHAR_TABLE_P (array
))
2084 CHECK_CHARACTER (idx
);
2085 return CHAR_TABLE_REF (array
, idxval
);
2090 if (VECTORP (array
))
2091 size
= ASIZE (array
);
2092 else if (COMPILEDP (array
))
2093 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2095 wrong_type_argument (Qarrayp
, array
);
2097 if (idxval
< 0 || idxval
>= size
)
2098 args_out_of_range (array
, idx
);
2099 return AREF (array
, idxval
);
2103 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2104 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2105 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2106 bool-vector. IDX starts at 0. */)
2107 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2109 register EMACS_INT idxval
;
2112 idxval
= XINT (idx
);
2113 CHECK_ARRAY (array
, Qarrayp
);
2114 CHECK_IMPURE (array
);
2116 if (VECTORP (array
))
2118 if (idxval
< 0 || idxval
>= ASIZE (array
))
2119 args_out_of_range (array
, idx
);
2120 ASET (array
, idxval
, newelt
);
2122 else if (BOOL_VECTOR_P (array
))
2124 if (idxval
< 0 || idxval
>= bool_vector_size (array
))
2125 args_out_of_range (array
, idx
);
2126 bool_vector_set (array
, idxval
, !NILP (newelt
));
2128 else if (CHAR_TABLE_P (array
))
2130 CHECK_CHARACTER (idx
);
2131 CHAR_TABLE_SET (array
, idxval
, newelt
);
2137 if (idxval
< 0 || idxval
>= SCHARS (array
))
2138 args_out_of_range (array
, idx
);
2139 CHECK_CHARACTER (newelt
);
2140 c
= XFASTINT (newelt
);
2142 if (STRING_MULTIBYTE (array
))
2144 ptrdiff_t idxval_byte
, nbytes
;
2145 int prev_bytes
, new_bytes
;
2146 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2148 nbytes
= SBYTES (array
);
2149 idxval_byte
= string_char_to_byte (array
, idxval
);
2150 p1
= SDATA (array
) + idxval_byte
;
2151 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2152 new_bytes
= CHAR_STRING (c
, p0
);
2153 if (prev_bytes
!= new_bytes
)
2155 /* We must relocate the string data. */
2156 ptrdiff_t nchars
= SCHARS (array
);
2158 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2160 memcpy (str
, SDATA (array
), nbytes
);
2161 allocate_string_data (array
, nchars
,
2162 nbytes
+ new_bytes
- prev_bytes
);
2163 memcpy (SDATA (array
), str
, idxval_byte
);
2164 p1
= SDATA (array
) + idxval_byte
;
2165 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2166 nbytes
- (idxval_byte
+ prev_bytes
));
2168 clear_string_char_byte_cache ();
2175 if (! SINGLE_BYTE_CHAR_P (c
))
2179 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2180 if (SREF (array
, i
) >= 0x80)
2181 args_out_of_range (array
, newelt
);
2182 /* ARRAY is an ASCII string. Convert it to a multibyte
2183 string, and try `aset' again. */
2184 STRING_SET_MULTIBYTE (array
);
2185 return Faset (array
, idx
, newelt
);
2187 SSET (array
, idxval
, c
);
2194 /* Arithmetic functions */
2197 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum Arith_Comparison comparison
)
2199 double f1
= 0, f2
= 0;
2202 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2203 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2205 if (FLOATP (num1
) || FLOATP (num2
))
2208 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2209 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2215 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2219 case ARITH_NOTEQUAL
:
2220 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2225 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2229 case ARITH_LESS_OR_EQUAL
:
2230 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2235 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2239 case ARITH_GRTR_OR_EQUAL
:
2240 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2250 arithcompare_driver (ptrdiff_t nargs
, Lisp_Object
*args
,
2251 enum Arith_Comparison comparison
)
2254 for (argnum
= 1; argnum
< nargs
; ++argnum
)
2256 if (EQ (Qnil
, arithcompare (args
[argnum
- 1], args
[argnum
], comparison
)))
2262 DEFUN ("=", Feqlsign
, Seqlsign
, 1, MANY
, 0,
2263 doc
: /* Return t if args, all numbers or markers, are equal.
2264 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2265 (ptrdiff_t nargs
, Lisp_Object
*args
)
2267 return arithcompare_driver (nargs
, args
, ARITH_EQUAL
);
2270 DEFUN ("<", Flss
, Slss
, 1, MANY
, 0,
2271 doc
: /* Return t if each arg (a number or marker), is less than the next arg.
2272 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2273 (ptrdiff_t nargs
, Lisp_Object
*args
)
2275 return arithcompare_driver (nargs
, args
, ARITH_LESS
);
2278 DEFUN (">", Fgtr
, Sgtr
, 1, MANY
, 0,
2279 doc
: /* Return t if each arg (a number or marker) is greater than the next arg.
2280 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2281 (ptrdiff_t nargs
, Lisp_Object
*args
)
2283 return arithcompare_driver (nargs
, args
, ARITH_GRTR
);
2286 DEFUN ("<=", Fleq
, Sleq
, 1, MANY
, 0,
2287 doc
: /* Return t if each arg (a number or marker) is less than or equal to the next.
2288 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2289 (ptrdiff_t nargs
, Lisp_Object
*args
)
2291 return arithcompare_driver (nargs
, args
, ARITH_LESS_OR_EQUAL
);
2294 DEFUN (">=", Fgeq
, Sgeq
, 1, MANY
, 0,
2295 doc
: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2296 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2297 (ptrdiff_t nargs
, Lisp_Object
*args
)
2299 return arithcompare_driver (nargs
, args
, ARITH_GRTR_OR_EQUAL
);
2302 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2303 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2304 (register Lisp_Object num1
, Lisp_Object num2
)
2306 return arithcompare (num1
, num2
, ARITH_NOTEQUAL
);
2309 /* Convert the cons-of-integers, integer, or float value C to an
2310 unsigned value with maximum value MAX. Signal an error if C does not
2311 have a valid format or is out of range. */
2313 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2316 uintmax_t val
IF_LINT (= 0);
2319 valid
= 0 <= XINT (c
);
2322 else if (FLOATP (c
))
2324 double d
= XFLOAT_DATA (c
);
2326 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2332 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2334 uintmax_t top
= XFASTINT (XCAR (c
));
2335 Lisp_Object rest
= XCDR (c
);
2336 if (top
<= UINTMAX_MAX
>> 24 >> 16
2338 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2339 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2341 uintmax_t mid
= XFASTINT (XCAR (rest
));
2342 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2345 else if (top
<= UINTMAX_MAX
>> 16)
2349 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2351 val
= top
<< 16 | XFASTINT (rest
);
2357 if (! (valid
&& val
<= max
))
2358 error ("Not an in-range integer, float, or cons of integers");
2362 /* Convert the cons-of-integers, integer, or float value C to a signed
2363 value with extrema MIN and MAX. Signal an error if C does not have
2364 a valid format or is out of range. */
2366 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2369 intmax_t val
IF_LINT (= 0);
2375 else if (FLOATP (c
))
2377 double d
= XFLOAT_DATA (c
);
2379 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2385 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2387 intmax_t top
= XINT (XCAR (c
));
2388 Lisp_Object rest
= XCDR (c
);
2389 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2391 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2392 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2394 intmax_t mid
= XFASTINT (XCAR (rest
));
2395 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2398 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2402 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2404 val
= top
<< 16 | XFASTINT (rest
);
2410 if (! (valid
&& min
<= val
&& val
<= max
))
2411 error ("Not an in-range integer, float, or cons of integers");
2415 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2416 doc
: /* Return the decimal representation of NUMBER as a string.
2417 Uses a minus sign if negative.
2418 NUMBER may be an integer or a floating point number. */)
2419 (Lisp_Object number
)
2421 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2424 CHECK_NUMBER_OR_FLOAT (number
);
2426 if (FLOATP (number
))
2427 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2429 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2431 return make_unibyte_string (buffer
, len
);
2434 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2435 doc
: /* Parse STRING as a decimal number and return the number.
2436 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2437 STRING cannot be parsed as an integer or floating point number.
2439 If BASE, interpret STRING as a number in that base. If BASE isn't
2440 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2441 If the base used is not 10, STRING is always parsed as an integer. */)
2442 (register Lisp_Object string
, Lisp_Object base
)
2448 CHECK_STRING (string
);
2454 CHECK_NUMBER (base
);
2455 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2456 xsignal1 (Qargs_out_of_range
, base
);
2460 p
= SSDATA (string
);
2461 while (*p
== ' ' || *p
== '\t')
2464 val
= string_to_number (p
, b
, 1);
2465 return NILP (val
) ? make_number (0) : val
;
2481 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2482 ptrdiff_t, Lisp_Object
*);
2484 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2487 ptrdiff_t argnum
, ok_args
;
2488 EMACS_INT accum
= 0;
2489 EMACS_INT next
, ok_accum
;
2510 for (argnum
= 0; argnum
< nargs
; argnum
++)
2518 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2520 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2523 return float_arith_driver (ok_accum
, ok_args
, code
,
2526 next
= XINT (args
[argnum
]);
2530 if (INT_ADD_OVERFLOW (accum
, next
))
2538 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2543 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2546 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2548 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2550 accum
= ab
& INTMASK
;
2561 xsignal0 (Qarith_error
);
2575 if (!argnum
|| next
> accum
)
2579 if (!argnum
|| next
< accum
)
2585 XSETINT (val
, accum
);
2590 #define isnan(x) ((x) != (x))
2593 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2594 ptrdiff_t nargs
, Lisp_Object
*args
)
2596 register Lisp_Object val
;
2599 for (; argnum
< nargs
; argnum
++)
2601 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2602 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2606 next
= XFLOAT_DATA (val
);
2610 args
[argnum
] = val
; /* runs into a compiler bug. */
2611 next
= XINT (args
[argnum
]);
2619 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2629 if (! IEEE_FLOATING_POINT
&& next
== 0)
2630 xsignal0 (Qarith_error
);
2637 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2639 if (!argnum
|| isnan (next
) || next
> accum
)
2643 if (!argnum
|| isnan (next
) || next
< accum
)
2649 return make_float (accum
);
2653 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2654 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2655 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2656 (ptrdiff_t nargs
, Lisp_Object
*args
)
2658 return arith_driver (Aadd
, nargs
, args
);
2661 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2662 doc
: /* Negate number or subtract numbers or markers and return the result.
2663 With one arg, negates it. With more than one arg,
2664 subtracts all but the first from the first.
2665 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2666 (ptrdiff_t nargs
, Lisp_Object
*args
)
2668 return arith_driver (Asub
, nargs
, args
);
2671 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2672 doc
: /* Return product of any number of arguments, which are numbers or markers.
2673 usage: (* &rest NUMBERS-OR-MARKERS) */)
2674 (ptrdiff_t nargs
, Lisp_Object
*args
)
2676 return arith_driver (Amult
, nargs
, args
);
2679 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2680 doc
: /* Return first argument divided by all the remaining arguments.
2681 The arguments must be numbers or markers.
2682 usage: (/ DIVIDEND &rest DIVISORS) */)
2683 (ptrdiff_t nargs
, Lisp_Object
*args
)
2686 for (argnum
= 2; argnum
< nargs
; argnum
++)
2687 if (FLOATP (args
[argnum
]))
2688 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2689 return arith_driver (Adiv
, nargs
, args
);
2692 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2693 doc
: /* Return remainder of X divided by Y.
2694 Both must be integers or markers. */)
2695 (register Lisp_Object x
, Lisp_Object y
)
2699 CHECK_NUMBER_COERCE_MARKER (x
);
2700 CHECK_NUMBER_COERCE_MARKER (y
);
2703 xsignal0 (Qarith_error
);
2705 XSETINT (val
, XINT (x
) % XINT (y
));
2709 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2710 doc
: /* Return X modulo Y.
2711 The result falls between zero (inclusive) and Y (exclusive).
2712 Both X and Y must be numbers or markers. */)
2713 (register Lisp_Object x
, Lisp_Object y
)
2718 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2719 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2721 if (FLOATP (x
) || FLOATP (y
))
2722 return fmod_float (x
, y
);
2728 xsignal0 (Qarith_error
);
2732 /* If the "remainder" comes out with the wrong sign, fix it. */
2733 if (i2
< 0 ? i1
> 0 : i1
< 0)
2740 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2741 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2742 The value is always a number; markers are converted to numbers.
2743 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2744 (ptrdiff_t nargs
, Lisp_Object
*args
)
2746 return arith_driver (Amax
, nargs
, args
);
2749 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2750 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2751 The value is always a number; markers are converted to numbers.
2752 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2753 (ptrdiff_t nargs
, Lisp_Object
*args
)
2755 return arith_driver (Amin
, nargs
, args
);
2758 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2759 doc
: /* Return bitwise-and of all the arguments.
2760 Arguments may be integers, or markers converted to integers.
2761 usage: (logand &rest INTS-OR-MARKERS) */)
2762 (ptrdiff_t nargs
, Lisp_Object
*args
)
2764 return arith_driver (Alogand
, nargs
, args
);
2767 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2768 doc
: /* Return bitwise-or of all the arguments.
2769 Arguments may be integers, or markers converted to integers.
2770 usage: (logior &rest INTS-OR-MARKERS) */)
2771 (ptrdiff_t nargs
, Lisp_Object
*args
)
2773 return arith_driver (Alogior
, nargs
, args
);
2776 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2777 doc
: /* Return bitwise-exclusive-or of all the arguments.
2778 Arguments may be integers, or markers converted to integers.
2779 usage: (logxor &rest INTS-OR-MARKERS) */)
2780 (ptrdiff_t nargs
, Lisp_Object
*args
)
2782 return arith_driver (Alogxor
, nargs
, args
);
2785 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2786 doc
: /* Return VALUE with its bits shifted left by COUNT.
2787 If COUNT is negative, shifting is actually to the right.
2788 In this case, the sign bit is duplicated. */)
2789 (register Lisp_Object value
, Lisp_Object count
)
2791 register Lisp_Object val
;
2793 CHECK_NUMBER (value
);
2794 CHECK_NUMBER (count
);
2796 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2798 else if (XINT (count
) > 0)
2799 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2800 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2801 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2803 XSETINT (val
, XINT (value
) >> -XINT (count
));
2807 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2808 doc
: /* Return VALUE with its bits shifted left by COUNT.
2809 If COUNT is negative, shifting is actually to the right.
2810 In this case, zeros are shifted in on the left. */)
2811 (register Lisp_Object value
, Lisp_Object count
)
2813 register Lisp_Object val
;
2815 CHECK_NUMBER (value
);
2816 CHECK_NUMBER (count
);
2818 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2820 else if (XINT (count
) > 0)
2821 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2822 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2825 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2829 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2830 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2831 Markers are converted to integers. */)
2832 (register Lisp_Object number
)
2834 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2836 if (FLOATP (number
))
2837 return (make_float (1.0 + XFLOAT_DATA (number
)));
2839 XSETINT (number
, XINT (number
) + 1);
2843 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2844 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2845 Markers are converted to integers. */)
2846 (register Lisp_Object number
)
2848 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2850 if (FLOATP (number
))
2851 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2853 XSETINT (number
, XINT (number
) - 1);
2857 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2858 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2859 (register Lisp_Object number
)
2861 CHECK_NUMBER (number
);
2862 XSETINT (number
, ~XINT (number
));
2866 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2867 doc
: /* Return the byteorder for the machine.
2868 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2869 lowercase l) for small endian machines. */)
2872 unsigned i
= 0x04030201;
2873 int order
= *(char *)&i
== 1 ? 108 : 66;
2875 return make_number (order
);
2878 /* Because we round up the bool vector allocate size to word_size
2879 units, we can safely read past the "end" of the vector in the
2880 operations below. These extra bits are always zero. */
2883 bool_vector_spare_mask (EMACS_INT nr_bits
)
2885 return (((bits_word
) 1) << (nr_bits
% BITS_PER_BITS_WORD
)) - 1;
2888 /* Info about unsigned long long, falling back on unsigned long
2889 if unsigned long long is not available. */
2891 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2892 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long long) };
2893 # define ULL_MAX ULLONG_MAX
2895 enum { BITS_PER_ULL
= CHAR_BIT
* sizeof (unsigned long) };
2896 # define ULL_MAX ULONG_MAX
2897 # define count_one_bits_ll count_one_bits_l
2898 # define count_trailing_zeros_ll count_trailing_zeros_l
2901 /* Shift VAL right by the width of an unsigned long long.
2902 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
2905 shift_right_ull (bits_word w
)
2907 /* Pacify bogus GCC warning about shift count exceeding type width. */
2908 int shift
= BITS_PER_ULL
- BITS_PER_BITS_WORD
< 0 ? BITS_PER_ULL
: 0;
2912 /* Return the number of 1 bits in W. */
2915 count_one_bits_word (bits_word w
)
2917 if (BITS_WORD_MAX
<= UINT_MAX
)
2918 return count_one_bits (w
);
2919 else if (BITS_WORD_MAX
<= ULONG_MAX
)
2920 return count_one_bits_l (w
);
2923 int i
= 0, count
= 0;
2924 while (count
+= count_one_bits_ll (w
),
2925 (i
+= BITS_PER_ULL
) < BITS_PER_BITS_WORD
)
2926 w
= shift_right_ull (w
);
2931 enum bool_vector_op
{ bool_vector_exclusive_or
,
2933 bool_vector_intersection
,
2934 bool_vector_set_difference
,
2935 bool_vector_subsetp
};
2938 bool_vector_binop_driver (Lisp_Object a
,
2941 enum bool_vector_op op
)
2944 bits_word
*adata
, *bdata
, *destdata
;
2948 CHECK_BOOL_VECTOR (a
);
2949 CHECK_BOOL_VECTOR (b
);
2951 nr_bits
= bool_vector_size (a
);
2952 if (bool_vector_size (b
) != nr_bits
)
2953 wrong_length_argument (a
, b
, dest
);
2955 nr_words
= bool_vector_words (nr_bits
);
2956 adata
= bool_vector_data (a
);
2957 bdata
= bool_vector_data (b
);
2961 dest
= make_uninit_bool_vector (nr_bits
);
2962 destdata
= bool_vector_data (dest
);
2966 CHECK_BOOL_VECTOR (dest
);
2967 destdata
= bool_vector_data (dest
);
2968 if (bool_vector_size (dest
) != nr_bits
)
2969 wrong_length_argument (a
, b
, dest
);
2973 case bool_vector_exclusive_or
:
2974 for (; i
< nr_words
; i
++)
2975 if (destdata
[i
] != (adata
[i
] ^ bdata
[i
]))
2979 case bool_vector_subsetp
:
2980 for (; i
< nr_words
; i
++)
2981 if (adata
[i
] &~ bdata
[i
])
2985 case bool_vector_union
:
2986 for (; i
< nr_words
; i
++)
2987 if (destdata
[i
] != (adata
[i
] | bdata
[i
]))
2991 case bool_vector_intersection
:
2992 for (; i
< nr_words
; i
++)
2993 if (destdata
[i
] != (adata
[i
] & bdata
[i
]))
2997 case bool_vector_set_difference
:
2998 for (; i
< nr_words
; i
++)
2999 if (destdata
[i
] != (adata
[i
] &~ bdata
[i
]))
3010 case bool_vector_exclusive_or
:
3011 for (; i
< nr_words
; i
++)
3012 destdata
[i
] = adata
[i
] ^ bdata
[i
];
3015 case bool_vector_union
:
3016 for (; i
< nr_words
; i
++)
3017 destdata
[i
] = adata
[i
] | bdata
[i
];
3020 case bool_vector_intersection
:
3021 for (; i
< nr_words
; i
++)
3022 destdata
[i
] = adata
[i
] & bdata
[i
];
3025 case bool_vector_set_difference
:
3026 for (; i
< nr_words
; i
++)
3027 destdata
[i
] = adata
[i
] &~ bdata
[i
];
3037 /* PRECONDITION must be true. Return VALUE. This odd construction
3038 works around a bogus GCC diagnostic "shift count >= width of type". */
3041 pre_value (bool precondition
, int value
)
3043 eassume (precondition
);
3044 return precondition
? value
: 0;
3047 /* Compute the number of trailing zero bits in val. If val is zero,
3048 return the number of bits in val. */
3050 count_trailing_zero_bits (bits_word val
)
3052 if (BITS_WORD_MAX
== UINT_MAX
)
3053 return count_trailing_zeros (val
);
3054 if (BITS_WORD_MAX
== ULONG_MAX
)
3055 return count_trailing_zeros_l (val
);
3056 if (BITS_WORD_MAX
== ULL_MAX
)
3057 return count_trailing_zeros_ll (val
);
3059 /* The rest of this code is for the unlikely platform where bits_word differs
3060 in width from unsigned int, unsigned long, and unsigned long long. */
3061 val
|= ~ BITS_WORD_MAX
;
3062 if (BITS_WORD_MAX
<= UINT_MAX
)
3063 return count_trailing_zeros (val
);
3064 if (BITS_WORD_MAX
<= ULONG_MAX
)
3065 return count_trailing_zeros_l (val
);
3070 count
< BITS_PER_BITS_WORD
- BITS_PER_ULL
;
3071 count
+= BITS_PER_ULL
)
3074 return count
+ count_trailing_zeros_ll (val
);
3075 val
= shift_right_ull (val
);
3078 if (BITS_PER_BITS_WORD
% BITS_PER_ULL
!= 0
3079 && BITS_WORD_MAX
== (bits_word
) -1)
3080 val
|= (bits_word
) 1 << pre_value (ULONG_MAX
< BITS_WORD_MAX
,
3081 BITS_PER_BITS_WORD
% BITS_PER_ULL
);
3082 return count
+ count_trailing_zeros_ll (val
);
3087 bits_word_to_host_endian (bits_word val
)
3089 #ifndef WORDS_BIGENDIAN
3092 if (BITS_WORD_MAX
>> 31 == 1)
3093 return bswap_32 (val
);
3094 # if HAVE_UNSIGNED_LONG_LONG
3095 if (BITS_WORD_MAX
>> 31 >> 31 >> 1 == 1)
3096 return bswap_64 (val
);
3101 for (i
= 0; i
< sizeof val
; i
++)
3103 r
= ((r
<< 1 << (CHAR_BIT
- 1))
3104 | (val
& ((1u << 1 << (CHAR_BIT
- 1)) - 1)));
3105 val
= val
>> 1 >> (CHAR_BIT
- 1);
3112 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or
,
3113 Sbool_vector_exclusive_or
, 2, 3, 0,
3114 doc
: /* Return A ^ B, bitwise exclusive or.
3115 If optional third argument C is given, store result into C.
3116 A, B, and C must be bool vectors of the same length.
3117 Return the destination vector if it changed or nil otherwise. */)
3118 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3120 return bool_vector_binop_driver (a
, b
, c
, bool_vector_exclusive_or
);
3123 DEFUN ("bool-vector-union", Fbool_vector_union
,
3124 Sbool_vector_union
, 2, 3, 0,
3125 doc
: /* Return A | B, bitwise or.
3126 If optional third argument C is given, store result into C.
3127 A, B, and C must be bool vectors of the same length.
3128 Return the destination vector if it changed or nil otherwise. */)
3129 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3131 return bool_vector_binop_driver (a
, b
, c
, bool_vector_union
);
3134 DEFUN ("bool-vector-intersection", Fbool_vector_intersection
,
3135 Sbool_vector_intersection
, 2, 3, 0,
3136 doc
: /* Return A & B, bitwise and.
3137 If optional third argument C is given, store result into C.
3138 A, B, and C must be bool vectors of the same length.
3139 Return the destination vector if it changed or nil otherwise. */)
3140 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3142 return bool_vector_binop_driver (a
, b
, c
, bool_vector_intersection
);
3145 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference
,
3146 Sbool_vector_set_difference
, 2, 3, 0,
3147 doc
: /* Return A &~ B, set difference.
3148 If optional third argument C is given, store result into C.
3149 A, B, and C must be bool vectors of the same length.
3150 Return the destination vector if it changed or nil otherwise. */)
3151 (Lisp_Object a
, Lisp_Object b
, Lisp_Object c
)
3153 return bool_vector_binop_driver (a
, b
, c
, bool_vector_set_difference
);
3156 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp
,
3157 Sbool_vector_subsetp
, 2, 2, 0,
3158 doc
: /* Return t if every t value in A is also t in B, nil otherwise.
3159 A and B must be bool vectors of the same length. */)
3160 (Lisp_Object a
, Lisp_Object b
)
3162 return bool_vector_binop_driver (a
, b
, b
, bool_vector_subsetp
);
3165 DEFUN ("bool-vector-not", Fbool_vector_not
,
3166 Sbool_vector_not
, 1, 2, 0,
3167 doc
: /* Compute ~A, set complement.
3168 If optional second argument B is given, store result into B.
3169 A and B must be bool vectors of the same length.
3170 Return the destination vector. */)
3171 (Lisp_Object a
, Lisp_Object b
)
3174 bits_word
*bdata
, *adata
;
3177 CHECK_BOOL_VECTOR (a
);
3178 nr_bits
= bool_vector_size (a
);
3181 b
= make_uninit_bool_vector (nr_bits
);
3184 CHECK_BOOL_VECTOR (b
);
3185 if (bool_vector_size (b
) != nr_bits
)
3186 wrong_length_argument (a
, b
, Qnil
);
3189 bdata
= bool_vector_data (b
);
3190 adata
= bool_vector_data (a
);
3192 for (i
= 0; i
< nr_bits
/ BITS_PER_BITS_WORD
; i
++)
3193 bdata
[i
] = BITS_WORD_MAX
& ~adata
[i
];
3195 if (nr_bits
% BITS_PER_BITS_WORD
)
3197 bits_word mword
= bits_word_to_host_endian (adata
[i
]);
3199 mword
&= bool_vector_spare_mask (nr_bits
);
3200 bdata
[i
] = bits_word_to_host_endian (mword
);
3206 DEFUN ("bool-vector-count-population", Fbool_vector_count_population
,
3207 Sbool_vector_count_population
, 1, 1, 0,
3208 doc
: /* Count how many elements in A are t.
3209 A is a bool vector. To count A's nil elements, subtract the return
3210 value from A's length. */)
3216 ptrdiff_t i
, nwords
;
3218 CHECK_BOOL_VECTOR (a
);
3220 nr_bits
= bool_vector_size (a
);
3221 nwords
= bool_vector_words (nr_bits
);
3223 adata
= bool_vector_data (a
);
3225 for (i
= 0; i
< nwords
; i
++)
3226 count
+= count_one_bits_word (adata
[i
]);
3228 return make_number (count
);
3231 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive
,
3232 Sbool_vector_count_consecutive
, 3, 3, 0,
3233 doc
: /* Count how many consecutive elements in A equal B starting at I.
3234 A is a bool vector, B is t or nil, and I is an index into A. */)
3235 (Lisp_Object a
, Lisp_Object b
, Lisp_Object i
)
3242 bits_word mword
; /* Machine word. */
3243 ptrdiff_t pos
, pos0
;
3246 CHECK_BOOL_VECTOR (a
);
3249 nr_bits
= bool_vector_size (a
);
3250 if (XFASTINT (i
) > nr_bits
) /* Allow one past the end for convenience */
3251 args_out_of_range (a
, i
);
3253 adata
= bool_vector_data (a
);
3254 nr_words
= bool_vector_words (nr_bits
);
3255 pos
= XFASTINT (i
) / BITS_PER_BITS_WORD
;
3256 offset
= XFASTINT (i
) % BITS_PER_BITS_WORD
;
3259 /* By XORing with twiddle, we transform the problem of "count
3260 consecutive equal values" into "count the zero bits". The latter
3261 operation usually has hardware support. */
3262 twiddle
= NILP (b
) ? 0 : BITS_WORD_MAX
;
3264 /* Scan the remainder of the mword at the current offset. */
3265 if (pos
< nr_words
&& offset
!= 0)
3267 mword
= bits_word_to_host_endian (adata
[pos
]);
3271 /* Do not count the pad bits. */
3272 mword
|= (bits_word
) 1 << (BITS_PER_BITS_WORD
- offset
);
3274 count
= count_trailing_zero_bits (mword
);
3276 if (count
+ offset
< BITS_PER_BITS_WORD
)
3277 return make_number (count
);
3280 /* Scan whole words until we either reach the end of the vector or
3281 find an mword that doesn't completely match. twiddle is
3282 endian-independent. */
3284 while (pos
< nr_words
&& adata
[pos
] == twiddle
)
3286 count
+= (pos
- pos0
) * BITS_PER_BITS_WORD
;
3290 /* If we stopped because of a mismatch, see how many bits match
3291 in the current mword. */
3292 mword
= bits_word_to_host_endian (adata
[pos
]);
3294 count
+= count_trailing_zero_bits (mword
);
3296 else if (nr_bits
% BITS_PER_BITS_WORD
!= 0)
3298 /* If we hit the end, we might have overshot our count. Reduce
3299 the total by the number of spare bits at the end of the
3301 count
-= BITS_PER_BITS_WORD
- nr_bits
% BITS_PER_BITS_WORD
;
3304 return make_number (count
);
3308 DEFUN ("bind-symbol", Fbind_symbol
, Sbind_symbol
, 3, 3, 0,
3309 doc
: /* Bind symbol. */)
3310 (Lisp_Object symbol
, Lisp_Object value
, Lisp_Object thunk
)
3314 specbind (symbol
, value
);
3315 val
= call0 (thunk
);
3323 Lisp_Object error_tail
, arith_tail
;
3325 /* Used by defsubr. */
3326 DEFSYM (Qspecial_operator
, "special-operator");
3327 DEFSYM (Qinteractive_form
, "interactive-form");
3331 DEFSYM (Qquote
, "quote");
3332 DEFSYM (Qlambda
, "lambda");
3333 DEFSYM (Qsubr
, "subr");
3334 DEFSYM (Qerror_conditions
, "error-conditions");
3335 DEFSYM (Qerror_message
, "error-message");
3336 DEFSYM (Qtop_level
, "top-level");
3338 DEFSYM (Qerror
, "error");
3339 DEFSYM (Quser_error
, "user-error");
3340 DEFSYM (Qquit
, "quit");
3341 DEFSYM (Qwrong_length_argument
, "wrong-length-argument");
3342 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
3343 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
3344 DEFSYM (Qvoid_function
, "void-function");
3345 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
3346 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
3347 DEFSYM (Qvoid_variable
, "void-variable");
3348 DEFSYM (Qsetting_constant
, "setting-constant");
3349 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
3351 DEFSYM (Qinvalid_function
, "invalid-function");
3352 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
3353 DEFSYM (Qno_catch
, "no-catch");
3354 DEFSYM (Qend_of_file
, "end-of-file");
3355 DEFSYM (Qarith_error
, "arith-error");
3356 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
3357 DEFSYM (Qend_of_buffer
, "end-of-buffer");
3358 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
3359 DEFSYM (Qtext_read_only
, "text-read-only");
3360 DEFSYM (Qmark_inactive
, "mark-inactive");
3362 DEFSYM (Qlistp
, "listp");
3363 DEFSYM (Qconsp
, "consp");
3364 DEFSYM (Qsymbolp
, "symbolp");
3365 DEFSYM (Qkeywordp
, "keywordp");
3366 DEFSYM (Qintegerp
, "integerp");
3367 DEFSYM (Qnatnump
, "natnump");
3368 DEFSYM (Qwholenump
, "wholenump");
3369 DEFSYM (Qstringp
, "stringp");
3370 DEFSYM (Qarrayp
, "arrayp");
3371 DEFSYM (Qsequencep
, "sequencep");
3372 DEFSYM (Qbufferp
, "bufferp");
3373 DEFSYM (Qvectorp
, "vectorp");
3374 DEFSYM (Qbool_vector_p
, "bool-vector-p");
3375 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
3376 DEFSYM (Qmarkerp
, "markerp");
3377 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
3378 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
3379 DEFSYM (Qboundp
, "boundp");
3380 DEFSYM (Qfboundp
, "fboundp");
3382 DEFSYM (Qfloatp
, "floatp");
3383 DEFSYM (Qnumberp
, "numberp");
3384 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
3386 DEFSYM (Qchar_table_p
, "char-table-p");
3387 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
3389 DEFSYM (Qsubrp
, "subrp");
3390 DEFSYM (Qunevalled
, "unevalled");
3391 DEFSYM (Qmany
, "many");
3393 DEFSYM (Qcdr
, "cdr");
3395 /* Handle automatic advice activation. */
3396 DEFSYM (Qad_advice_info
, "ad-advice-info");
3397 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3399 error_tail
= pure_cons (Qerror
, Qnil
);
3401 /* ERROR is used as a signaler for random errors for which nothing else is
3404 Fput (Qerror
, Qerror_conditions
,
3406 Fput (Qerror
, Qerror_message
,
3407 build_pure_c_string ("error"));
3409 #define PUT_ERROR(sym, tail, msg) \
3410 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3411 Fput (sym, Qerror_message, build_pure_c_string (msg))
3413 PUT_ERROR (Qquit
, Qnil
, "Quit");
3415 PUT_ERROR (Quser_error
, error_tail
, "");
3416 PUT_ERROR (Qwrong_length_argument
, error_tail
, "Wrong length argument");
3417 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3418 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3419 PUT_ERROR (Qvoid_function
, error_tail
,
3420 "Symbol's function definition is void");
3421 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3422 "Symbol's chain of function indirections contains a loop");
3423 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3424 "Symbol's chain of variable indirections contains a loop");
3425 DEFSYM (Qcircular_list
, "circular-list");
3426 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3427 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3428 PUT_ERROR (Qsetting_constant
, error_tail
,
3429 "Attempt to set a constant symbol");
3430 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3431 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3432 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3433 "Wrong number of arguments");
3434 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3435 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3437 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3438 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3439 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3441 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3442 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3443 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3444 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3445 "Text is read-only");
3447 DEFSYM (Qrange_error
, "range-error");
3448 DEFSYM (Qdomain_error
, "domain-error");
3449 DEFSYM (Qsingularity_error
, "singularity-error");
3450 DEFSYM (Qoverflow_error
, "overflow-error");
3451 DEFSYM (Qunderflow_error
, "underflow-error");
3453 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3455 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3457 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3458 "Arithmetic singularity error");
3460 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3461 "Arithmetic overflow error");
3462 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3463 "Arithmetic underflow error");
3467 staticpro (&Qunbound
);
3469 /* Types that type-of returns. */
3470 DEFSYM (Qinteger
, "integer");
3471 DEFSYM (Qsymbol
, "symbol");
3472 DEFSYM (Qstring
, "string");
3473 DEFSYM (Qcons
, "cons");
3474 DEFSYM (Qmarker
, "marker");
3475 DEFSYM (Qoverlay
, "overlay");
3476 DEFSYM (Qfloat
, "float");
3477 DEFSYM (Qwindow_configuration
, "window-configuration");
3478 DEFSYM (Qprocess
, "process");
3479 DEFSYM (Qwindow
, "window");
3480 DEFSYM (Qcompiled_function
, "compiled-function");
3481 DEFSYM (Qbuffer
, "buffer");
3482 DEFSYM (Qframe
, "frame");
3483 DEFSYM (Qvector
, "vector");
3484 DEFSYM (Qchar_table
, "char-table");
3485 DEFSYM (Qbool_vector
, "bool-vector");
3486 DEFSYM (Qhash_table
, "hash-table");
3487 DEFSYM (Qmisc
, "misc");
3489 DEFSYM (Qdefun
, "defun");
3491 DEFSYM (Qfont_spec
, "font-spec");
3492 DEFSYM (Qfont_entity
, "font-entity");
3493 DEFSYM (Qfont_object
, "font-object");
3495 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3497 set_symbol_function (Qwholenump
, SYMBOL_FUNCTION (Qnatnump
));
3499 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3500 doc
: /* The largest value that is representable in a Lisp integer. */);
3501 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3502 SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-positive-fixnum")), 1);
3504 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3505 doc
: /* The smallest value that is representable in a Lisp integer. */);
3506 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3507 SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-negative-fixnum")), 1);