1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
3 Free Software Foundation, Inc.
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/>. */
29 #include "character.h"
33 #include "syssignal.h"
34 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
40 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
41 #define IEEE_FLOATING_POINT 1
43 #define IEEE_FLOATING_POINT 0
46 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
47 static Lisp_Object Qsubr
;
48 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
49 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
50 static Lisp_Object Qwrong_type_argument
;
51 Lisp_Object Qvoid_variable
, Qvoid_function
;
52 static Lisp_Object Qcyclic_function_indirection
;
53 static Lisp_Object Qcyclic_variable_indirection
;
54 Lisp_Object Qcircular_list
;
55 static Lisp_Object Qsetting_constant
;
56 Lisp_Object Qinvalid_read_syntax
;
57 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
58 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
59 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
60 Lisp_Object Qtext_read_only
;
62 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
63 static Lisp_Object Qnatnump
;
64 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
65 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
66 Lisp_Object Qbuffer_or_string_p
;
67 static Lisp_Object Qkeywordp
, Qboundp
;
69 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
72 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
74 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
75 Lisp_Object Qrange_error
, Qoverflow_error
;
78 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
80 Lisp_Object Qinteger
, Qsymbol
;
81 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
83 static Lisp_Object Qoverlay
, Qwindow_configuration
;
84 static Lisp_Object Qprocess
, Qmarker
;
85 static Lisp_Object Qcompiled_function
, Qframe
;
87 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
88 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
89 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
90 static Lisp_Object Qdefun
;
92 Lisp_Object Qinteractive_form
;
94 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
98 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
100 /* If VALUE is not even a valid Lisp object, we'd want to abort here
101 where we can get a backtrace showing where it came from. We used
102 to try and do that by checking the tagbits, but nowadays all
103 tagbits are potentially valid. */
104 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
107 xsignal2 (Qwrong_type_argument
, predicate
, value
);
111 pure_write_error (void)
113 error ("Attempt to modify read-only object");
117 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
119 xsignal2 (Qargs_out_of_range
, a1
, a2
);
123 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
125 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
129 /* Data type predicates. */
131 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
132 doc
: /* Return t if the two args are the same Lisp object. */)
133 (Lisp_Object obj1
, Lisp_Object obj2
)
140 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
141 doc
: /* Return t if OBJECT is nil. */)
149 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
150 doc
: /* Return a symbol representing the type of OBJECT.
151 The symbol returned names the object's basic type;
152 for example, (type-of 1) returns `integer'. */)
155 switch (XTYPE (object
))
170 switch (XMISCTYPE (object
))
172 case Lisp_Misc_Marker
:
174 case Lisp_Misc_Overlay
:
176 case Lisp_Misc_Float
:
181 case Lisp_Vectorlike
:
182 if (WINDOW_CONFIGURATIONP (object
))
183 return Qwindow_configuration
;
184 if (PROCESSP (object
))
186 if (WINDOWP (object
))
190 if (COMPILEDP (object
))
191 return Qcompiled_function
;
192 if (BUFFERP (object
))
194 if (CHAR_TABLE_P (object
))
196 if (BOOL_VECTOR_P (object
))
200 if (HASH_TABLE_P (object
))
202 if (FONT_SPEC_P (object
))
204 if (FONT_ENTITY_P (object
))
206 if (FONT_OBJECT_P (object
))
218 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
219 doc
: /* Return t if OBJECT is a cons cell. */)
227 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
228 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
236 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
237 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
238 Otherwise, return nil. */)
241 if (CONSP (object
) || NILP (object
))
246 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
247 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
250 if (CONSP (object
) || NILP (object
))
255 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
256 doc
: /* Return t if OBJECT is a symbol. */)
259 if (SYMBOLP (object
))
264 /* Define this in C to avoid unnecessarily consing up the symbol
266 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
267 doc
: /* Return t if OBJECT is a keyword.
268 This means that it is a symbol with a print name beginning with `:'
269 interned in the initial obarray. */)
273 && SREF (SYMBOL_NAME (object
), 0) == ':'
274 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
279 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is a vector. */)
283 if (VECTORP (object
))
288 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
289 doc
: /* Return t if OBJECT is a string. */)
292 if (STRINGP (object
))
297 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
299 doc
: /* Return t if OBJECT is a multibyte string. */)
302 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
307 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
308 doc
: /* Return t if OBJECT is a char-table. */)
311 if (CHAR_TABLE_P (object
))
316 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
317 Svector_or_char_table_p
, 1, 1, 0,
318 doc
: /* Return t if OBJECT is a char-table or vector. */)
321 if (VECTORP (object
) || CHAR_TABLE_P (object
))
326 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
327 doc
: /* Return t if OBJECT is a bool-vector. */)
330 if (BOOL_VECTOR_P (object
))
335 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
336 doc
: /* Return t if OBJECT is an array (string or vector). */)
344 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
345 doc
: /* Return t if OBJECT is a sequence (list or array). */)
346 (register Lisp_Object object
)
348 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
353 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
354 doc
: /* Return t if OBJECT is an editor buffer. */)
357 if (BUFFERP (object
))
362 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
366 if (MARKERP (object
))
371 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
372 doc
: /* Return t if OBJECT is a built-in function. */)
380 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
382 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
385 if (COMPILEDP (object
))
390 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
391 doc
: /* Return t if OBJECT is a character or a string. */)
392 (register Lisp_Object object
)
394 if (CHARACTERP (object
) || STRINGP (object
))
399 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
400 doc
: /* Return t if OBJECT is an integer. */)
403 if (INTEGERP (object
))
408 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
409 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
410 (register Lisp_Object object
)
412 if (MARKERP (object
) || INTEGERP (object
))
417 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a nonnegative integer. */)
421 if (NATNUMP (object
))
426 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
427 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
430 if (NUMBERP (object
))
436 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
437 Snumber_or_marker_p
, 1, 1, 0,
438 doc
: /* Return t if OBJECT is a number or a marker. */)
441 if (NUMBERP (object
) || MARKERP (object
))
446 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
447 doc
: /* Return t if OBJECT is a floating point number. */)
456 /* Extract and set components of lists */
458 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
459 doc
: /* Return the car of LIST. If arg is nil, return nil.
460 Error if arg is not nil and not a cons cell. See also `car-safe'.
462 See Info node `(elisp)Cons Cells' for a discussion of related basic
463 Lisp concepts such as car, cdr, cons cell and list. */)
464 (register Lisp_Object list
)
469 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
470 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
473 return CAR_SAFE (object
);
476 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
477 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
478 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
480 See Info node `(elisp)Cons Cells' for a discussion of related basic
481 Lisp concepts such as cdr, car, cons cell and list. */)
482 (register Lisp_Object list
)
487 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
488 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
491 return CDR_SAFE (object
);
494 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
495 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
496 (register Lisp_Object cell
, Lisp_Object newcar
)
500 XSETCAR (cell
, newcar
);
504 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
505 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
506 (register Lisp_Object cell
, Lisp_Object newcdr
)
510 XSETCDR (cell
, newcdr
);
514 /* Extract and set components of symbols. */
516 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
517 doc
: /* Return t if SYMBOL's value is not void. */)
518 (register Lisp_Object symbol
)
520 Lisp_Object valcontents
;
521 struct Lisp_Symbol
*sym
;
522 CHECK_SYMBOL (symbol
);
523 sym
= XSYMBOL (symbol
);
526 switch (sym
->redirect
)
528 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
529 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
530 case SYMBOL_LOCALIZED
:
532 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
534 /* In set_internal, we un-forward vars when their value is
539 swap_in_symval_forwarding (sym
, blv
);
540 valcontents
= blv_value (blv
);
544 case SYMBOL_FORWARDED
:
545 /* In set_internal, we un-forward vars when their value is
548 default: emacs_abort ();
551 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
554 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
555 doc
: /* Return t if SYMBOL's function definition is not void. */)
556 (register Lisp_Object symbol
)
558 CHECK_SYMBOL (symbol
);
559 return EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
;
562 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
563 doc
: /* Make SYMBOL's value be void.
565 (register Lisp_Object symbol
)
567 CHECK_SYMBOL (symbol
);
568 if (SYMBOL_CONSTANT_P (symbol
))
569 xsignal1 (Qsetting_constant
, symbol
);
570 Fset (symbol
, Qunbound
);
574 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
575 doc
: /* Make SYMBOL's function definition be void.
577 (register Lisp_Object symbol
)
579 CHECK_SYMBOL (symbol
);
580 if (NILP (symbol
) || EQ (symbol
, Qt
))
581 xsignal1 (Qsetting_constant
, symbol
);
582 set_symbol_function (symbol
, Qunbound
);
586 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
587 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
588 (register Lisp_Object symbol
)
590 CHECK_SYMBOL (symbol
);
591 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
592 return XSYMBOL (symbol
)->function
;
593 xsignal1 (Qvoid_function
, symbol
);
596 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
597 doc
: /* Return SYMBOL's property list. */)
598 (register Lisp_Object symbol
)
600 CHECK_SYMBOL (symbol
);
601 return XSYMBOL (symbol
)->plist
;
604 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
605 doc
: /* Return SYMBOL's name, a string. */)
606 (register Lisp_Object symbol
)
608 register Lisp_Object name
;
610 CHECK_SYMBOL (symbol
);
611 name
= SYMBOL_NAME (symbol
);
615 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
616 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
617 (register Lisp_Object symbol
, Lisp_Object definition
)
619 register Lisp_Object function
;
621 CHECK_SYMBOL (symbol
);
622 if (NILP (symbol
) || EQ (symbol
, Qt
))
623 xsignal1 (Qsetting_constant
, symbol
);
625 function
= XSYMBOL (symbol
)->function
;
627 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
628 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
630 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
631 Fput (symbol
, Qautoload
, XCDR (function
));
633 set_symbol_function (symbol
, definition
);
634 /* Handle automatic advice activation. */
635 if (CONSP (XSYMBOL (symbol
)->plist
)
636 && !NILP (Fget (symbol
, Qad_advice_info
)))
638 call2 (Qad_activate_internal
, symbol
, Qnil
);
639 definition
= XSYMBOL (symbol
)->function
;
644 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
645 doc
: /* Set SYMBOL's function definition to DEFINITION.
646 Associates the function with the current load file, if any.
647 The optional third argument DOCSTRING specifies the documentation string
648 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
649 determined by DEFINITION.
650 The return value is undefined. */)
651 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
653 CHECK_SYMBOL (symbol
);
654 if (CONSP (XSYMBOL (symbol
)->function
)
655 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
656 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
657 if (!NILP (Vpurify_flag
)
658 /* If `definition' is a keymap, immutable (and copying) is wrong. */
659 && !KEYMAPP (definition
))
660 definition
= Fpurecopy (definition
);
661 definition
= Ffset (symbol
, definition
);
662 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
663 if (!NILP (docstring
))
664 Fput (symbol
, Qfunction_documentation
, docstring
);
665 /* We used to return `definition', but now that `defun' and `defmacro' expand
666 to a call to `defalias', we return `symbol' for backward compatibility
671 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
672 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
673 (register Lisp_Object symbol
, Lisp_Object newplist
)
675 CHECK_SYMBOL (symbol
);
676 set_symbol_plist (symbol
, newplist
);
680 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
681 doc
: /* Return minimum and maximum number of args allowed for SUBR.
682 SUBR must be a built-in function.
683 The returned value is a pair (MIN . MAX). MIN is the minimum number
684 of args. MAX is the maximum number or the symbol `many', for a
685 function with `&rest' args, or `unevalled' for a special form. */)
688 short minargs
, maxargs
;
690 minargs
= XSUBR (subr
)->min_args
;
691 maxargs
= XSUBR (subr
)->max_args
;
693 return Fcons (make_number (minargs
), Qmany
);
694 else if (maxargs
== UNEVALLED
)
695 return Fcons (make_number (minargs
), Qunevalled
);
697 return Fcons (make_number (minargs
), make_number (maxargs
));
700 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
701 doc
: /* Return name of subroutine SUBR.
702 SUBR must be a built-in function. */)
707 name
= XSUBR (subr
)->symbol_name
;
708 return build_string (name
);
711 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
712 doc
: /* Return the interactive form of CMD or nil if none.
713 If CMD is not a command, the return value is nil.
714 Value, if non-nil, is a list \(interactive SPEC). */)
717 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
719 if (NILP (fun
) || EQ (fun
, Qunbound
))
722 /* Use an `interactive-form' property if present, analogous to the
723 function-documentation property. */
725 while (SYMBOLP (fun
))
727 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
731 fun
= Fsymbol_function (fun
);
736 const char *spec
= XSUBR (fun
)->intspec
;
738 return list2 (Qinteractive
,
739 (*spec
!= '(') ? build_string (spec
) :
740 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
742 else if (COMPILEDP (fun
))
744 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
745 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
747 else if (CONSP (fun
))
749 Lisp_Object funcar
= XCAR (fun
);
750 if (EQ (funcar
, Qclosure
))
751 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
752 else if (EQ (funcar
, Qlambda
))
753 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
754 else if (EQ (funcar
, Qautoload
))
758 Fautoload_do_load (fun
, cmd
, Qnil
);
760 return Finteractive_form (cmd
);
767 /***********************************************************************
768 Getting and Setting Values of Symbols
769 ***********************************************************************/
771 /* Return the symbol holding SYMBOL's value. Signal
772 `cyclic-variable-indirection' if SYMBOL's chain of variable
773 indirections contains a loop. */
776 indirect_variable (struct Lisp_Symbol
*symbol
)
778 struct Lisp_Symbol
*tortoise
, *hare
;
780 hare
= tortoise
= symbol
;
782 while (hare
->redirect
== SYMBOL_VARALIAS
)
784 hare
= SYMBOL_ALIAS (hare
);
785 if (hare
->redirect
!= SYMBOL_VARALIAS
)
788 hare
= SYMBOL_ALIAS (hare
);
789 tortoise
= SYMBOL_ALIAS (tortoise
);
791 if (hare
== tortoise
)
794 XSETSYMBOL (tem
, symbol
);
795 xsignal1 (Qcyclic_variable_indirection
, tem
);
803 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
804 doc
: /* Return the variable at the end of OBJECT's variable chain.
805 If OBJECT is a symbol, follow its variable indirections (if any), and
806 return the variable at the end of the chain of aliases. See Info node
807 `(elisp)Variable Aliases'.
809 If OBJECT is not a symbol, just return it. If there is a loop in the
810 chain of aliases, signal a `cyclic-variable-indirection' error. */)
813 if (SYMBOLP (object
))
815 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
816 XSETSYMBOL (object
, sym
);
822 /* Given the raw contents of a symbol value cell,
823 return the Lisp value of the symbol.
824 This does not handle buffer-local variables; use
825 swap_in_symval_forwarding for that. */
828 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
830 register Lisp_Object val
;
831 switch (XFWDTYPE (valcontents
))
834 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
838 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
841 return *XOBJFWD (valcontents
)->objvar
;
843 case Lisp_Fwd_Buffer_Obj
:
844 return per_buffer_value (current_buffer
,
845 XBUFFER_OBJFWD (valcontents
)->offset
);
847 case Lisp_Fwd_Kboard_Obj
:
848 /* We used to simply use current_kboard here, but from Lisp
849 code, its value is often unexpected. It seems nicer to
850 allow constructions like this to work as intuitively expected:
852 (with-selected-frame frame
853 (define-key local-function-map "\eOP" [f1]))
855 On the other hand, this affects the semantics of
856 last-command and real-last-command, and people may rely on
857 that. I took a quick look at the Lisp codebase, and I
858 don't think anything will break. --lorentey */
859 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
860 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
861 default: emacs_abort ();
865 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
866 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
867 buffer-independent contents of the value cell: forwarded just one
868 step past the buffer-localness.
870 BUF non-zero means set the value in buffer BUF instead of the
871 current buffer. This only plays a role for per-buffer variables. */
874 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
876 switch (XFWDTYPE (valcontents
))
879 CHECK_NUMBER (newval
);
880 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
884 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
888 *XOBJFWD (valcontents
)->objvar
= newval
;
890 /* If this variable is a default for something stored
891 in the buffer itself, such as default-fill-column,
892 find the buffers that don't have local values for it
894 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
895 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
897 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
898 - (char *) &buffer_defaults
);
899 int idx
= PER_BUFFER_IDX (offset
);
906 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
911 lbuf
= Fcdr (XCAR (tail
));
912 if (!BUFFERP (lbuf
)) continue;
915 if (! PER_BUFFER_VALUE_P (b
, idx
))
916 set_per_buffer_value (b
, offset
, newval
);
921 case Lisp_Fwd_Buffer_Obj
:
923 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
924 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
926 if (!(NILP (type
) || NILP (newval
)
927 || (XINT (type
) == Lisp_Int0
929 : XTYPE (newval
) == XINT (type
))))
930 buffer_slot_type_mismatch (newval
, XINT (type
));
933 buf
= current_buffer
;
934 set_per_buffer_value (buf
, offset
, newval
);
938 case Lisp_Fwd_Kboard_Obj
:
940 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
941 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
942 *(Lisp_Object
*) p
= newval
;
947 emacs_abort (); /* goto def; */
951 /* Set up SYMBOL to refer to its global binding. This makes it safe
952 to alter the status of other bindings. BEWARE: this may be called
953 during the mark phase of GC, where we assume that Lisp_Object slots
954 of BLV are marked after this function has changed them. */
957 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
959 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
961 /* Unload the previously loaded binding. */
963 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
965 /* Select the global binding in the symbol. */
966 set_blv_valcell (blv
, blv
->defcell
);
968 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
970 /* Indicate that the global binding is set up now. */
971 set_blv_where (blv
, Qnil
);
972 set_blv_found (blv
, 0);
975 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
976 VALCONTENTS is the contents of its value cell,
977 which points to a struct Lisp_Buffer_Local_Value.
979 Return the value forwarded one step past the buffer-local stage.
980 This could be another forwarding pointer. */
983 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
985 register Lisp_Object tem1
;
987 eassert (blv
== SYMBOL_BLV (symbol
));
993 ? !EQ (selected_frame
, tem1
)
994 : current_buffer
!= XBUFFER (tem1
)))
997 /* Unload the previously loaded binding. */
1000 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1001 /* Choose the new binding. */
1004 XSETSYMBOL (var
, symbol
);
1005 if (blv
->frame_local
)
1007 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1008 set_blv_where (blv
, selected_frame
);
1012 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1013 set_blv_where (blv
, Fcurrent_buffer ());
1016 if (!(blv
->found
= !NILP (tem1
)))
1017 tem1
= blv
->defcell
;
1019 /* Load the new binding. */
1020 set_blv_valcell (blv
, tem1
);
1022 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1026 /* Find the value of a symbol, returning Qunbound if it's not bound.
1027 This is helpful for code which just wants to get a variable's value
1028 if it has one, without signaling an error.
1029 Note that it must not be possible to quit
1030 within this function. Great care is required for this. */
1033 find_symbol_value (Lisp_Object symbol
)
1035 struct Lisp_Symbol
*sym
;
1037 CHECK_SYMBOL (symbol
);
1038 sym
= XSYMBOL (symbol
);
1041 switch (sym
->redirect
)
1043 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1044 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1045 case SYMBOL_LOCALIZED
:
1047 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1048 swap_in_symval_forwarding (sym
, blv
);
1049 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1052 case SYMBOL_FORWARDED
:
1053 return do_symval_forwarding (SYMBOL_FWD (sym
));
1054 default: emacs_abort ();
1058 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1059 doc
: /* Return SYMBOL's value. Error if that is void. */)
1060 (Lisp_Object symbol
)
1064 val
= find_symbol_value (symbol
);
1065 if (!EQ (val
, Qunbound
))
1068 xsignal1 (Qvoid_variable
, symbol
);
1071 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1072 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1073 (register Lisp_Object symbol
, Lisp_Object newval
)
1075 set_internal (symbol
, newval
, Qnil
, 0);
1079 /* Return true if SYMBOL currently has a let-binding
1080 which was made in the buffer that is now current. */
1083 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1085 struct specbinding
*p
;
1087 for (p
= specpdl_ptr
; p
> specpdl
; )
1088 if ((--p
)->func
== NULL
1089 && CONSP (p
->symbol
))
1091 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1092 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1093 if (symbol
== let_bound_symbol
1094 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1102 let_shadows_global_binding_p (Lisp_Object symbol
)
1104 struct specbinding
*p
;
1106 for (p
= specpdl_ptr
; p
> specpdl
; )
1107 if ((--p
)->func
== NULL
&& EQ (p
->symbol
, symbol
))
1113 /* Store the value NEWVAL into SYMBOL.
1114 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1115 (nil stands for the current buffer/frame).
1117 If BINDFLAG is false, then if this symbol is supposed to become
1118 local in every buffer where it is set, then we make it local.
1119 If BINDFLAG is true, we don't do that. */
1122 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1125 bool voide
= EQ (newval
, Qunbound
);
1126 struct Lisp_Symbol
*sym
;
1129 /* If restoring in a dead buffer, do nothing. */
1130 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1133 CHECK_SYMBOL (symbol
);
1134 if (SYMBOL_CONSTANT_P (symbol
))
1136 if (NILP (Fkeywordp (symbol
))
1137 || !EQ (newval
, Fsymbol_value (symbol
)))
1138 xsignal1 (Qsetting_constant
, symbol
);
1140 /* Allow setting keywords to their own value. */
1144 sym
= XSYMBOL (symbol
);
1147 switch (sym
->redirect
)
1149 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1150 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1151 case SYMBOL_LOCALIZED
:
1153 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1156 if (blv
->frame_local
)
1157 where
= selected_frame
;
1159 XSETBUFFER (where
, current_buffer
);
1161 /* If the current buffer is not the buffer whose binding is
1162 loaded, or if there may be frame-local bindings and the frame
1163 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1164 the default binding is loaded, the loaded binding may be the
1166 if (!EQ (blv
->where
, where
)
1167 /* Also unload a global binding (if the var is local_if_set). */
1168 || (EQ (blv
->valcell
, blv
->defcell
)))
1170 /* The currently loaded binding is not necessarily valid.
1171 We need to unload it, and choose a new binding. */
1173 /* Write out `realvalue' to the old loaded binding. */
1175 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1177 /* Find the new binding. */
1178 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1179 tem1
= Fassq (symbol
,
1181 ? XFRAME (where
)->param_alist
1182 : BVAR (XBUFFER (where
), local_var_alist
)));
1183 set_blv_where (blv
, where
);
1188 /* This buffer still sees the default value. */
1190 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1191 or if this is `let' rather than `set',
1192 make CURRENT-ALIST-ELEMENT point to itself,
1193 indicating that we're seeing the default value.
1194 Likewise if the variable has been let-bound
1195 in the current buffer. */
1196 if (bindflag
|| !blv
->local_if_set
1197 || let_shadows_buffer_binding_p (sym
))
1200 tem1
= blv
->defcell
;
1202 /* If it's a local_if_set, being set not bound,
1203 and we're not within a let that was made for this buffer,
1204 create a new buffer-local binding for the variable.
1205 That means, give this buffer a new assoc for a local value
1206 and load that binding. */
1209 /* local_if_set is only supported for buffer-local
1210 bindings, not for frame-local bindings. */
1211 eassert (!blv
->frame_local
);
1212 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1213 bset_local_var_alist
1215 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1219 /* Record which binding is now loaded. */
1220 set_blv_valcell (blv
, tem1
);
1223 /* Store the new value in the cons cell. */
1224 set_blv_value (blv
, newval
);
1229 /* If storing void (making the symbol void), forward only through
1230 buffer-local indicator, not through Lisp_Objfwd, etc. */
1233 store_symval_forwarding (blv
->fwd
, newval
,
1235 ? XBUFFER (where
) : current_buffer
);
1239 case SYMBOL_FORWARDED
:
1242 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1243 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1244 if (BUFFER_OBJFWDP (innercontents
))
1246 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1247 int idx
= PER_BUFFER_IDX (offset
);
1250 && !let_shadows_buffer_binding_p (sym
))
1251 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1255 { /* If storing void (making the symbol void), forward only through
1256 buffer-local indicator, not through Lisp_Objfwd, etc. */
1257 sym
->redirect
= SYMBOL_PLAINVAL
;
1258 SET_SYMBOL_VAL (sym
, newval
);
1261 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1264 default: emacs_abort ();
1269 /* Access or set a buffer-local symbol's default value. */
1271 /* Return the default value of SYMBOL, but don't check for voidness.
1272 Return Qunbound if it is void. */
1275 default_value (Lisp_Object symbol
)
1277 struct Lisp_Symbol
*sym
;
1279 CHECK_SYMBOL (symbol
);
1280 sym
= XSYMBOL (symbol
);
1283 switch (sym
->redirect
)
1285 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1286 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1287 case SYMBOL_LOCALIZED
:
1289 /* If var is set up for a buffer that lacks a local value for it,
1290 the current value is nominally the default value.
1291 But the `realvalue' slot may be more up to date, since
1292 ordinary setq stores just that slot. So use that. */
1293 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1294 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1295 return do_symval_forwarding (blv
->fwd
);
1297 return XCDR (blv
->defcell
);
1299 case SYMBOL_FORWARDED
:
1301 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1303 /* For a built-in buffer-local variable, get the default value
1304 rather than letting do_symval_forwarding get the current value. */
1305 if (BUFFER_OBJFWDP (valcontents
))
1307 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1308 if (PER_BUFFER_IDX (offset
) != 0)
1309 return per_buffer_default (offset
);
1312 /* For other variables, get the current value. */
1313 return do_symval_forwarding (valcontents
);
1315 default: emacs_abort ();
1319 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1320 doc
: /* Return t if SYMBOL has a non-void default value.
1321 This is the value that is seen in buffers that do not have their own values
1322 for this variable. */)
1323 (Lisp_Object symbol
)
1325 register Lisp_Object value
;
1327 value
= default_value (symbol
);
1328 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1331 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1332 doc
: /* Return SYMBOL's default value.
1333 This is the value that is seen in buffers that do not have their own values
1334 for this variable. The default value is meaningful for variables with
1335 local bindings in certain buffers. */)
1336 (Lisp_Object symbol
)
1338 register Lisp_Object value
;
1340 value
= default_value (symbol
);
1341 if (!EQ (value
, Qunbound
))
1344 xsignal1 (Qvoid_variable
, symbol
);
1347 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1348 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1349 The default value is seen in buffers that do not have their own values
1350 for this variable. */)
1351 (Lisp_Object symbol
, Lisp_Object value
)
1353 struct Lisp_Symbol
*sym
;
1355 CHECK_SYMBOL (symbol
);
1356 if (SYMBOL_CONSTANT_P (symbol
))
1358 if (NILP (Fkeywordp (symbol
))
1359 || !EQ (value
, Fdefault_value (symbol
)))
1360 xsignal1 (Qsetting_constant
, symbol
);
1362 /* Allow setting keywords to their own value. */
1365 sym
= XSYMBOL (symbol
);
1368 switch (sym
->redirect
)
1370 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1371 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1372 case SYMBOL_LOCALIZED
:
1374 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1376 /* Store new value into the DEFAULT-VALUE slot. */
1377 XSETCDR (blv
->defcell
, value
);
1379 /* If the default binding is now loaded, set the REALVALUE slot too. */
1380 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1381 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1384 case SYMBOL_FORWARDED
:
1386 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1388 /* Handle variables like case-fold-search that have special slots
1390 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1391 if (BUFFER_OBJFWDP (valcontents
))
1393 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1394 int idx
= PER_BUFFER_IDX (offset
);
1396 set_per_buffer_default (offset
, value
);
1398 /* If this variable is not always local in all buffers,
1399 set it in the buffers that don't nominally have a local value. */
1405 if (!PER_BUFFER_VALUE_P (b
, idx
))
1406 set_per_buffer_value (b
, offset
, value
);
1411 return Fset (symbol
, value
);
1413 default: emacs_abort ();
1417 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1418 doc
: /* Set the default value of variable VAR to VALUE.
1419 VAR, the variable name, is literal (not evaluated);
1420 VALUE is an expression: it is evaluated and its value returned.
1421 The default value of a variable is seen in buffers
1422 that do not have their own values for the variable.
1424 More generally, you can use multiple variables and values, as in
1425 (setq-default VAR VALUE VAR VALUE...)
1426 This sets each VAR's default value to the corresponding VALUE.
1427 The VALUE for the Nth VAR can refer to the new default values
1429 usage: (setq-default [VAR VALUE]...) */)
1432 register Lisp_Object args_left
;
1433 register Lisp_Object val
, symbol
;
1434 struct gcpro gcpro1
;
1444 val
= eval_sub (Fcar (Fcdr (args_left
)));
1445 symbol
= XCAR (args_left
);
1446 Fset_default (symbol
, val
);
1447 args_left
= Fcdr (XCDR (args_left
));
1449 while (!NILP (args_left
));
1455 /* Lisp functions for creating and removing buffer-local variables. */
1460 union Lisp_Fwd
*fwd
;
1463 static struct Lisp_Buffer_Local_Value
*
1464 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1465 union Lisp_Val_Fwd valcontents
)
1467 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1471 XSETSYMBOL (symbol
, sym
);
1472 tem
= Fcons (symbol
, (forwarded
1473 ? do_symval_forwarding (valcontents
.fwd
)
1474 : valcontents
.value
));
1476 /* Buffer_Local_Values cannot have as realval a buffer-local
1477 or keyboard-local forwarding. */
1478 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1479 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1480 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1481 set_blv_where (blv
, Qnil
);
1482 blv
->frame_local
= 0;
1483 blv
->local_if_set
= 0;
1484 set_blv_defcell (blv
, tem
);
1485 set_blv_valcell (blv
, tem
);
1486 set_blv_found (blv
, 0);
1490 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1491 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1492 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1493 At any time, the value for the current buffer is in effect,
1494 unless the variable has never been set in this buffer,
1495 in which case the default value is in effect.
1496 Note that binding the variable with `let', or setting it while
1497 a `let'-style binding made in this buffer is in effect,
1498 does not make the variable buffer-local. Return VARIABLE.
1500 In most cases it is better to use `make-local-variable',
1501 which makes a variable local in just one buffer.
1503 The function `default-value' gets the default value and `set-default' sets it. */)
1504 (register Lisp_Object variable
)
1506 struct Lisp_Symbol
*sym
;
1507 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1508 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1509 bool forwarded
IF_LINT (= 0);
1511 CHECK_SYMBOL (variable
);
1512 sym
= XSYMBOL (variable
);
1515 switch (sym
->redirect
)
1517 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1518 case SYMBOL_PLAINVAL
:
1519 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1520 if (EQ (valcontents
.value
, Qunbound
))
1521 valcontents
.value
= Qnil
;
1523 case SYMBOL_LOCALIZED
:
1524 blv
= SYMBOL_BLV (sym
);
1525 if (blv
->frame_local
)
1526 error ("Symbol %s may not be buffer-local",
1527 SDATA (SYMBOL_NAME (variable
)));
1529 case SYMBOL_FORWARDED
:
1530 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1531 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1532 error ("Symbol %s may not be buffer-local",
1533 SDATA (SYMBOL_NAME (variable
)));
1534 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1537 default: emacs_abort ();
1541 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1545 blv
= make_blv (sym
, forwarded
, valcontents
);
1546 sym
->redirect
= SYMBOL_LOCALIZED
;
1547 SET_SYMBOL_BLV (sym
, blv
);
1550 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1551 if (let_shadows_global_binding_p (symbol
))
1552 message ("Making %s buffer-local while let-bound!",
1553 SDATA (SYMBOL_NAME (variable
)));
1557 blv
->local_if_set
= 1;
1561 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1562 1, 1, "vMake Local Variable: ",
1563 doc
: /* Make VARIABLE have a separate value in the current buffer.
1564 Other buffers will continue to share a common default value.
1565 \(The buffer-local value of VARIABLE starts out as the same value
1566 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1569 If the variable is already arranged to become local when set,
1570 this function causes a local value to exist for this buffer,
1571 just as setting the variable would do.
1573 This function returns VARIABLE, and therefore
1574 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1577 See also `make-variable-buffer-local'.
1579 Do not use `make-local-variable' to make a hook variable buffer-local.
1580 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1581 (Lisp_Object variable
)
1584 bool forwarded
IF_LINT (= 0);
1585 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1586 struct Lisp_Symbol
*sym
;
1587 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1589 CHECK_SYMBOL (variable
);
1590 sym
= XSYMBOL (variable
);
1593 switch (sym
->redirect
)
1595 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1596 case SYMBOL_PLAINVAL
:
1597 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1598 case SYMBOL_LOCALIZED
:
1599 blv
= SYMBOL_BLV (sym
);
1600 if (blv
->frame_local
)
1601 error ("Symbol %s may not be buffer-local",
1602 SDATA (SYMBOL_NAME (variable
)));
1604 case SYMBOL_FORWARDED
:
1605 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1606 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1607 error ("Symbol %s may not be buffer-local",
1608 SDATA (SYMBOL_NAME (variable
)));
1610 default: emacs_abort ();
1614 error ("Symbol %s may not be buffer-local",
1615 SDATA (SYMBOL_NAME (variable
)));
1617 if (blv
? blv
->local_if_set
1618 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1620 tem
= Fboundp (variable
);
1621 /* Make sure the symbol has a local value in this particular buffer,
1622 by setting it to the same value it already has. */
1623 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1628 blv
= make_blv (sym
, forwarded
, valcontents
);
1629 sym
->redirect
= SYMBOL_LOCALIZED
;
1630 SET_SYMBOL_BLV (sym
, blv
);
1633 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1634 if (let_shadows_global_binding_p (symbol
))
1635 message ("Making %s local to %s while let-bound!",
1636 SDATA (SYMBOL_NAME (variable
)),
1637 SDATA (BVAR (current_buffer
, name
)));
1641 /* Make sure this buffer has its own value of symbol. */
1642 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1643 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1646 if (let_shadows_buffer_binding_p (sym
))
1647 message ("Making %s buffer-local while locally let-bound!",
1648 SDATA (SYMBOL_NAME (variable
)));
1650 /* Swap out any local binding for some other buffer, and make
1651 sure the current value is permanently recorded, if it's the
1653 find_symbol_value (variable
);
1655 bset_local_var_alist
1657 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1658 BVAR (current_buffer
, local_var_alist
)));
1660 /* Make sure symbol does not think it is set up for this buffer;
1661 force it to look once again for this buffer's value. */
1662 if (current_buffer
== XBUFFER (blv
->where
))
1663 set_blv_where (blv
, Qnil
);
1664 set_blv_found (blv
, 0);
1667 /* If the symbol forwards into a C variable, then load the binding
1668 for this buffer now. If C code modifies the variable before we
1669 load the binding in, then that new value will clobber the default
1670 binding the next time we unload it. */
1672 swap_in_symval_forwarding (sym
, blv
);
1677 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1678 1, 1, "vKill Local Variable: ",
1679 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1680 From now on the default value will apply in this buffer. Return VARIABLE. */)
1681 (register Lisp_Object variable
)
1683 register Lisp_Object tem
;
1684 struct Lisp_Buffer_Local_Value
*blv
;
1685 struct Lisp_Symbol
*sym
;
1687 CHECK_SYMBOL (variable
);
1688 sym
= XSYMBOL (variable
);
1691 switch (sym
->redirect
)
1693 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1694 case SYMBOL_PLAINVAL
: return variable
;
1695 case SYMBOL_FORWARDED
:
1697 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1698 if (BUFFER_OBJFWDP (valcontents
))
1700 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1701 int idx
= PER_BUFFER_IDX (offset
);
1705 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1706 set_per_buffer_value (current_buffer
, offset
,
1707 per_buffer_default (offset
));
1712 case SYMBOL_LOCALIZED
:
1713 blv
= SYMBOL_BLV (sym
);
1714 if (blv
->frame_local
)
1717 default: emacs_abort ();
1720 /* Get rid of this buffer's alist element, if any. */
1721 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1722 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1724 bset_local_var_alist
1726 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1728 /* If the symbol is set up with the current buffer's binding
1729 loaded, recompute its value. We have to do it now, or else
1730 forwarded objects won't work right. */
1732 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1733 if (EQ (buf
, blv
->where
))
1735 set_blv_where (blv
, Qnil
);
1737 find_symbol_value (variable
);
1744 /* Lisp functions for creating and removing buffer-local variables. */
1746 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1747 when/if this is removed. */
1749 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1750 1, 1, "vMake Variable Frame Local: ",
1751 doc
: /* Enable VARIABLE to have frame-local bindings.
1752 This does not create any frame-local bindings for VARIABLE,
1753 it just makes them possible.
1755 A frame-local binding is actually a frame parameter value.
1756 If a frame F has a value for the frame parameter named VARIABLE,
1757 that also acts as a frame-local binding for VARIABLE in F--
1758 provided this function has been called to enable VARIABLE
1759 to have frame-local bindings at all.
1761 The only way to create a frame-local binding for VARIABLE in a frame
1762 is to set the VARIABLE frame parameter of that frame. See
1763 `modify-frame-parameters' for how to set frame parameters.
1765 Note that since Emacs 23.1, variables cannot be both buffer-local and
1766 frame-local any more (buffer-local bindings used to take precedence over
1767 frame-local bindings). */)
1768 (Lisp_Object variable
)
1771 union Lisp_Val_Fwd valcontents
;
1772 struct Lisp_Symbol
*sym
;
1773 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1775 CHECK_SYMBOL (variable
);
1776 sym
= XSYMBOL (variable
);
1779 switch (sym
->redirect
)
1781 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1782 case SYMBOL_PLAINVAL
:
1783 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1784 if (EQ (valcontents
.value
, Qunbound
))
1785 valcontents
.value
= Qnil
;
1787 case SYMBOL_LOCALIZED
:
1788 if (SYMBOL_BLV (sym
)->frame_local
)
1791 error ("Symbol %s may not be frame-local",
1792 SDATA (SYMBOL_NAME (variable
)));
1793 case SYMBOL_FORWARDED
:
1794 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1795 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1796 error ("Symbol %s may not be frame-local",
1797 SDATA (SYMBOL_NAME (variable
)));
1799 default: emacs_abort ();
1803 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1805 blv
= make_blv (sym
, forwarded
, valcontents
);
1806 blv
->frame_local
= 1;
1807 sym
->redirect
= SYMBOL_LOCALIZED
;
1808 SET_SYMBOL_BLV (sym
, blv
);
1811 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1812 if (let_shadows_global_binding_p (symbol
))
1813 message ("Making %s frame-local while let-bound!",
1814 SDATA (SYMBOL_NAME (variable
)));
1819 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1821 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1822 BUFFER defaults to the current buffer. */)
1823 (register Lisp_Object variable
, Lisp_Object buffer
)
1825 register struct buffer
*buf
;
1826 struct Lisp_Symbol
*sym
;
1829 buf
= current_buffer
;
1832 CHECK_BUFFER (buffer
);
1833 buf
= XBUFFER (buffer
);
1836 CHECK_SYMBOL (variable
);
1837 sym
= XSYMBOL (variable
);
1840 switch (sym
->redirect
)
1842 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1843 case SYMBOL_PLAINVAL
: return Qnil
;
1844 case SYMBOL_LOCALIZED
:
1846 Lisp_Object tail
, elt
, tmp
;
1847 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1848 XSETBUFFER (tmp
, buf
);
1849 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1851 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1854 if (EQ (variable
, XCAR (elt
)))
1856 eassert (!blv
->frame_local
);
1857 eassert (blv_found (blv
) || !EQ (blv
->where
, tmp
));
1861 eassert (!blv_found (blv
) || !EQ (blv
->where
, tmp
));
1864 case SYMBOL_FORWARDED
:
1866 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1867 if (BUFFER_OBJFWDP (valcontents
))
1869 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1870 int idx
= PER_BUFFER_IDX (offset
);
1871 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1876 default: emacs_abort ();
1880 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1882 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1883 BUFFER defaults to the current buffer.
1885 More precisely, return non-nil if either VARIABLE already has a local
1886 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1887 `make-variable-buffer-local'). */)
1888 (register Lisp_Object variable
, Lisp_Object buffer
)
1890 struct Lisp_Symbol
*sym
;
1892 CHECK_SYMBOL (variable
);
1893 sym
= XSYMBOL (variable
);
1896 switch (sym
->redirect
)
1898 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1899 case SYMBOL_PLAINVAL
: return Qnil
;
1900 case SYMBOL_LOCALIZED
:
1902 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1903 if (blv
->local_if_set
)
1905 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1906 return Flocal_variable_p (variable
, buffer
);
1908 case SYMBOL_FORWARDED
:
1909 /* All BUFFER_OBJFWD slots become local if they are set. */
1910 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1911 default: emacs_abort ();
1915 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1917 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1918 If the current binding is buffer-local, the value is the current buffer.
1919 If the current binding is frame-local, the value is the selected frame.
1920 If the current binding is global (the default), the value is nil. */)
1921 (register Lisp_Object variable
)
1923 struct Lisp_Symbol
*sym
;
1925 CHECK_SYMBOL (variable
);
1926 sym
= XSYMBOL (variable
);
1928 /* Make sure the current binding is actually swapped in. */
1929 find_symbol_value (variable
);
1932 switch (sym
->redirect
)
1934 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1935 case SYMBOL_PLAINVAL
: return Qnil
;
1936 case SYMBOL_FORWARDED
:
1938 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1939 if (KBOARD_OBJFWDP (valcontents
))
1940 return Fframe_terminal (Fselected_frame ());
1941 else if (!BUFFER_OBJFWDP (valcontents
))
1945 case SYMBOL_LOCALIZED
:
1946 /* For a local variable, record both the symbol and which
1947 buffer's or frame's value we are saving. */
1948 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1949 return Fcurrent_buffer ();
1950 else if (sym
->redirect
== SYMBOL_LOCALIZED
1951 && blv_found (SYMBOL_BLV (sym
)))
1952 return SYMBOL_BLV (sym
)->where
;
1955 default: emacs_abort ();
1959 /* This code is disabled now that we use the selected frame to return
1960 keyboard-local-values. */
1962 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1964 DEFUN ("terminal-local-value", Fterminal_local_value
,
1965 Sterminal_local_value
, 2, 2, 0,
1966 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1967 If SYMBOL is not a terminal-local variable, then return its normal
1968 value, like `symbol-value'.
1970 TERMINAL may be a terminal object, a frame, or nil (meaning the
1971 selected frame's terminal device). */)
1972 (Lisp_Object symbol
, Lisp_Object terminal
)
1975 struct terminal
*t
= get_terminal (terminal
, 1);
1976 push_kboard (t
->kboard
);
1977 result
= Fsymbol_value (symbol
);
1982 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1983 Sset_terminal_local_value
, 3, 3, 0,
1984 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1985 If VARIABLE is not a terminal-local variable, then set its normal
1986 binding, like `set'.
1988 TERMINAL may be a terminal object, a frame, or nil (meaning the
1989 selected frame's terminal device). */)
1990 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1993 struct terminal
*t
= get_terminal (terminal
, 1);
1994 push_kboard (d
->kboard
);
1995 result
= Fset (symbol
, value
);
2001 /* Find the function at the end of a chain of symbol function indirections. */
2003 /* If OBJECT is a symbol, find the end of its function chain and
2004 return the value found there. If OBJECT is not a symbol, just
2005 return it. If there is a cycle in the function chain, signal a
2006 cyclic-function-indirection error.
2008 This is like Findirect_function, except that it doesn't signal an
2009 error if the chain ends up unbound. */
2011 indirect_function (register Lisp_Object object
)
2013 Lisp_Object tortoise
, hare
;
2015 hare
= tortoise
= object
;
2019 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2021 hare
= XSYMBOL (hare
)->function
;
2022 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2024 hare
= XSYMBOL (hare
)->function
;
2026 tortoise
= XSYMBOL (tortoise
)->function
;
2028 if (EQ (hare
, tortoise
))
2029 xsignal1 (Qcyclic_function_indirection
, object
);
2035 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2036 doc
: /* Return the function at the end of OBJECT's function chain.
2037 If OBJECT is not a symbol, just return it. Otherwise, follow all
2038 function indirections to find the final function binding and return it.
2039 If the final symbol in the chain is unbound, signal a void-function error.
2040 Optional arg NOERROR non-nil means to return nil instead of signaling.
2041 Signal a cyclic-function-indirection error if there is a loop in the
2042 function chain of symbols. */)
2043 (register Lisp_Object object
, Lisp_Object noerror
)
2047 /* Optimize for no indirection. */
2049 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2050 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2051 result
= indirect_function (result
);
2052 if (!EQ (result
, Qunbound
))
2056 xsignal1 (Qvoid_function
, object
);
2061 /* Extract and set vector and string elements. */
2063 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2064 doc
: /* Return the element of ARRAY at index IDX.
2065 ARRAY may be a vector, a string, a char-table, a bool-vector,
2066 or a byte-code object. IDX starts at 0. */)
2067 (register Lisp_Object array
, Lisp_Object idx
)
2069 register EMACS_INT idxval
;
2072 idxval
= XINT (idx
);
2073 if (STRINGP (array
))
2076 ptrdiff_t idxval_byte
;
2078 if (idxval
< 0 || idxval
>= SCHARS (array
))
2079 args_out_of_range (array
, idx
);
2080 if (! STRING_MULTIBYTE (array
))
2081 return make_number ((unsigned char) SREF (array
, idxval
));
2082 idxval_byte
= string_char_to_byte (array
, idxval
);
2084 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2085 return make_number (c
);
2087 else if (BOOL_VECTOR_P (array
))
2091 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2092 args_out_of_range (array
, idx
);
2094 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2095 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2097 else if (CHAR_TABLE_P (array
))
2099 CHECK_CHARACTER (idx
);
2100 return CHAR_TABLE_REF (array
, idxval
);
2105 if (VECTORP (array
))
2106 size
= ASIZE (array
);
2107 else if (COMPILEDP (array
))
2108 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2110 wrong_type_argument (Qarrayp
, array
);
2112 if (idxval
< 0 || idxval
>= size
)
2113 args_out_of_range (array
, idx
);
2114 return AREF (array
, idxval
);
2118 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2119 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2120 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2121 bool-vector. IDX starts at 0. */)
2122 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2124 register EMACS_INT idxval
;
2127 idxval
= XINT (idx
);
2128 CHECK_ARRAY (array
, Qarrayp
);
2129 CHECK_IMPURE (array
);
2131 if (VECTORP (array
))
2133 if (idxval
< 0 || idxval
>= ASIZE (array
))
2134 args_out_of_range (array
, idx
);
2135 ASET (array
, idxval
, newelt
);
2137 else if (BOOL_VECTOR_P (array
))
2141 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2142 args_out_of_range (array
, idx
);
2144 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2146 if (! NILP (newelt
))
2147 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2149 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2150 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2152 else if (CHAR_TABLE_P (array
))
2154 CHECK_CHARACTER (idx
);
2155 CHAR_TABLE_SET (array
, idxval
, newelt
);
2161 if (idxval
< 0 || idxval
>= SCHARS (array
))
2162 args_out_of_range (array
, idx
);
2163 CHECK_CHARACTER (newelt
);
2164 c
= XFASTINT (newelt
);
2166 if (STRING_MULTIBYTE (array
))
2168 ptrdiff_t idxval_byte
, nbytes
;
2169 int prev_bytes
, new_bytes
;
2170 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2172 nbytes
= SBYTES (array
);
2173 idxval_byte
= string_char_to_byte (array
, idxval
);
2174 p1
= SDATA (array
) + idxval_byte
;
2175 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2176 new_bytes
= CHAR_STRING (c
, p0
);
2177 if (prev_bytes
!= new_bytes
)
2179 /* We must relocate the string data. */
2180 ptrdiff_t nchars
= SCHARS (array
);
2182 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2184 memcpy (str
, SDATA (array
), nbytes
);
2185 allocate_string_data (XSTRING (array
), nchars
,
2186 nbytes
+ new_bytes
- prev_bytes
);
2187 memcpy (SDATA (array
), str
, idxval_byte
);
2188 p1
= SDATA (array
) + idxval_byte
;
2189 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2190 nbytes
- (idxval_byte
+ prev_bytes
));
2192 clear_string_char_byte_cache ();
2199 if (! SINGLE_BYTE_CHAR_P (c
))
2203 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2204 if (SREF (array
, i
) >= 0x80)
2205 args_out_of_range (array
, newelt
);
2206 /* ARRAY is an ASCII string. Convert it to a multibyte
2207 string, and try `aset' again. */
2208 STRING_SET_MULTIBYTE (array
);
2209 return Faset (array
, idx
, newelt
);
2211 SSET (array
, idxval
, c
);
2218 /* Arithmetic functions */
2220 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2223 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2225 double f1
= 0, f2
= 0;
2228 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2229 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2231 if (FLOATP (num1
) || FLOATP (num2
))
2234 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2235 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2241 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2246 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2251 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2256 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2261 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2266 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2275 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2276 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2277 (register Lisp_Object num1
, Lisp_Object num2
)
2279 return arithcompare (num1
, num2
, equal
);
2282 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2283 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2284 (register Lisp_Object num1
, Lisp_Object num2
)
2286 return arithcompare (num1
, num2
, less
);
2289 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2290 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2291 (register Lisp_Object num1
, Lisp_Object num2
)
2293 return arithcompare (num1
, num2
, grtr
);
2296 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2297 doc
: /* Return t if first arg is less than or equal to second arg.
2298 Both must be numbers or markers. */)
2299 (register Lisp_Object num1
, Lisp_Object num2
)
2301 return arithcompare (num1
, num2
, less_or_equal
);
2304 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2305 doc
: /* Return t if first arg is greater than or equal to second arg.
2306 Both must be numbers or markers. */)
2307 (register Lisp_Object num1
, Lisp_Object num2
)
2309 return arithcompare (num1
, num2
, grtr_or_equal
);
2312 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2313 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2314 (register Lisp_Object num1
, Lisp_Object num2
)
2316 return arithcompare (num1
, num2
, notequal
);
2319 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2320 doc
: /* Return t if NUMBER is zero. */)
2321 (register Lisp_Object number
)
2323 CHECK_NUMBER_OR_FLOAT (number
);
2325 if (FLOATP (number
))
2327 if (XFLOAT_DATA (number
) == 0.0)
2337 /* Convert the cons-of-integers, integer, or float value C to an
2338 unsigned value with maximum value MAX. Signal an error if C does not
2339 have a valid format or is out of range. */
2341 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2344 uintmax_t val
IF_LINT (= 0);
2347 valid
= 0 <= XINT (c
);
2350 else if (FLOATP (c
))
2352 double d
= XFLOAT_DATA (c
);
2354 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2360 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2362 uintmax_t top
= XFASTINT (XCAR (c
));
2363 Lisp_Object rest
= XCDR (c
);
2364 if (top
<= UINTMAX_MAX
>> 24 >> 16
2366 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2367 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2369 uintmax_t mid
= XFASTINT (XCAR (rest
));
2370 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2373 else if (top
<= UINTMAX_MAX
>> 16)
2377 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2379 val
= top
<< 16 | XFASTINT (rest
);
2385 if (! (valid
&& val
<= max
))
2386 error ("Not an in-range integer, float, or cons of integers");
2390 /* Convert the cons-of-integers, integer, or float value C to a signed
2391 value with extrema MIN and MAX. Signal an error if C does not have
2392 a valid format or is out of range. */
2394 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2397 intmax_t val
IF_LINT (= 0);
2403 else if (FLOATP (c
))
2405 double d
= XFLOAT_DATA (c
);
2407 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2413 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2415 intmax_t top
= XINT (XCAR (c
));
2416 Lisp_Object rest
= XCDR (c
);
2417 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2419 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2420 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2422 intmax_t mid
= XFASTINT (XCAR (rest
));
2423 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2426 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2430 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2432 val
= top
<< 16 | XFASTINT (rest
);
2438 if (! (valid
&& min
<= val
&& val
<= max
))
2439 error ("Not an in-range integer, float, or cons of integers");
2443 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2444 doc
: /* Return the decimal representation of NUMBER as a string.
2445 Uses a minus sign if negative.
2446 NUMBER may be an integer or a floating point number. */)
2447 (Lisp_Object number
)
2449 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2452 CHECK_NUMBER_OR_FLOAT (number
);
2454 if (FLOATP (number
))
2455 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2457 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2459 return make_unibyte_string (buffer
, len
);
2462 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2463 doc
: /* Parse STRING as a decimal number and return the number.
2464 This parses both integers and floating point numbers.
2465 It ignores leading spaces and tabs, and all trailing chars.
2467 If BASE, interpret STRING as a number in that base. If BASE isn't
2468 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2469 If the base used is not 10, STRING is always parsed as integer. */)
2470 (register Lisp_Object string
, Lisp_Object base
)
2476 CHECK_STRING (string
);
2482 CHECK_NUMBER (base
);
2483 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2484 xsignal1 (Qargs_out_of_range
, base
);
2488 p
= SSDATA (string
);
2489 while (*p
== ' ' || *p
== '\t')
2492 val
= string_to_number (p
, b
, 1);
2493 return NILP (val
) ? make_number (0) : val
;
2509 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2510 ptrdiff_t, Lisp_Object
*);
2512 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2515 ptrdiff_t argnum
, ok_args
;
2516 EMACS_INT accum
= 0;
2517 EMACS_INT next
, ok_accum
;
2538 for (argnum
= 0; argnum
< nargs
; argnum
++)
2546 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2548 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2551 return float_arith_driver (ok_accum
, ok_args
, code
,
2554 next
= XINT (args
[argnum
]);
2558 if (INT_ADD_OVERFLOW (accum
, next
))
2566 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2571 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2574 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2576 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2578 accum
= ab
& INTMASK
;
2589 xsignal0 (Qarith_error
);
2603 if (!argnum
|| next
> accum
)
2607 if (!argnum
|| next
< accum
)
2613 XSETINT (val
, accum
);
2618 #define isnan(x) ((x) != (x))
2621 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2622 ptrdiff_t nargs
, Lisp_Object
*args
)
2624 register Lisp_Object val
;
2627 for (; argnum
< nargs
; argnum
++)
2629 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2630 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2634 next
= XFLOAT_DATA (val
);
2638 args
[argnum
] = val
; /* runs into a compiler bug. */
2639 next
= XINT (args
[argnum
]);
2647 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2657 if (! IEEE_FLOATING_POINT
&& next
== 0)
2658 xsignal0 (Qarith_error
);
2665 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2667 if (!argnum
|| isnan (next
) || next
> accum
)
2671 if (!argnum
|| isnan (next
) || next
< accum
)
2677 return make_float (accum
);
2681 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2682 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2683 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2684 (ptrdiff_t nargs
, Lisp_Object
*args
)
2686 return arith_driver (Aadd
, nargs
, args
);
2689 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2690 doc
: /* Negate number or subtract numbers or markers and return the result.
2691 With one arg, negates it. With more than one arg,
2692 subtracts all but the first from the first.
2693 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2694 (ptrdiff_t nargs
, Lisp_Object
*args
)
2696 return arith_driver (Asub
, nargs
, args
);
2699 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2700 doc
: /* Return product of any number of arguments, which are numbers or markers.
2701 usage: (* &rest NUMBERS-OR-MARKERS) */)
2702 (ptrdiff_t nargs
, Lisp_Object
*args
)
2704 return arith_driver (Amult
, nargs
, args
);
2707 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2708 doc
: /* Return first argument divided by all the remaining arguments.
2709 The arguments must be numbers or markers.
2710 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2711 (ptrdiff_t nargs
, Lisp_Object
*args
)
2714 for (argnum
= 2; argnum
< nargs
; argnum
++)
2715 if (FLOATP (args
[argnum
]))
2716 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2717 return arith_driver (Adiv
, nargs
, args
);
2720 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2721 doc
: /* Return remainder of X divided by Y.
2722 Both must be integers or markers. */)
2723 (register Lisp_Object x
, Lisp_Object y
)
2727 CHECK_NUMBER_COERCE_MARKER (x
);
2728 CHECK_NUMBER_COERCE_MARKER (y
);
2731 xsignal0 (Qarith_error
);
2733 XSETINT (val
, XINT (x
) % XINT (y
));
2737 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2738 doc
: /* Return X modulo Y.
2739 The result falls between zero (inclusive) and Y (exclusive).
2740 Both X and Y must be numbers or markers. */)
2741 (register Lisp_Object x
, Lisp_Object y
)
2746 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2747 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2749 if (FLOATP (x
) || FLOATP (y
))
2750 return fmod_float (x
, y
);
2756 xsignal0 (Qarith_error
);
2760 /* If the "remainder" comes out with the wrong sign, fix it. */
2761 if (i2
< 0 ? i1
> 0 : i1
< 0)
2768 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2769 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2770 The value is always a number; markers are converted to numbers.
2771 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2772 (ptrdiff_t nargs
, Lisp_Object
*args
)
2774 return arith_driver (Amax
, nargs
, args
);
2777 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2778 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2779 The value is always a number; markers are converted to numbers.
2780 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2781 (ptrdiff_t nargs
, Lisp_Object
*args
)
2783 return arith_driver (Amin
, nargs
, args
);
2786 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2787 doc
: /* Return bitwise-and of all the arguments.
2788 Arguments may be integers, or markers converted to integers.
2789 usage: (logand &rest INTS-OR-MARKERS) */)
2790 (ptrdiff_t nargs
, Lisp_Object
*args
)
2792 return arith_driver (Alogand
, nargs
, args
);
2795 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2796 doc
: /* Return bitwise-or of all the arguments.
2797 Arguments may be integers, or markers converted to integers.
2798 usage: (logior &rest INTS-OR-MARKERS) */)
2799 (ptrdiff_t nargs
, Lisp_Object
*args
)
2801 return arith_driver (Alogior
, nargs
, args
);
2804 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2805 doc
: /* Return bitwise-exclusive-or of all the arguments.
2806 Arguments may be integers, or markers converted to integers.
2807 usage: (logxor &rest INTS-OR-MARKERS) */)
2808 (ptrdiff_t nargs
, Lisp_Object
*args
)
2810 return arith_driver (Alogxor
, nargs
, args
);
2813 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2814 doc
: /* Return VALUE with its bits shifted left by COUNT.
2815 If COUNT is negative, shifting is actually to the right.
2816 In this case, the sign bit is duplicated. */)
2817 (register Lisp_Object value
, Lisp_Object count
)
2819 register Lisp_Object val
;
2821 CHECK_NUMBER (value
);
2822 CHECK_NUMBER (count
);
2824 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2826 else if (XINT (count
) > 0)
2827 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2828 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2829 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2831 XSETINT (val
, XINT (value
) >> -XINT (count
));
2835 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2836 doc
: /* Return VALUE with its bits shifted left by COUNT.
2837 If COUNT is negative, shifting is actually to the right.
2838 In this case, zeros are shifted in on the left. */)
2839 (register Lisp_Object value
, Lisp_Object count
)
2841 register Lisp_Object val
;
2843 CHECK_NUMBER (value
);
2844 CHECK_NUMBER (count
);
2846 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2848 else if (XINT (count
) > 0)
2849 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2850 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2853 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2857 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2858 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2859 Markers are converted to integers. */)
2860 (register Lisp_Object number
)
2862 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2864 if (FLOATP (number
))
2865 return (make_float (1.0 + XFLOAT_DATA (number
)));
2867 XSETINT (number
, XINT (number
) + 1);
2871 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2872 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2873 Markers are converted to integers. */)
2874 (register Lisp_Object number
)
2876 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2878 if (FLOATP (number
))
2879 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2881 XSETINT (number
, XINT (number
) - 1);
2885 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2886 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2887 (register Lisp_Object number
)
2889 CHECK_NUMBER (number
);
2890 XSETINT (number
, ~XINT (number
));
2894 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2895 doc
: /* Return the byteorder for the machine.
2896 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2897 lowercase l) for small endian machines. */)
2900 unsigned i
= 0x04030201;
2901 int order
= *(char *)&i
== 1 ? 108 : 66;
2903 return make_number (order
);
2911 Lisp_Object error_tail
, arith_tail
;
2913 DEFSYM (Qquote
, "quote");
2914 DEFSYM (Qlambda
, "lambda");
2915 DEFSYM (Qsubr
, "subr");
2916 DEFSYM (Qerror_conditions
, "error-conditions");
2917 DEFSYM (Qerror_message
, "error-message");
2918 DEFSYM (Qtop_level
, "top-level");
2920 DEFSYM (Qerror
, "error");
2921 DEFSYM (Quser_error
, "user-error");
2922 DEFSYM (Qquit
, "quit");
2923 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2924 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2925 DEFSYM (Qvoid_function
, "void-function");
2926 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2927 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2928 DEFSYM (Qvoid_variable
, "void-variable");
2929 DEFSYM (Qsetting_constant
, "setting-constant");
2930 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2932 DEFSYM (Qinvalid_function
, "invalid-function");
2933 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2934 DEFSYM (Qno_catch
, "no-catch");
2935 DEFSYM (Qend_of_file
, "end-of-file");
2936 DEFSYM (Qarith_error
, "arith-error");
2937 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2938 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2939 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2940 DEFSYM (Qtext_read_only
, "text-read-only");
2941 DEFSYM (Qmark_inactive
, "mark-inactive");
2943 DEFSYM (Qlistp
, "listp");
2944 DEFSYM (Qconsp
, "consp");
2945 DEFSYM (Qsymbolp
, "symbolp");
2946 DEFSYM (Qkeywordp
, "keywordp");
2947 DEFSYM (Qintegerp
, "integerp");
2948 DEFSYM (Qnatnump
, "natnump");
2949 DEFSYM (Qwholenump
, "wholenump");
2950 DEFSYM (Qstringp
, "stringp");
2951 DEFSYM (Qarrayp
, "arrayp");
2952 DEFSYM (Qsequencep
, "sequencep");
2953 DEFSYM (Qbufferp
, "bufferp");
2954 DEFSYM (Qvectorp
, "vectorp");
2955 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2956 DEFSYM (Qmarkerp
, "markerp");
2957 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
2958 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
2959 DEFSYM (Qboundp
, "boundp");
2960 DEFSYM (Qfboundp
, "fboundp");
2962 DEFSYM (Qfloatp
, "floatp");
2963 DEFSYM (Qnumberp
, "numberp");
2964 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
2966 DEFSYM (Qchar_table_p
, "char-table-p");
2967 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
2969 DEFSYM (Qsubrp
, "subrp");
2970 DEFSYM (Qunevalled
, "unevalled");
2971 DEFSYM (Qmany
, "many");
2973 DEFSYM (Qcdr
, "cdr");
2975 /* Handle automatic advice activation. */
2976 DEFSYM (Qad_advice_info
, "ad-advice-info");
2977 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
2979 error_tail
= pure_cons (Qerror
, Qnil
);
2981 /* ERROR is used as a signaler for random errors for which nothing else is
2984 Fput (Qerror
, Qerror_conditions
,
2986 Fput (Qerror
, Qerror_message
,
2987 build_pure_c_string ("error"));
2989 #define PUT_ERROR(sym, tail, msg) \
2990 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
2991 Fput (sym, Qerror_message, build_pure_c_string (msg))
2993 PUT_ERROR (Qquit
, Qnil
, "Quit");
2995 PUT_ERROR (Quser_error
, error_tail
, "");
2996 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
2997 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
2998 PUT_ERROR (Qvoid_function
, error_tail
,
2999 "Symbol's function definition is void");
3000 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3001 "Symbol's chain of function indirections contains a loop");
3002 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3003 "Symbol's chain of variable indirections contains a loop");
3004 DEFSYM (Qcircular_list
, "circular-list");
3005 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3006 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3007 PUT_ERROR (Qsetting_constant
, error_tail
,
3008 "Attempt to set a constant symbol");
3009 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3010 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3011 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3012 "Wrong number of arguments");
3013 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3014 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3016 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3017 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3018 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3020 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3021 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3022 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3023 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3024 "Text is read-only");
3026 DEFSYM (Qrange_error
, "range-error");
3027 DEFSYM (Qdomain_error
, "domain-error");
3028 DEFSYM (Qsingularity_error
, "singularity-error");
3029 DEFSYM (Qoverflow_error
, "overflow-error");
3030 DEFSYM (Qunderflow_error
, "underflow-error");
3032 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3034 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3036 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3037 "Arithmetic singularity error");
3039 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3040 "Arithmetic overflow error");
3041 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3042 "Arithmetic underflow error");
3046 staticpro (&Qunbound
);
3048 /* Types that type-of returns. */
3049 DEFSYM (Qinteger
, "integer");
3050 DEFSYM (Qsymbol
, "symbol");
3051 DEFSYM (Qstring
, "string");
3052 DEFSYM (Qcons
, "cons");
3053 DEFSYM (Qmarker
, "marker");
3054 DEFSYM (Qoverlay
, "overlay");
3055 DEFSYM (Qfloat
, "float");
3056 DEFSYM (Qwindow_configuration
, "window-configuration");
3057 DEFSYM (Qprocess
, "process");
3058 DEFSYM (Qwindow
, "window");
3059 DEFSYM (Qcompiled_function
, "compiled-function");
3060 DEFSYM (Qbuffer
, "buffer");
3061 DEFSYM (Qframe
, "frame");
3062 DEFSYM (Qvector
, "vector");
3063 DEFSYM (Qchar_table
, "char-table");
3064 DEFSYM (Qbool_vector
, "bool-vector");
3065 DEFSYM (Qhash_table
, "hash-table");
3066 DEFSYM (Qmisc
, "misc");
3068 DEFSYM (Qdefun
, "defun");
3070 DEFSYM (Qfont_spec
, "font-spec");
3071 DEFSYM (Qfont_entity
, "font-entity");
3072 DEFSYM (Qfont_object
, "font-object");
3074 DEFSYM (Qinteractive_form
, "interactive-form");
3076 defsubr (&Sindirect_variable
);
3077 defsubr (&Sinteractive_form
);
3080 defsubr (&Stype_of
);
3085 defsubr (&Sintegerp
);
3086 defsubr (&Sinteger_or_marker_p
);
3087 defsubr (&Snumberp
);
3088 defsubr (&Snumber_or_marker_p
);
3090 defsubr (&Snatnump
);
3091 defsubr (&Ssymbolp
);
3092 defsubr (&Skeywordp
);
3093 defsubr (&Sstringp
);
3094 defsubr (&Smultibyte_string_p
);
3095 defsubr (&Svectorp
);
3096 defsubr (&Schar_table_p
);
3097 defsubr (&Svector_or_char_table_p
);
3098 defsubr (&Sbool_vector_p
);
3100 defsubr (&Ssequencep
);
3101 defsubr (&Sbufferp
);
3102 defsubr (&Smarkerp
);
3104 defsubr (&Sbyte_code_function_p
);
3105 defsubr (&Schar_or_string_p
);
3108 defsubr (&Scar_safe
);
3109 defsubr (&Scdr_safe
);
3112 defsubr (&Ssymbol_function
);
3113 defsubr (&Sindirect_function
);
3114 defsubr (&Ssymbol_plist
);
3115 defsubr (&Ssymbol_name
);
3116 defsubr (&Smakunbound
);
3117 defsubr (&Sfmakunbound
);
3119 defsubr (&Sfboundp
);
3121 defsubr (&Sdefalias
);
3122 defsubr (&Ssetplist
);
3123 defsubr (&Ssymbol_value
);
3125 defsubr (&Sdefault_boundp
);
3126 defsubr (&Sdefault_value
);
3127 defsubr (&Sset_default
);
3128 defsubr (&Ssetq_default
);
3129 defsubr (&Smake_variable_buffer_local
);
3130 defsubr (&Smake_local_variable
);
3131 defsubr (&Skill_local_variable
);
3132 defsubr (&Smake_variable_frame_local
);
3133 defsubr (&Slocal_variable_p
);
3134 defsubr (&Slocal_variable_if_set_p
);
3135 defsubr (&Svariable_binding_locus
);
3136 #if 0 /* XXX Remove this. --lorentey */
3137 defsubr (&Sterminal_local_value
);
3138 defsubr (&Sset_terminal_local_value
);
3142 defsubr (&Snumber_to_string
);
3143 defsubr (&Sstring_to_number
);
3144 defsubr (&Seqlsign
);
3167 defsubr (&Sbyteorder
);
3168 defsubr (&Ssubr_arity
);
3169 defsubr (&Ssubr_name
);
3171 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3173 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3174 doc
: /* The largest value that is representable in a Lisp integer. */);
3175 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3176 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3178 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3179 doc
: /* The smallest value that is representable in a Lisp integer. */);
3180 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3181 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3184 static _Noreturn
void
3185 handle_arith_signal (int sig
)
3187 pthread_sigmask (SIG_SETMASK
, &empty_mask
, 0);
3188 xsignal0 (Qarith_error
);
3192 deliver_arith_signal (int sig
)
3194 handle_on_main_thread (sig
, handle_arith_signal
);
3200 struct sigaction action
;
3201 /* Don't do this if just dumping out.
3202 We don't want to call `signal' in this case
3203 so that we don't have trouble with dumping
3204 signal-delivering routines in an inconsistent state. */
3208 #endif /* CANNOT_DUMP */
3209 emacs_sigaction_init (&action
, deliver_arith_signal
);
3210 sigaction (SIGFPE
, &action
, 0);