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 IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
51 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
52 static Lisp_Object Qsubr
;
53 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
54 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
55 static Lisp_Object Qwrong_type_argument
;
56 Lisp_Object Qvoid_variable
, Qvoid_function
;
57 static Lisp_Object Qcyclic_function_indirection
;
58 static Lisp_Object Qcyclic_variable_indirection
;
59 Lisp_Object Qcircular_list
;
60 static Lisp_Object Qsetting_constant
;
61 Lisp_Object Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 static Lisp_Object Qnatnump
;
69 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
70 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
71 Lisp_Object Qbuffer_or_string_p
;
72 static Lisp_Object Qkeywordp
, Qboundp
;
74 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
77 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
79 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
80 Lisp_Object Qoverflow_error
, Qunderflow_error
;
83 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
85 Lisp_Object Qinteger
, Qsymbol
;
86 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
88 static Lisp_Object Qoverlay
, Qwindow_configuration
;
89 static Lisp_Object Qprocess
, Qmarker
;
90 static Lisp_Object Qcompiled_function
, Qframe
;
92 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
93 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
94 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
95 static Lisp_Object Qdefun
;
97 Lisp_Object Qinteractive_form
;
99 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
103 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
105 /* If VALUE is not even a valid Lisp object, we'd want to abort here
106 where we can get a backtrace showing where it came from. We used
107 to try and do that by checking the tagbits, but nowadays all
108 tagbits are potentially valid. */
109 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
112 xsignal2 (Qwrong_type_argument
, predicate
, value
);
116 pure_write_error (void)
118 error ("Attempt to modify read-only object");
122 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
124 xsignal2 (Qargs_out_of_range
, a1
, a2
);
128 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
130 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
134 /* Data type predicates. */
136 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
137 doc
: /* Return t if the two args are the same Lisp object. */)
138 (Lisp_Object obj1
, Lisp_Object obj2
)
145 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
146 doc
: /* Return t if OBJECT is nil. */)
154 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
155 doc
: /* Return a symbol representing the type of OBJECT.
156 The symbol returned names the object's basic type;
157 for example, (type-of 1) returns `integer'. */)
160 switch (XTYPE (object
))
175 switch (XMISCTYPE (object
))
177 case Lisp_Misc_Marker
:
179 case Lisp_Misc_Overlay
:
181 case Lisp_Misc_Float
:
186 case Lisp_Vectorlike
:
187 if (WINDOW_CONFIGURATIONP (object
))
188 return Qwindow_configuration
;
189 if (PROCESSP (object
))
191 if (WINDOWP (object
))
195 if (COMPILEDP (object
))
196 return Qcompiled_function
;
197 if (BUFFERP (object
))
199 if (CHAR_TABLE_P (object
))
201 if (BOOL_VECTOR_P (object
))
205 if (HASH_TABLE_P (object
))
207 if (FONT_SPEC_P (object
))
209 if (FONT_ENTITY_P (object
))
211 if (FONT_OBJECT_P (object
))
223 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
224 doc
: /* Return t if OBJECT is a cons cell. */)
232 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
233 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
241 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
242 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
243 Otherwise, return nil. */)
246 if (CONSP (object
) || NILP (object
))
251 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
252 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
255 if (CONSP (object
) || NILP (object
))
260 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
261 doc
: /* Return t if OBJECT is a symbol. */)
264 if (SYMBOLP (object
))
269 /* Define this in C to avoid unnecessarily consing up the symbol
271 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
272 doc
: /* Return t if OBJECT is a keyword.
273 This means that it is a symbol with a print name beginning with `:'
274 interned in the initial obarray. */)
278 && SREF (SYMBOL_NAME (object
), 0) == ':'
279 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
284 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
285 doc
: /* Return t if OBJECT is a vector. */)
288 if (VECTORP (object
))
293 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
294 doc
: /* Return t if OBJECT is a string. */)
297 if (STRINGP (object
))
302 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
304 doc
: /* Return t if OBJECT is a multibyte string. */)
307 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
312 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
313 doc
: /* Return t if OBJECT is a char-table. */)
316 if (CHAR_TABLE_P (object
))
321 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
322 Svector_or_char_table_p
, 1, 1, 0,
323 doc
: /* Return t if OBJECT is a char-table or vector. */)
326 if (VECTORP (object
) || CHAR_TABLE_P (object
))
331 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
332 doc
: /* Return t if OBJECT is a bool-vector. */)
335 if (BOOL_VECTOR_P (object
))
340 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
341 doc
: /* Return t if OBJECT is an array (string or vector). */)
349 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
350 doc
: /* Return t if OBJECT is a sequence (list or array). */)
351 (register Lisp_Object object
)
353 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
358 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
359 doc
: /* Return t if OBJECT is an editor buffer. */)
362 if (BUFFERP (object
))
367 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
371 if (MARKERP (object
))
376 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is a built-in function. */)
385 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
387 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
390 if (COMPILEDP (object
))
395 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
396 doc
: /* Return t if OBJECT is a character or a string. */)
397 (register Lisp_Object object
)
399 if (CHARACTERP (object
) || STRINGP (object
))
404 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is an integer. */)
408 if (INTEGERP (object
))
413 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
414 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
415 (register Lisp_Object object
)
417 if (MARKERP (object
) || INTEGERP (object
))
422 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
423 doc
: /* Return t if OBJECT is a nonnegative integer. */)
426 if (NATNUMP (object
))
431 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
432 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
435 if (NUMBERP (object
))
441 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
442 Snumber_or_marker_p
, 1, 1, 0,
443 doc
: /* Return t if OBJECT is a number or a marker. */)
446 if (NUMBERP (object
) || MARKERP (object
))
451 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
452 doc
: /* Return t if OBJECT is a floating point number. */)
461 /* Extract and set components of lists */
463 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
464 doc
: /* Return the car of LIST. If arg is nil, return nil.
465 Error if arg is not nil and not a cons cell. See also `car-safe'.
467 See Info node `(elisp)Cons Cells' for a discussion of related basic
468 Lisp concepts such as car, cdr, cons cell and list. */)
469 (register Lisp_Object list
)
474 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
475 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
478 return CAR_SAFE (object
);
481 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
482 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
483 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
485 See Info node `(elisp)Cons Cells' for a discussion of related basic
486 Lisp concepts such as cdr, car, cons cell and list. */)
487 (register Lisp_Object list
)
492 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
493 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
496 return CDR_SAFE (object
);
499 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
500 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
501 (register Lisp_Object cell
, Lisp_Object newcar
)
505 XSETCAR (cell
, newcar
);
509 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
510 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
511 (register Lisp_Object cell
, Lisp_Object newcdr
)
515 XSETCDR (cell
, newcdr
);
519 /* Extract and set components of symbols. */
521 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
522 doc
: /* Return t if SYMBOL's value is not void. */)
523 (register Lisp_Object symbol
)
525 Lisp_Object valcontents
;
526 struct Lisp_Symbol
*sym
;
527 CHECK_SYMBOL (symbol
);
528 sym
= XSYMBOL (symbol
);
531 switch (sym
->redirect
)
533 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
534 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
535 case SYMBOL_LOCALIZED
:
537 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
539 /* In set_internal, we un-forward vars when their value is
544 swap_in_symval_forwarding (sym
, blv
);
545 valcontents
= blv_value (blv
);
549 case SYMBOL_FORWARDED
:
550 /* In set_internal, we un-forward vars when their value is
553 default: emacs_abort ();
556 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
559 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
560 doc
: /* Return t if SYMBOL's function definition is not void. */)
561 (register Lisp_Object symbol
)
563 CHECK_SYMBOL (symbol
);
564 return EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
;
567 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
568 doc
: /* Make SYMBOL's value be void.
570 (register Lisp_Object symbol
)
572 CHECK_SYMBOL (symbol
);
573 if (SYMBOL_CONSTANT_P (symbol
))
574 xsignal1 (Qsetting_constant
, symbol
);
575 Fset (symbol
, Qunbound
);
579 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
580 doc
: /* Make SYMBOL's function definition be void.
582 (register Lisp_Object symbol
)
584 CHECK_SYMBOL (symbol
);
585 if (NILP (symbol
) || EQ (symbol
, Qt
))
586 xsignal1 (Qsetting_constant
, symbol
);
587 set_symbol_function (symbol
, Qunbound
);
591 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
592 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
593 (register Lisp_Object symbol
)
595 CHECK_SYMBOL (symbol
);
596 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
597 return XSYMBOL (symbol
)->function
;
598 xsignal1 (Qvoid_function
, symbol
);
601 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
602 doc
: /* Return SYMBOL's property list. */)
603 (register Lisp_Object symbol
)
605 CHECK_SYMBOL (symbol
);
606 return XSYMBOL (symbol
)->plist
;
609 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
610 doc
: /* Return SYMBOL's name, a string. */)
611 (register Lisp_Object symbol
)
613 register Lisp_Object name
;
615 CHECK_SYMBOL (symbol
);
616 name
= SYMBOL_NAME (symbol
);
620 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
621 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
622 (register Lisp_Object symbol
, Lisp_Object definition
)
624 register Lisp_Object function
;
626 CHECK_SYMBOL (symbol
);
627 if (NILP (symbol
) || EQ (symbol
, Qt
))
628 xsignal1 (Qsetting_constant
, symbol
);
630 function
= XSYMBOL (symbol
)->function
;
632 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
633 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
635 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
636 Fput (symbol
, Qautoload
, XCDR (function
));
638 set_symbol_function (symbol
, definition
);
639 /* Handle automatic advice activation. */
640 if (CONSP (XSYMBOL (symbol
)->plist
)
641 && !NILP (Fget (symbol
, Qad_advice_info
)))
643 call2 (Qad_activate_internal
, symbol
, Qnil
);
644 definition
= XSYMBOL (symbol
)->function
;
649 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
650 doc
: /* Set SYMBOL's function definition to DEFINITION.
651 Associates the function with the current load file, if any.
652 The optional third argument DOCSTRING specifies the documentation string
653 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
654 determined by DEFINITION.
655 The return value is undefined. */)
656 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
658 CHECK_SYMBOL (symbol
);
659 if (CONSP (XSYMBOL (symbol
)->function
)
660 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
661 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
662 if (!NILP (Vpurify_flag
)
663 /* If `definition' is a keymap, immutable (and copying) is wrong. */
664 && !KEYMAPP (definition
))
665 definition
= Fpurecopy (definition
);
666 definition
= Ffset (symbol
, definition
);
667 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
668 if (!NILP (docstring
))
669 Fput (symbol
, Qfunction_documentation
, docstring
);
670 /* We used to return `definition', but now that `defun' and `defmacro' expand
671 to a call to `defalias', we return `symbol' for backward compatibility
676 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
677 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
678 (register Lisp_Object symbol
, Lisp_Object newplist
)
680 CHECK_SYMBOL (symbol
);
681 set_symbol_plist (symbol
, newplist
);
685 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
686 doc
: /* Return minimum and maximum number of args allowed for SUBR.
687 SUBR must be a built-in function.
688 The returned value is a pair (MIN . MAX). MIN is the minimum number
689 of args. MAX is the maximum number or the symbol `many', for a
690 function with `&rest' args, or `unevalled' for a special form. */)
693 short minargs
, maxargs
;
695 minargs
= XSUBR (subr
)->min_args
;
696 maxargs
= XSUBR (subr
)->max_args
;
698 return Fcons (make_number (minargs
), Qmany
);
699 else if (maxargs
== UNEVALLED
)
700 return Fcons (make_number (minargs
), Qunevalled
);
702 return Fcons (make_number (minargs
), make_number (maxargs
));
705 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
706 doc
: /* Return name of subroutine SUBR.
707 SUBR must be a built-in function. */)
712 name
= XSUBR (subr
)->symbol_name
;
713 return build_string (name
);
716 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
717 doc
: /* Return the interactive form of CMD or nil if none.
718 If CMD is not a command, the return value is nil.
719 Value, if non-nil, is a list \(interactive SPEC). */)
722 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
724 if (NILP (fun
) || EQ (fun
, Qunbound
))
727 /* Use an `interactive-form' property if present, analogous to the
728 function-documentation property. */
730 while (SYMBOLP (fun
))
732 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
736 fun
= Fsymbol_function (fun
);
741 const char *spec
= XSUBR (fun
)->intspec
;
743 return list2 (Qinteractive
,
744 (*spec
!= '(') ? build_string (spec
) :
745 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
747 else if (COMPILEDP (fun
))
749 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
750 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
752 else if (CONSP (fun
))
754 Lisp_Object funcar
= XCAR (fun
);
755 if (EQ (funcar
, Qclosure
))
756 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
757 else if (EQ (funcar
, Qlambda
))
758 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
759 else if (EQ (funcar
, Qautoload
))
763 Fautoload_do_load (fun
, cmd
, Qnil
);
765 return Finteractive_form (cmd
);
772 /***********************************************************************
773 Getting and Setting Values of Symbols
774 ***********************************************************************/
776 /* Return the symbol holding SYMBOL's value. Signal
777 `cyclic-variable-indirection' if SYMBOL's chain of variable
778 indirections contains a loop. */
781 indirect_variable (struct Lisp_Symbol
*symbol
)
783 struct Lisp_Symbol
*tortoise
, *hare
;
785 hare
= tortoise
= symbol
;
787 while (hare
->redirect
== SYMBOL_VARALIAS
)
789 hare
= SYMBOL_ALIAS (hare
);
790 if (hare
->redirect
!= SYMBOL_VARALIAS
)
793 hare
= SYMBOL_ALIAS (hare
);
794 tortoise
= SYMBOL_ALIAS (tortoise
);
796 if (hare
== tortoise
)
799 XSETSYMBOL (tem
, symbol
);
800 xsignal1 (Qcyclic_variable_indirection
, tem
);
808 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
809 doc
: /* Return the variable at the end of OBJECT's variable chain.
810 If OBJECT is a symbol, follow its variable indirections (if any), and
811 return the variable at the end of the chain of aliases. See Info node
812 `(elisp)Variable Aliases'.
814 If OBJECT is not a symbol, just return it. If there is a loop in the
815 chain of aliases, signal a `cyclic-variable-indirection' error. */)
818 if (SYMBOLP (object
))
820 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
821 XSETSYMBOL (object
, sym
);
827 /* Given the raw contents of a symbol value cell,
828 return the Lisp value of the symbol.
829 This does not handle buffer-local variables; use
830 swap_in_symval_forwarding for that. */
833 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
835 register Lisp_Object val
;
836 switch (XFWDTYPE (valcontents
))
839 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
843 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
846 return *XOBJFWD (valcontents
)->objvar
;
848 case Lisp_Fwd_Buffer_Obj
:
849 return per_buffer_value (current_buffer
,
850 XBUFFER_OBJFWD (valcontents
)->offset
);
852 case Lisp_Fwd_Kboard_Obj
:
853 /* We used to simply use current_kboard here, but from Lisp
854 code, its value is often unexpected. It seems nicer to
855 allow constructions like this to work as intuitively expected:
857 (with-selected-frame frame
858 (define-key local-function-map "\eOP" [f1]))
860 On the other hand, this affects the semantics of
861 last-command and real-last-command, and people may rely on
862 that. I took a quick look at the Lisp codebase, and I
863 don't think anything will break. --lorentey */
864 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
865 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
866 default: emacs_abort ();
870 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
871 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
872 buffer-independent contents of the value cell: forwarded just one
873 step past the buffer-localness.
875 BUF non-zero means set the value in buffer BUF instead of the
876 current buffer. This only plays a role for per-buffer variables. */
879 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
881 switch (XFWDTYPE (valcontents
))
884 CHECK_NUMBER (newval
);
885 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
889 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
893 *XOBJFWD (valcontents
)->objvar
= newval
;
895 /* If this variable is a default for something stored
896 in the buffer itself, such as default-fill-column,
897 find the buffers that don't have local values for it
899 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
900 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
902 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
903 - (char *) &buffer_defaults
);
904 int idx
= PER_BUFFER_IDX (offset
);
911 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
916 lbuf
= Fcdr (XCAR (tail
));
917 if (!BUFFERP (lbuf
)) continue;
920 if (! PER_BUFFER_VALUE_P (b
, idx
))
921 set_per_buffer_value (b
, offset
, newval
);
926 case Lisp_Fwd_Buffer_Obj
:
928 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
929 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
931 if (!(NILP (type
) || NILP (newval
)
932 || (XINT (type
) == Lisp_Int0
934 : XTYPE (newval
) == XINT (type
))))
935 buffer_slot_type_mismatch (newval
, XINT (type
));
938 buf
= current_buffer
;
939 set_per_buffer_value (buf
, offset
, newval
);
943 case Lisp_Fwd_Kboard_Obj
:
945 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
946 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
947 *(Lisp_Object
*) p
= newval
;
952 emacs_abort (); /* goto def; */
956 /* Set up SYMBOL to refer to its global binding.
957 This makes it safe to alter the status of other bindings. */
960 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
962 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
964 /* Unload the previously loaded binding. */
966 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
968 /* Select the global binding in the symbol. */
969 set_blv_valcell (blv
, blv
->defcell
);
971 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
973 /* Indicate that the global binding is set up now. */
974 set_blv_where (blv
, Qnil
);
975 set_blv_found (blv
, 0);
978 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
979 VALCONTENTS is the contents of its value cell,
980 which points to a struct Lisp_Buffer_Local_Value.
982 Return the value forwarded one step past the buffer-local stage.
983 This could be another forwarding pointer. */
986 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
988 register Lisp_Object tem1
;
990 eassert (blv
== SYMBOL_BLV (symbol
));
996 ? !EQ (selected_frame
, tem1
)
997 : current_buffer
!= XBUFFER (tem1
)))
1000 /* Unload the previously loaded binding. */
1001 tem1
= blv
->valcell
;
1003 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1004 /* Choose the new binding. */
1007 XSETSYMBOL (var
, symbol
);
1008 if (blv
->frame_local
)
1010 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1011 set_blv_where (blv
, selected_frame
);
1015 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1016 XSETBUFFER (blv
->where
, current_buffer
);
1019 if (!(blv
->found
= !NILP (tem1
)))
1020 tem1
= blv
->defcell
;
1022 /* Load the new binding. */
1023 set_blv_valcell (blv
, tem1
);
1025 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1029 /* Find the value of a symbol, returning Qunbound if it's not bound.
1030 This is helpful for code which just wants to get a variable's value
1031 if it has one, without signaling an error.
1032 Note that it must not be possible to quit
1033 within this function. Great care is required for this. */
1036 find_symbol_value (Lisp_Object symbol
)
1038 struct Lisp_Symbol
*sym
;
1040 CHECK_SYMBOL (symbol
);
1041 sym
= XSYMBOL (symbol
);
1044 switch (sym
->redirect
)
1046 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1047 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1048 case SYMBOL_LOCALIZED
:
1050 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1051 swap_in_symval_forwarding (sym
, blv
);
1052 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1055 case SYMBOL_FORWARDED
:
1056 return do_symval_forwarding (SYMBOL_FWD (sym
));
1057 default: emacs_abort ();
1061 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1062 doc
: /* Return SYMBOL's value. Error if that is void. */)
1063 (Lisp_Object symbol
)
1067 val
= find_symbol_value (symbol
);
1068 if (!EQ (val
, Qunbound
))
1071 xsignal1 (Qvoid_variable
, symbol
);
1074 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1075 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1076 (register Lisp_Object symbol
, Lisp_Object newval
)
1078 set_internal (symbol
, newval
, Qnil
, 0);
1082 /* Return true if SYMBOL currently has a let-binding
1083 which was made in the buffer that is now current. */
1086 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1088 struct specbinding
*p
;
1090 for (p
= specpdl_ptr
; p
> specpdl
; )
1091 if ((--p
)->func
== NULL
1092 && CONSP (p
->symbol
))
1094 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1095 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1096 if (symbol
== let_bound_symbol
1097 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1105 let_shadows_global_binding_p (Lisp_Object symbol
)
1107 struct specbinding
*p
;
1109 for (p
= specpdl_ptr
; p
> specpdl
; )
1110 if ((--p
)->func
== NULL
&& EQ (p
->symbol
, symbol
))
1116 /* Store the value NEWVAL into SYMBOL.
1117 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1118 (nil stands for the current buffer/frame).
1120 If BINDFLAG is false, then if this symbol is supposed to become
1121 local in every buffer where it is set, then we make it local.
1122 If BINDFLAG is true, we don't do that. */
1125 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1128 bool voide
= EQ (newval
, Qunbound
);
1129 struct Lisp_Symbol
*sym
;
1132 /* If restoring in a dead buffer, do nothing. */
1133 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1136 CHECK_SYMBOL (symbol
);
1137 if (SYMBOL_CONSTANT_P (symbol
))
1139 if (NILP (Fkeywordp (symbol
))
1140 || !EQ (newval
, Fsymbol_value (symbol
)))
1141 xsignal1 (Qsetting_constant
, symbol
);
1143 /* Allow setting keywords to their own value. */
1147 sym
= XSYMBOL (symbol
);
1150 switch (sym
->redirect
)
1152 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1153 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1154 case SYMBOL_LOCALIZED
:
1156 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1159 if (blv
->frame_local
)
1160 where
= selected_frame
;
1162 XSETBUFFER (where
, current_buffer
);
1164 /* If the current buffer is not the buffer whose binding is
1165 loaded, or if there may be frame-local bindings and the frame
1166 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1167 the default binding is loaded, the loaded binding may be the
1169 if (!EQ (blv
->where
, where
)
1170 /* Also unload a global binding (if the var is local_if_set). */
1171 || (EQ (blv
->valcell
, blv
->defcell
)))
1173 /* The currently loaded binding is not necessarily valid.
1174 We need to unload it, and choose a new binding. */
1176 /* Write out `realvalue' to the old loaded binding. */
1178 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1180 /* Find the new binding. */
1181 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1182 tem1
= Fassq (symbol
,
1184 ? XFRAME (where
)->param_alist
1185 : BVAR (XBUFFER (where
), local_var_alist
)));
1186 set_blv_where (blv
, where
);
1191 /* This buffer still sees the default value. */
1193 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1194 or if this is `let' rather than `set',
1195 make CURRENT-ALIST-ELEMENT point to itself,
1196 indicating that we're seeing the default value.
1197 Likewise if the variable has been let-bound
1198 in the current buffer. */
1199 if (bindflag
|| !blv
->local_if_set
1200 || let_shadows_buffer_binding_p (sym
))
1203 tem1
= blv
->defcell
;
1205 /* If it's a local_if_set, being set not bound,
1206 and we're not within a let that was made for this buffer,
1207 create a new buffer-local binding for the variable.
1208 That means, give this buffer a new assoc for a local value
1209 and load that binding. */
1212 /* local_if_set is only supported for buffer-local
1213 bindings, not for frame-local bindings. */
1214 eassert (!blv
->frame_local
);
1215 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1216 bset_local_var_alist
1218 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1222 /* Record which binding is now loaded. */
1223 set_blv_valcell (blv
, tem1
);
1226 /* Store the new value in the cons cell. */
1227 set_blv_value (blv
, newval
);
1232 /* If storing void (making the symbol void), forward only through
1233 buffer-local indicator, not through Lisp_Objfwd, etc. */
1236 store_symval_forwarding (blv
->fwd
, newval
,
1238 ? XBUFFER (where
) : current_buffer
);
1242 case SYMBOL_FORWARDED
:
1245 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1246 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1247 if (BUFFER_OBJFWDP (innercontents
))
1249 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1250 int idx
= PER_BUFFER_IDX (offset
);
1253 && !let_shadows_buffer_binding_p (sym
))
1254 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1258 { /* If storing void (making the symbol void), forward only through
1259 buffer-local indicator, not through Lisp_Objfwd, etc. */
1260 sym
->redirect
= SYMBOL_PLAINVAL
;
1261 SET_SYMBOL_VAL (sym
, newval
);
1264 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1267 default: emacs_abort ();
1272 /* Access or set a buffer-local symbol's default value. */
1274 /* Return the default value of SYMBOL, but don't check for voidness.
1275 Return Qunbound if it is void. */
1278 default_value (Lisp_Object symbol
)
1280 struct Lisp_Symbol
*sym
;
1282 CHECK_SYMBOL (symbol
);
1283 sym
= XSYMBOL (symbol
);
1286 switch (sym
->redirect
)
1288 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1289 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1290 case SYMBOL_LOCALIZED
:
1292 /* If var is set up for a buffer that lacks a local value for it,
1293 the current value is nominally the default value.
1294 But the `realvalue' slot may be more up to date, since
1295 ordinary setq stores just that slot. So use that. */
1296 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1297 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1298 return do_symval_forwarding (blv
->fwd
);
1300 return XCDR (blv
->defcell
);
1302 case SYMBOL_FORWARDED
:
1304 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1306 /* For a built-in buffer-local variable, get the default value
1307 rather than letting do_symval_forwarding get the current value. */
1308 if (BUFFER_OBJFWDP (valcontents
))
1310 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1311 if (PER_BUFFER_IDX (offset
) != 0)
1312 return per_buffer_default (offset
);
1315 /* For other variables, get the current value. */
1316 return do_symval_forwarding (valcontents
);
1318 default: emacs_abort ();
1322 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1323 doc
: /* Return t if SYMBOL has a non-void default value.
1324 This is the value that is seen in buffers that do not have their own values
1325 for this variable. */)
1326 (Lisp_Object symbol
)
1328 register Lisp_Object value
;
1330 value
= default_value (symbol
);
1331 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1334 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1335 doc
: /* Return SYMBOL's default value.
1336 This is the value that is seen in buffers that do not have their own values
1337 for this variable. The default value is meaningful for variables with
1338 local bindings in certain buffers. */)
1339 (Lisp_Object symbol
)
1341 register Lisp_Object value
;
1343 value
= default_value (symbol
);
1344 if (!EQ (value
, Qunbound
))
1347 xsignal1 (Qvoid_variable
, symbol
);
1350 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1351 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1352 The default value is seen in buffers that do not have their own values
1353 for this variable. */)
1354 (Lisp_Object symbol
, Lisp_Object value
)
1356 struct Lisp_Symbol
*sym
;
1358 CHECK_SYMBOL (symbol
);
1359 if (SYMBOL_CONSTANT_P (symbol
))
1361 if (NILP (Fkeywordp (symbol
))
1362 || !EQ (value
, Fdefault_value (symbol
)))
1363 xsignal1 (Qsetting_constant
, symbol
);
1365 /* Allow setting keywords to their own value. */
1368 sym
= XSYMBOL (symbol
);
1371 switch (sym
->redirect
)
1373 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1374 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1375 case SYMBOL_LOCALIZED
:
1377 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1379 /* Store new value into the DEFAULT-VALUE slot. */
1380 XSETCDR (blv
->defcell
, value
);
1382 /* If the default binding is now loaded, set the REALVALUE slot too. */
1383 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1384 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1387 case SYMBOL_FORWARDED
:
1389 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1391 /* Handle variables like case-fold-search that have special slots
1393 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1394 if (BUFFER_OBJFWDP (valcontents
))
1396 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1397 int idx
= PER_BUFFER_IDX (offset
);
1399 set_per_buffer_default (offset
, value
);
1401 /* If this variable is not always local in all buffers,
1402 set it in the buffers that don't nominally have a local value. */
1408 if (!PER_BUFFER_VALUE_P (b
, idx
))
1409 set_per_buffer_value (b
, offset
, value
);
1414 return Fset (symbol
, value
);
1416 default: emacs_abort ();
1420 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1421 doc
: /* Set the default value of variable VAR to VALUE.
1422 VAR, the variable name, is literal (not evaluated);
1423 VALUE is an expression: it is evaluated and its value returned.
1424 The default value of a variable is seen in buffers
1425 that do not have their own values for the variable.
1427 More generally, you can use multiple variables and values, as in
1428 (setq-default VAR VALUE VAR VALUE...)
1429 This sets each VAR's default value to the corresponding VALUE.
1430 The VALUE for the Nth VAR can refer to the new default values
1432 usage: (setq-default [VAR VALUE]...) */)
1435 register Lisp_Object args_left
;
1436 register Lisp_Object val
, symbol
;
1437 struct gcpro gcpro1
;
1447 val
= eval_sub (Fcar (Fcdr (args_left
)));
1448 symbol
= XCAR (args_left
);
1449 Fset_default (symbol
, val
);
1450 args_left
= Fcdr (XCDR (args_left
));
1452 while (!NILP (args_left
));
1458 /* Lisp functions for creating and removing buffer-local variables. */
1463 union Lisp_Fwd
*fwd
;
1466 static struct Lisp_Buffer_Local_Value
*
1467 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1468 union Lisp_Val_Fwd valcontents
)
1470 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1474 XSETSYMBOL (symbol
, sym
);
1475 tem
= Fcons (symbol
, (forwarded
1476 ? do_symval_forwarding (valcontents
.fwd
)
1477 : valcontents
.value
));
1479 /* Buffer_Local_Values cannot have as realval a buffer-local
1480 or keyboard-local forwarding. */
1481 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1482 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1483 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1484 set_blv_where (blv
, Qnil
);
1485 blv
->frame_local
= 0;
1486 blv
->local_if_set
= 0;
1487 set_blv_defcell (blv
, tem
);
1488 set_blv_valcell (blv
, tem
);
1489 set_blv_found (blv
, 0);
1493 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1494 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1495 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1496 At any time, the value for the current buffer is in effect,
1497 unless the variable has never been set in this buffer,
1498 in which case the default value is in effect.
1499 Note that binding the variable with `let', or setting it while
1500 a `let'-style binding made in this buffer is in effect,
1501 does not make the variable buffer-local. Return VARIABLE.
1503 In most cases it is better to use `make-local-variable',
1504 which makes a variable local in just one buffer.
1506 The function `default-value' gets the default value and `set-default' sets it. */)
1507 (register Lisp_Object variable
)
1509 struct Lisp_Symbol
*sym
;
1510 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1511 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1512 bool forwarded
IF_LINT (= 0);
1514 CHECK_SYMBOL (variable
);
1515 sym
= XSYMBOL (variable
);
1518 switch (sym
->redirect
)
1520 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1521 case SYMBOL_PLAINVAL
:
1522 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1523 if (EQ (valcontents
.value
, Qunbound
))
1524 valcontents
.value
= Qnil
;
1526 case SYMBOL_LOCALIZED
:
1527 blv
= SYMBOL_BLV (sym
);
1528 if (blv
->frame_local
)
1529 error ("Symbol %s may not be buffer-local",
1530 SDATA (SYMBOL_NAME (variable
)));
1532 case SYMBOL_FORWARDED
:
1533 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1534 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1535 error ("Symbol %s may not be buffer-local",
1536 SDATA (SYMBOL_NAME (variable
)));
1537 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1540 default: emacs_abort ();
1544 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1548 blv
= make_blv (sym
, forwarded
, valcontents
);
1549 sym
->redirect
= SYMBOL_LOCALIZED
;
1550 SET_SYMBOL_BLV (sym
, blv
);
1553 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1554 if (let_shadows_global_binding_p (symbol
))
1555 message ("Making %s buffer-local while let-bound!",
1556 SDATA (SYMBOL_NAME (variable
)));
1560 blv
->local_if_set
= 1;
1564 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1565 1, 1, "vMake Local Variable: ",
1566 doc
: /* Make VARIABLE have a separate value in the current buffer.
1567 Other buffers will continue to share a common default value.
1568 \(The buffer-local value of VARIABLE starts out as the same value
1569 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1572 If the variable is already arranged to become local when set,
1573 this function causes a local value to exist for this buffer,
1574 just as setting the variable would do.
1576 This function returns VARIABLE, and therefore
1577 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1580 See also `make-variable-buffer-local'.
1582 Do not use `make-local-variable' to make a hook variable buffer-local.
1583 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1584 (Lisp_Object variable
)
1587 bool forwarded
IF_LINT (= 0);
1588 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1589 struct Lisp_Symbol
*sym
;
1590 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1592 CHECK_SYMBOL (variable
);
1593 sym
= XSYMBOL (variable
);
1596 switch (sym
->redirect
)
1598 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1599 case SYMBOL_PLAINVAL
:
1600 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1601 case SYMBOL_LOCALIZED
:
1602 blv
= SYMBOL_BLV (sym
);
1603 if (blv
->frame_local
)
1604 error ("Symbol %s may not be buffer-local",
1605 SDATA (SYMBOL_NAME (variable
)));
1607 case SYMBOL_FORWARDED
:
1608 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1609 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1610 error ("Symbol %s may not be buffer-local",
1611 SDATA (SYMBOL_NAME (variable
)));
1613 default: emacs_abort ();
1617 error ("Symbol %s may not be buffer-local",
1618 SDATA (SYMBOL_NAME (variable
)));
1620 if (blv
? blv
->local_if_set
1621 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1623 tem
= Fboundp (variable
);
1624 /* Make sure the symbol has a local value in this particular buffer,
1625 by setting it to the same value it already has. */
1626 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1631 blv
= make_blv (sym
, forwarded
, valcontents
);
1632 sym
->redirect
= SYMBOL_LOCALIZED
;
1633 SET_SYMBOL_BLV (sym
, blv
);
1636 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1637 if (let_shadows_global_binding_p (symbol
))
1638 message ("Making %s local to %s while let-bound!",
1639 SDATA (SYMBOL_NAME (variable
)),
1640 SDATA (BVAR (current_buffer
, name
)));
1644 /* Make sure this buffer has its own value of symbol. */
1645 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1646 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1649 if (let_shadows_buffer_binding_p (sym
))
1650 message ("Making %s buffer-local while locally let-bound!",
1651 SDATA (SYMBOL_NAME (variable
)));
1653 /* Swap out any local binding for some other buffer, and make
1654 sure the current value is permanently recorded, if it's the
1656 find_symbol_value (variable
);
1658 bset_local_var_alist
1660 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1661 BVAR (current_buffer
, local_var_alist
)));
1663 /* Make sure symbol does not think it is set up for this buffer;
1664 force it to look once again for this buffer's value. */
1665 if (current_buffer
== XBUFFER (blv
->where
))
1666 set_blv_where (blv
, Qnil
);
1667 set_blv_found (blv
, 0);
1670 /* If the symbol forwards into a C variable, then load the binding
1671 for this buffer now. If C code modifies the variable before we
1672 load the binding in, then that new value will clobber the default
1673 binding the next time we unload it. */
1675 swap_in_symval_forwarding (sym
, blv
);
1680 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1681 1, 1, "vKill Local Variable: ",
1682 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1683 From now on the default value will apply in this buffer. Return VARIABLE. */)
1684 (register Lisp_Object variable
)
1686 register Lisp_Object tem
;
1687 struct Lisp_Buffer_Local_Value
*blv
;
1688 struct Lisp_Symbol
*sym
;
1690 CHECK_SYMBOL (variable
);
1691 sym
= XSYMBOL (variable
);
1694 switch (sym
->redirect
)
1696 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1697 case SYMBOL_PLAINVAL
: return variable
;
1698 case SYMBOL_FORWARDED
:
1700 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1701 if (BUFFER_OBJFWDP (valcontents
))
1703 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1704 int idx
= PER_BUFFER_IDX (offset
);
1708 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1709 set_per_buffer_value (current_buffer
, offset
,
1710 per_buffer_default (offset
));
1715 case SYMBOL_LOCALIZED
:
1716 blv
= SYMBOL_BLV (sym
);
1717 if (blv
->frame_local
)
1720 default: emacs_abort ();
1723 /* Get rid of this buffer's alist element, if any. */
1724 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1725 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1727 bset_local_var_alist
1729 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1731 /* If the symbol is set up with the current buffer's binding
1732 loaded, recompute its value. We have to do it now, or else
1733 forwarded objects won't work right. */
1735 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1736 if (EQ (buf
, blv
->where
))
1738 set_blv_where (blv
, Qnil
);
1740 find_symbol_value (variable
);
1747 /* Lisp functions for creating and removing buffer-local variables. */
1749 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1750 when/if this is removed. */
1752 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1753 1, 1, "vMake Variable Frame Local: ",
1754 doc
: /* Enable VARIABLE to have frame-local bindings.
1755 This does not create any frame-local bindings for VARIABLE,
1756 it just makes them possible.
1758 A frame-local binding is actually a frame parameter value.
1759 If a frame F has a value for the frame parameter named VARIABLE,
1760 that also acts as a frame-local binding for VARIABLE in F--
1761 provided this function has been called to enable VARIABLE
1762 to have frame-local bindings at all.
1764 The only way to create a frame-local binding for VARIABLE in a frame
1765 is to set the VARIABLE frame parameter of that frame. See
1766 `modify-frame-parameters' for how to set frame parameters.
1768 Note that since Emacs 23.1, variables cannot be both buffer-local and
1769 frame-local any more (buffer-local bindings used to take precedence over
1770 frame-local bindings). */)
1771 (Lisp_Object variable
)
1774 union Lisp_Val_Fwd valcontents
;
1775 struct Lisp_Symbol
*sym
;
1776 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1778 CHECK_SYMBOL (variable
);
1779 sym
= XSYMBOL (variable
);
1782 switch (sym
->redirect
)
1784 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1785 case SYMBOL_PLAINVAL
:
1786 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1787 if (EQ (valcontents
.value
, Qunbound
))
1788 valcontents
.value
= Qnil
;
1790 case SYMBOL_LOCALIZED
:
1791 if (SYMBOL_BLV (sym
)->frame_local
)
1794 error ("Symbol %s may not be frame-local",
1795 SDATA (SYMBOL_NAME (variable
)));
1796 case SYMBOL_FORWARDED
:
1797 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1798 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1799 error ("Symbol %s may not be frame-local",
1800 SDATA (SYMBOL_NAME (variable
)));
1802 default: emacs_abort ();
1806 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1808 blv
= make_blv (sym
, forwarded
, valcontents
);
1809 blv
->frame_local
= 1;
1810 sym
->redirect
= SYMBOL_LOCALIZED
;
1811 SET_SYMBOL_BLV (sym
, blv
);
1814 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1815 if (let_shadows_global_binding_p (symbol
))
1816 message ("Making %s frame-local while let-bound!",
1817 SDATA (SYMBOL_NAME (variable
)));
1822 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1824 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1825 BUFFER defaults to the current buffer. */)
1826 (register Lisp_Object variable
, Lisp_Object buffer
)
1828 register struct buffer
*buf
;
1829 struct Lisp_Symbol
*sym
;
1832 buf
= current_buffer
;
1835 CHECK_BUFFER (buffer
);
1836 buf
= XBUFFER (buffer
);
1839 CHECK_SYMBOL (variable
);
1840 sym
= XSYMBOL (variable
);
1843 switch (sym
->redirect
)
1845 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1846 case SYMBOL_PLAINVAL
: return Qnil
;
1847 case SYMBOL_LOCALIZED
:
1849 Lisp_Object tail
, elt
, tmp
;
1850 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1851 XSETBUFFER (tmp
, buf
);
1852 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1854 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1857 if (EQ (variable
, XCAR (elt
)))
1859 eassert (!blv
->frame_local
);
1860 eassert (blv_found (blv
) || !EQ (blv
->where
, tmp
));
1864 eassert (!blv_found (blv
) || !EQ (blv
->where
, tmp
));
1867 case SYMBOL_FORWARDED
:
1869 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1870 if (BUFFER_OBJFWDP (valcontents
))
1872 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1873 int idx
= PER_BUFFER_IDX (offset
);
1874 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1879 default: emacs_abort ();
1883 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1885 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1886 More precisely, this means that setting the variable \(with `set' or`setq'),
1887 while it does not have a `let'-style binding that was made in BUFFER,
1888 will produce a buffer local binding. See Info node
1889 `(elisp)Creating Buffer-Local'.
1890 BUFFER defaults to the current buffer. */)
1891 (register Lisp_Object variable
, Lisp_Object buffer
)
1893 struct Lisp_Symbol
*sym
;
1895 CHECK_SYMBOL (variable
);
1896 sym
= XSYMBOL (variable
);
1899 switch (sym
->redirect
)
1901 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1902 case SYMBOL_PLAINVAL
: return Qnil
;
1903 case SYMBOL_LOCALIZED
:
1905 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1906 if (blv
->local_if_set
)
1908 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1909 return Flocal_variable_p (variable
, buffer
);
1911 case SYMBOL_FORWARDED
:
1912 /* All BUFFER_OBJFWD slots become local if they are set. */
1913 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1914 default: emacs_abort ();
1918 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1920 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1921 If the current binding is buffer-local, the value is the current buffer.
1922 If the current binding is frame-local, the value is the selected frame.
1923 If the current binding is global (the default), the value is nil. */)
1924 (register Lisp_Object variable
)
1926 struct Lisp_Symbol
*sym
;
1928 CHECK_SYMBOL (variable
);
1929 sym
= XSYMBOL (variable
);
1931 /* Make sure the current binding is actually swapped in. */
1932 find_symbol_value (variable
);
1935 switch (sym
->redirect
)
1937 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1938 case SYMBOL_PLAINVAL
: return Qnil
;
1939 case SYMBOL_FORWARDED
:
1941 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1942 if (KBOARD_OBJFWDP (valcontents
))
1943 return Fframe_terminal (Fselected_frame ());
1944 else if (!BUFFER_OBJFWDP (valcontents
))
1948 case SYMBOL_LOCALIZED
:
1949 /* For a local variable, record both the symbol and which
1950 buffer's or frame's value we are saving. */
1951 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1952 return Fcurrent_buffer ();
1953 else if (sym
->redirect
== SYMBOL_LOCALIZED
1954 && blv_found (SYMBOL_BLV (sym
)))
1955 return SYMBOL_BLV (sym
)->where
;
1958 default: emacs_abort ();
1962 /* This code is disabled now that we use the selected frame to return
1963 keyboard-local-values. */
1965 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1967 DEFUN ("terminal-local-value", Fterminal_local_value
,
1968 Sterminal_local_value
, 2, 2, 0,
1969 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1970 If SYMBOL is not a terminal-local variable, then return its normal
1971 value, like `symbol-value'.
1973 TERMINAL may be a terminal object, a frame, or nil (meaning the
1974 selected frame's terminal device). */)
1975 (Lisp_Object symbol
, Lisp_Object terminal
)
1978 struct terminal
*t
= get_terminal (terminal
, 1);
1979 push_kboard (t
->kboard
);
1980 result
= Fsymbol_value (symbol
);
1985 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1986 Sset_terminal_local_value
, 3, 3, 0,
1987 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1988 If VARIABLE is not a terminal-local variable, then set its normal
1989 binding, like `set'.
1991 TERMINAL may be a terminal object, a frame, or nil (meaning the
1992 selected frame's terminal device). */)
1993 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1996 struct terminal
*t
= get_terminal (terminal
, 1);
1997 push_kboard (d
->kboard
);
1998 result
= Fset (symbol
, value
);
2004 /* Find the function at the end of a chain of symbol function indirections. */
2006 /* If OBJECT is a symbol, find the end of its function chain and
2007 return the value found there. If OBJECT is not a symbol, just
2008 return it. If there is a cycle in the function chain, signal a
2009 cyclic-function-indirection error.
2011 This is like Findirect_function, except that it doesn't signal an
2012 error if the chain ends up unbound. */
2014 indirect_function (register Lisp_Object object
)
2016 Lisp_Object tortoise
, hare
;
2018 hare
= tortoise
= object
;
2022 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2024 hare
= XSYMBOL (hare
)->function
;
2025 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2027 hare
= XSYMBOL (hare
)->function
;
2029 tortoise
= XSYMBOL (tortoise
)->function
;
2031 if (EQ (hare
, tortoise
))
2032 xsignal1 (Qcyclic_function_indirection
, object
);
2038 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2039 doc
: /* Return the function at the end of OBJECT's function chain.
2040 If OBJECT is not a symbol, just return it. Otherwise, follow all
2041 function indirections to find the final function binding and return it.
2042 If the final symbol in the chain is unbound, signal a void-function error.
2043 Optional arg NOERROR non-nil means to return nil instead of signaling.
2044 Signal a cyclic-function-indirection error if there is a loop in the
2045 function chain of symbols. */)
2046 (register Lisp_Object object
, Lisp_Object noerror
)
2050 /* Optimize for no indirection. */
2052 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2053 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2054 result
= indirect_function (result
);
2055 if (!EQ (result
, Qunbound
))
2059 xsignal1 (Qvoid_function
, object
);
2064 /* Extract and set vector and string elements. */
2066 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2067 doc
: /* Return the element of ARRAY at index IDX.
2068 ARRAY may be a vector, a string, a char-table, a bool-vector,
2069 or a byte-code object. IDX starts at 0. */)
2070 (register Lisp_Object array
, Lisp_Object idx
)
2072 register EMACS_INT idxval
;
2075 idxval
= XINT (idx
);
2076 if (STRINGP (array
))
2079 ptrdiff_t idxval_byte
;
2081 if (idxval
< 0 || idxval
>= SCHARS (array
))
2082 args_out_of_range (array
, idx
);
2083 if (! STRING_MULTIBYTE (array
))
2084 return make_number ((unsigned char) SREF (array
, idxval
));
2085 idxval_byte
= string_char_to_byte (array
, idxval
);
2087 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2088 return make_number (c
);
2090 else if (BOOL_VECTOR_P (array
))
2094 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2095 args_out_of_range (array
, idx
);
2097 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2098 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2100 else if (CHAR_TABLE_P (array
))
2102 CHECK_CHARACTER (idx
);
2103 return CHAR_TABLE_REF (array
, idxval
);
2108 if (VECTORP (array
))
2109 size
= ASIZE (array
);
2110 else if (COMPILEDP (array
))
2111 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2113 wrong_type_argument (Qarrayp
, array
);
2115 if (idxval
< 0 || idxval
>= size
)
2116 args_out_of_range (array
, idx
);
2117 return AREF (array
, idxval
);
2121 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2122 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2123 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2124 bool-vector. IDX starts at 0. */)
2125 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2127 register EMACS_INT idxval
;
2130 idxval
= XINT (idx
);
2131 CHECK_ARRAY (array
, Qarrayp
);
2132 CHECK_IMPURE (array
);
2134 if (VECTORP (array
))
2136 if (idxval
< 0 || idxval
>= ASIZE (array
))
2137 args_out_of_range (array
, idx
);
2138 ASET (array
, idxval
, newelt
);
2140 else if (BOOL_VECTOR_P (array
))
2144 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2145 args_out_of_range (array
, idx
);
2147 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2149 if (! NILP (newelt
))
2150 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2152 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2153 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2155 else if (CHAR_TABLE_P (array
))
2157 CHECK_CHARACTER (idx
);
2158 CHAR_TABLE_SET (array
, idxval
, newelt
);
2164 if (idxval
< 0 || idxval
>= SCHARS (array
))
2165 args_out_of_range (array
, idx
);
2166 CHECK_CHARACTER (newelt
);
2167 c
= XFASTINT (newelt
);
2169 if (STRING_MULTIBYTE (array
))
2171 ptrdiff_t idxval_byte
, nbytes
;
2172 int prev_bytes
, new_bytes
;
2173 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2175 nbytes
= SBYTES (array
);
2176 idxval_byte
= string_char_to_byte (array
, idxval
);
2177 p1
= SDATA (array
) + idxval_byte
;
2178 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2179 new_bytes
= CHAR_STRING (c
, p0
);
2180 if (prev_bytes
!= new_bytes
)
2182 /* We must relocate the string data. */
2183 ptrdiff_t nchars
= SCHARS (array
);
2185 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2187 memcpy (str
, SDATA (array
), nbytes
);
2188 allocate_string_data (XSTRING (array
), nchars
,
2189 nbytes
+ new_bytes
- prev_bytes
);
2190 memcpy (SDATA (array
), str
, idxval_byte
);
2191 p1
= SDATA (array
) + idxval_byte
;
2192 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2193 nbytes
- (idxval_byte
+ prev_bytes
));
2195 clear_string_char_byte_cache ();
2202 if (! SINGLE_BYTE_CHAR_P (c
))
2206 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2207 if (SREF (array
, i
) >= 0x80)
2208 args_out_of_range (array
, newelt
);
2209 /* ARRAY is an ASCII string. Convert it to a multibyte
2210 string, and try `aset' again. */
2211 STRING_SET_MULTIBYTE (array
);
2212 return Faset (array
, idx
, newelt
);
2214 SSET (array
, idxval
, c
);
2221 /* Arithmetic functions */
2223 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2226 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2228 double f1
= 0, f2
= 0;
2231 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2232 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2234 if (FLOATP (num1
) || FLOATP (num2
))
2237 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2238 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2244 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2249 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2254 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2259 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2264 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2269 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2278 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2279 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2280 (register Lisp_Object num1
, Lisp_Object num2
)
2282 return arithcompare (num1
, num2
, equal
);
2285 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2286 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2287 (register Lisp_Object num1
, Lisp_Object num2
)
2289 return arithcompare (num1
, num2
, less
);
2292 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2293 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2294 (register Lisp_Object num1
, Lisp_Object num2
)
2296 return arithcompare (num1
, num2
, grtr
);
2299 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2300 doc
: /* Return t if first arg is less than or equal to second arg.
2301 Both must be numbers or markers. */)
2302 (register Lisp_Object num1
, Lisp_Object num2
)
2304 return arithcompare (num1
, num2
, less_or_equal
);
2307 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2308 doc
: /* Return t if first arg is greater than or equal to second arg.
2309 Both must be numbers or markers. */)
2310 (register Lisp_Object num1
, Lisp_Object num2
)
2312 return arithcompare (num1
, num2
, grtr_or_equal
);
2315 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2316 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2317 (register Lisp_Object num1
, Lisp_Object num2
)
2319 return arithcompare (num1
, num2
, notequal
);
2322 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2323 doc
: /* Return t if NUMBER is zero. */)
2324 (register Lisp_Object number
)
2326 CHECK_NUMBER_OR_FLOAT (number
);
2328 if (FLOATP (number
))
2330 if (XFLOAT_DATA (number
) == 0.0)
2340 /* Convert the cons-of-integers, integer, or float value C to an
2341 unsigned value with maximum value MAX. Signal an error if C does not
2342 have a valid format or is out of range. */
2344 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2347 uintmax_t val
IF_LINT (= 0);
2350 valid
= 0 <= XINT (c
);
2353 else if (FLOATP (c
))
2355 double d
= XFLOAT_DATA (c
);
2357 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2363 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2365 uintmax_t top
= XFASTINT (XCAR (c
));
2366 Lisp_Object rest
= XCDR (c
);
2367 if (top
<= UINTMAX_MAX
>> 24 >> 16
2369 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2370 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2372 uintmax_t mid
= XFASTINT (XCAR (rest
));
2373 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2376 else if (top
<= UINTMAX_MAX
>> 16)
2380 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2382 val
= top
<< 16 | XFASTINT (rest
);
2388 if (! (valid
&& val
<= max
))
2389 error ("Not an in-range integer, float, or cons of integers");
2393 /* Convert the cons-of-integers, integer, or float value C to a signed
2394 value with extrema MIN and MAX. Signal an error if C does not have
2395 a valid format or is out of range. */
2397 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2400 intmax_t val
IF_LINT (= 0);
2406 else if (FLOATP (c
))
2408 double d
= XFLOAT_DATA (c
);
2410 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2416 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2418 intmax_t top
= XINT (XCAR (c
));
2419 Lisp_Object rest
= XCDR (c
);
2420 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2422 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2423 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2425 intmax_t mid
= XFASTINT (XCAR (rest
));
2426 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2429 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2433 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2435 val
= top
<< 16 | XFASTINT (rest
);
2441 if (! (valid
&& min
<= val
&& val
<= max
))
2442 error ("Not an in-range integer, float, or cons of integers");
2446 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2447 doc
: /* Return the decimal representation of NUMBER as a string.
2448 Uses a minus sign if negative.
2449 NUMBER may be an integer or a floating point number. */)
2450 (Lisp_Object number
)
2452 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2455 CHECK_NUMBER_OR_FLOAT (number
);
2457 if (FLOATP (number
))
2458 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2460 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2462 return make_unibyte_string (buffer
, len
);
2465 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2466 doc
: /* Parse STRING as a decimal number and return the number.
2467 This parses both integers and floating point numbers.
2468 It ignores leading spaces and tabs, and all trailing chars.
2470 If BASE, interpret STRING as a number in that base. If BASE isn't
2471 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2472 If the base used is not 10, STRING is always parsed as integer. */)
2473 (register Lisp_Object string
, Lisp_Object base
)
2479 CHECK_STRING (string
);
2485 CHECK_NUMBER (base
);
2486 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2487 xsignal1 (Qargs_out_of_range
, base
);
2491 p
= SSDATA (string
);
2492 while (*p
== ' ' || *p
== '\t')
2495 val
= string_to_number (p
, b
, 1);
2496 return NILP (val
) ? make_number (0) : val
;
2512 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2513 ptrdiff_t, Lisp_Object
*);
2515 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2518 ptrdiff_t argnum
, ok_args
;
2519 EMACS_INT accum
= 0;
2520 EMACS_INT next
, ok_accum
;
2541 for (argnum
= 0; argnum
< nargs
; argnum
++)
2549 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2551 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2554 return float_arith_driver (ok_accum
, ok_args
, code
,
2557 next
= XINT (args
[argnum
]);
2561 if (INT_ADD_OVERFLOW (accum
, next
))
2569 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2574 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2577 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2579 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2581 accum
= ab
& INTMASK
;
2592 xsignal0 (Qarith_error
);
2606 if (!argnum
|| next
> accum
)
2610 if (!argnum
|| next
< accum
)
2616 XSETINT (val
, accum
);
2621 #define isnan(x) ((x) != (x))
2624 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2625 ptrdiff_t nargs
, Lisp_Object
*args
)
2627 register Lisp_Object val
;
2630 for (; argnum
< nargs
; argnum
++)
2632 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2633 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2637 next
= XFLOAT_DATA (val
);
2641 args
[argnum
] = val
; /* runs into a compiler bug. */
2642 next
= XINT (args
[argnum
]);
2650 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2660 if (! IEEE_FLOATING_POINT
&& next
== 0)
2661 xsignal0 (Qarith_error
);
2668 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2670 if (!argnum
|| isnan (next
) || next
> accum
)
2674 if (!argnum
|| isnan (next
) || next
< accum
)
2680 return make_float (accum
);
2684 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2685 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2686 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2687 (ptrdiff_t nargs
, Lisp_Object
*args
)
2689 return arith_driver (Aadd
, nargs
, args
);
2692 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2693 doc
: /* Negate number or subtract numbers or markers and return the result.
2694 With one arg, negates it. With more than one arg,
2695 subtracts all but the first from the first.
2696 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2697 (ptrdiff_t nargs
, Lisp_Object
*args
)
2699 return arith_driver (Asub
, nargs
, args
);
2702 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2703 doc
: /* Return product of any number of arguments, which are numbers or markers.
2704 usage: (* &rest NUMBERS-OR-MARKERS) */)
2705 (ptrdiff_t nargs
, Lisp_Object
*args
)
2707 return arith_driver (Amult
, nargs
, args
);
2710 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2711 doc
: /* Return first argument divided by all the remaining arguments.
2712 The arguments must be numbers or markers.
2713 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2714 (ptrdiff_t nargs
, Lisp_Object
*args
)
2717 for (argnum
= 2; argnum
< nargs
; argnum
++)
2718 if (FLOATP (args
[argnum
]))
2719 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2720 return arith_driver (Adiv
, nargs
, args
);
2723 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2724 doc
: /* Return remainder of X divided by Y.
2725 Both must be integers or markers. */)
2726 (register Lisp_Object x
, Lisp_Object y
)
2730 CHECK_NUMBER_COERCE_MARKER (x
);
2731 CHECK_NUMBER_COERCE_MARKER (y
);
2734 xsignal0 (Qarith_error
);
2736 XSETINT (val
, XINT (x
) % XINT (y
));
2742 fmod (double f1
, double f2
)
2749 /* If the magnitude of the result exceeds that of the divisor, or
2750 the sign of the result does not agree with that of the dividend,
2751 iterate with the reduced value. This does not yield a
2752 particularly accurate result, but at least it will be in the
2753 range promised by fmod. */
2755 r
-= f2
* floor (r
/ f2
);
2756 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2760 #endif /* ! HAVE_FMOD */
2762 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2763 doc
: /* Return X modulo Y.
2764 The result falls between zero (inclusive) and Y (exclusive).
2765 Both X and Y must be numbers or markers. */)
2766 (register Lisp_Object x
, Lisp_Object y
)
2771 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2772 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2774 if (FLOATP (x
) || FLOATP (y
))
2775 return fmod_float (x
, y
);
2781 xsignal0 (Qarith_error
);
2785 /* If the "remainder" comes out with the wrong sign, fix it. */
2786 if (i2
< 0 ? i1
> 0 : i1
< 0)
2793 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2794 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2795 The value is always a number; markers are converted to numbers.
2796 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2797 (ptrdiff_t nargs
, Lisp_Object
*args
)
2799 return arith_driver (Amax
, nargs
, args
);
2802 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2803 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2804 The value is always a number; markers are converted to numbers.
2805 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2806 (ptrdiff_t nargs
, Lisp_Object
*args
)
2808 return arith_driver (Amin
, nargs
, args
);
2811 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2812 doc
: /* Return bitwise-and of all the arguments.
2813 Arguments may be integers, or markers converted to integers.
2814 usage: (logand &rest INTS-OR-MARKERS) */)
2815 (ptrdiff_t nargs
, Lisp_Object
*args
)
2817 return arith_driver (Alogand
, nargs
, args
);
2820 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2821 doc
: /* Return bitwise-or of all the arguments.
2822 Arguments may be integers, or markers converted to integers.
2823 usage: (logior &rest INTS-OR-MARKERS) */)
2824 (ptrdiff_t nargs
, Lisp_Object
*args
)
2826 return arith_driver (Alogior
, nargs
, args
);
2829 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2830 doc
: /* Return bitwise-exclusive-or of all the arguments.
2831 Arguments may be integers, or markers converted to integers.
2832 usage: (logxor &rest INTS-OR-MARKERS) */)
2833 (ptrdiff_t nargs
, Lisp_Object
*args
)
2835 return arith_driver (Alogxor
, nargs
, args
);
2838 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2839 doc
: /* Return VALUE with its bits shifted left by COUNT.
2840 If COUNT is negative, shifting is actually to the right.
2841 In this case, the sign bit is duplicated. */)
2842 (register Lisp_Object value
, Lisp_Object count
)
2844 register Lisp_Object val
;
2846 CHECK_NUMBER (value
);
2847 CHECK_NUMBER (count
);
2849 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2851 else if (XINT (count
) > 0)
2852 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2853 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2854 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2856 XSETINT (val
, XINT (value
) >> -XINT (count
));
2860 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2861 doc
: /* Return VALUE with its bits shifted left by COUNT.
2862 If COUNT is negative, shifting is actually to the right.
2863 In this case, zeros are shifted in on the left. */)
2864 (register Lisp_Object value
, Lisp_Object count
)
2866 register Lisp_Object val
;
2868 CHECK_NUMBER (value
);
2869 CHECK_NUMBER (count
);
2871 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2873 else if (XINT (count
) > 0)
2874 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2875 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2878 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2882 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2883 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2884 Markers are converted to integers. */)
2885 (register Lisp_Object number
)
2887 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2889 if (FLOATP (number
))
2890 return (make_float (1.0 + XFLOAT_DATA (number
)));
2892 XSETINT (number
, XINT (number
) + 1);
2896 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2897 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2898 Markers are converted to integers. */)
2899 (register Lisp_Object number
)
2901 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2903 if (FLOATP (number
))
2904 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2906 XSETINT (number
, XINT (number
) - 1);
2910 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2911 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2912 (register Lisp_Object number
)
2914 CHECK_NUMBER (number
);
2915 XSETINT (number
, ~XINT (number
));
2919 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2920 doc
: /* Return the byteorder for the machine.
2921 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2922 lowercase l) for small endian machines. */)
2925 unsigned i
= 0x04030201;
2926 int order
= *(char *)&i
== 1 ? 108 : 66;
2928 return make_number (order
);
2936 Lisp_Object error_tail
, arith_tail
;
2938 DEFSYM (Qquote
, "quote");
2939 DEFSYM (Qlambda
, "lambda");
2940 DEFSYM (Qsubr
, "subr");
2941 DEFSYM (Qerror_conditions
, "error-conditions");
2942 DEFSYM (Qerror_message
, "error-message");
2943 DEFSYM (Qtop_level
, "top-level");
2945 DEFSYM (Qerror
, "error");
2946 DEFSYM (Quser_error
, "user-error");
2947 DEFSYM (Qquit
, "quit");
2948 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2949 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2950 DEFSYM (Qvoid_function
, "void-function");
2951 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2952 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2953 DEFSYM (Qvoid_variable
, "void-variable");
2954 DEFSYM (Qsetting_constant
, "setting-constant");
2955 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2957 DEFSYM (Qinvalid_function
, "invalid-function");
2958 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2959 DEFSYM (Qno_catch
, "no-catch");
2960 DEFSYM (Qend_of_file
, "end-of-file");
2961 DEFSYM (Qarith_error
, "arith-error");
2962 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2963 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2964 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2965 DEFSYM (Qtext_read_only
, "text-read-only");
2966 DEFSYM (Qmark_inactive
, "mark-inactive");
2968 DEFSYM (Qlistp
, "listp");
2969 DEFSYM (Qconsp
, "consp");
2970 DEFSYM (Qsymbolp
, "symbolp");
2971 DEFSYM (Qkeywordp
, "keywordp");
2972 DEFSYM (Qintegerp
, "integerp");
2973 DEFSYM (Qnatnump
, "natnump");
2974 DEFSYM (Qwholenump
, "wholenump");
2975 DEFSYM (Qstringp
, "stringp");
2976 DEFSYM (Qarrayp
, "arrayp");
2977 DEFSYM (Qsequencep
, "sequencep");
2978 DEFSYM (Qbufferp
, "bufferp");
2979 DEFSYM (Qvectorp
, "vectorp");
2980 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2981 DEFSYM (Qmarkerp
, "markerp");
2982 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
2983 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
2984 DEFSYM (Qboundp
, "boundp");
2985 DEFSYM (Qfboundp
, "fboundp");
2987 DEFSYM (Qfloatp
, "floatp");
2988 DEFSYM (Qnumberp
, "numberp");
2989 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
2991 DEFSYM (Qchar_table_p
, "char-table-p");
2992 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
2994 DEFSYM (Qsubrp
, "subrp");
2995 DEFSYM (Qunevalled
, "unevalled");
2996 DEFSYM (Qmany
, "many");
2998 DEFSYM (Qcdr
, "cdr");
3000 /* Handle automatic advice activation. */
3001 DEFSYM (Qad_advice_info
, "ad-advice-info");
3002 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3004 error_tail
= pure_cons (Qerror
, Qnil
);
3006 /* ERROR is used as a signaler for random errors for which nothing else is
3009 Fput (Qerror
, Qerror_conditions
,
3011 Fput (Qerror
, Qerror_message
,
3012 build_pure_c_string ("error"));
3014 #define PUT_ERROR(sym, tail, msg) \
3015 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3016 Fput (sym, Qerror_message, build_pure_c_string (msg))
3018 PUT_ERROR (Qquit
, Qnil
, "Quit");
3020 PUT_ERROR (Quser_error
, error_tail
, "");
3021 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3022 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3023 PUT_ERROR (Qvoid_function
, error_tail
,
3024 "Symbol's function definition is void");
3025 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3026 "Symbol's chain of function indirections contains a loop");
3027 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3028 "Symbol's chain of variable indirections contains a loop");
3029 DEFSYM (Qcircular_list
, "circular-list");
3030 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3031 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3032 PUT_ERROR (Qsetting_constant
, error_tail
,
3033 "Attempt to set a constant symbol");
3034 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3035 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3036 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3037 "Wrong number of arguments");
3038 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3039 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3041 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3042 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3043 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3045 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3046 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3047 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3048 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3049 "Text is read-only");
3051 DEFSYM (Qrange_error
, "range-error");
3052 DEFSYM (Qdomain_error
, "domain-error");
3053 DEFSYM (Qsingularity_error
, "singularity-error");
3054 DEFSYM (Qoverflow_error
, "overflow-error");
3055 DEFSYM (Qunderflow_error
, "underflow-error");
3057 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3059 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3061 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3062 "Arithmetic singularity error");
3064 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3065 "Arithmetic overflow error");
3066 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3067 "Arithmetic underflow error");
3071 staticpro (&Qunbound
);
3073 /* Types that type-of returns. */
3074 DEFSYM (Qinteger
, "integer");
3075 DEFSYM (Qsymbol
, "symbol");
3076 DEFSYM (Qstring
, "string");
3077 DEFSYM (Qcons
, "cons");
3078 DEFSYM (Qmarker
, "marker");
3079 DEFSYM (Qoverlay
, "overlay");
3080 DEFSYM (Qfloat
, "float");
3081 DEFSYM (Qwindow_configuration
, "window-configuration");
3082 DEFSYM (Qprocess
, "process");
3083 DEFSYM (Qwindow
, "window");
3084 DEFSYM (Qcompiled_function
, "compiled-function");
3085 DEFSYM (Qbuffer
, "buffer");
3086 DEFSYM (Qframe
, "frame");
3087 DEFSYM (Qvector
, "vector");
3088 DEFSYM (Qchar_table
, "char-table");
3089 DEFSYM (Qbool_vector
, "bool-vector");
3090 DEFSYM (Qhash_table
, "hash-table");
3091 DEFSYM (Qmisc
, "misc");
3093 DEFSYM (Qdefun
, "defun");
3095 DEFSYM (Qfont_spec
, "font-spec");
3096 DEFSYM (Qfont_entity
, "font-entity");
3097 DEFSYM (Qfont_object
, "font-object");
3099 DEFSYM (Qinteractive_form
, "interactive-form");
3101 defsubr (&Sindirect_variable
);
3102 defsubr (&Sinteractive_form
);
3105 defsubr (&Stype_of
);
3110 defsubr (&Sintegerp
);
3111 defsubr (&Sinteger_or_marker_p
);
3112 defsubr (&Snumberp
);
3113 defsubr (&Snumber_or_marker_p
);
3115 defsubr (&Snatnump
);
3116 defsubr (&Ssymbolp
);
3117 defsubr (&Skeywordp
);
3118 defsubr (&Sstringp
);
3119 defsubr (&Smultibyte_string_p
);
3120 defsubr (&Svectorp
);
3121 defsubr (&Schar_table_p
);
3122 defsubr (&Svector_or_char_table_p
);
3123 defsubr (&Sbool_vector_p
);
3125 defsubr (&Ssequencep
);
3126 defsubr (&Sbufferp
);
3127 defsubr (&Smarkerp
);
3129 defsubr (&Sbyte_code_function_p
);
3130 defsubr (&Schar_or_string_p
);
3133 defsubr (&Scar_safe
);
3134 defsubr (&Scdr_safe
);
3137 defsubr (&Ssymbol_function
);
3138 defsubr (&Sindirect_function
);
3139 defsubr (&Ssymbol_plist
);
3140 defsubr (&Ssymbol_name
);
3141 defsubr (&Smakunbound
);
3142 defsubr (&Sfmakunbound
);
3144 defsubr (&Sfboundp
);
3146 defsubr (&Sdefalias
);
3147 defsubr (&Ssetplist
);
3148 defsubr (&Ssymbol_value
);
3150 defsubr (&Sdefault_boundp
);
3151 defsubr (&Sdefault_value
);
3152 defsubr (&Sset_default
);
3153 defsubr (&Ssetq_default
);
3154 defsubr (&Smake_variable_buffer_local
);
3155 defsubr (&Smake_local_variable
);
3156 defsubr (&Skill_local_variable
);
3157 defsubr (&Smake_variable_frame_local
);
3158 defsubr (&Slocal_variable_p
);
3159 defsubr (&Slocal_variable_if_set_p
);
3160 defsubr (&Svariable_binding_locus
);
3161 #if 0 /* XXX Remove this. --lorentey */
3162 defsubr (&Sterminal_local_value
);
3163 defsubr (&Sset_terminal_local_value
);
3167 defsubr (&Snumber_to_string
);
3168 defsubr (&Sstring_to_number
);
3169 defsubr (&Seqlsign
);
3192 defsubr (&Sbyteorder
);
3193 defsubr (&Ssubr_arity
);
3194 defsubr (&Ssubr_name
);
3196 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3198 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3199 doc
: /* The largest value that is representable in a Lisp integer. */);
3200 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3201 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3203 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3204 doc
: /* The smallest value that is representable in a Lisp integer. */);
3205 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3206 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3209 static _Noreturn
void
3210 handle_arith_signal (int sig
)
3212 pthread_sigmask (SIG_SETMASK
, &empty_mask
, 0);
3213 xsignal0 (Qarith_error
);
3217 deliver_arith_signal (int sig
)
3219 handle_on_main_thread (sig
, handle_arith_signal
);
3225 struct sigaction action
;
3226 /* Don't do this if just dumping out.
3227 We don't want to call `signal' in this case
3228 so that we don't have trouble with dumping
3229 signal-delivering routines in an inconsistent state. */
3233 #endif /* CANNOT_DUMP */
3234 emacs_sigaction_init (&action
, deliver_arith_signal
);
3235 sigaction (SIGFPE
, &action
, 0);