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/>. */
30 #include "character.h"
34 #include "syssignal.h"
35 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
52 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
53 static Lisp_Object Qsubr
;
54 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
55 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
56 static Lisp_Object Qwrong_type_argument
;
57 Lisp_Object Qvoid_variable
, Qvoid_function
;
58 static Lisp_Object Qcyclic_function_indirection
;
59 static Lisp_Object Qcyclic_variable_indirection
;
60 Lisp_Object Qcircular_list
;
61 static Lisp_Object Qsetting_constant
;
62 Lisp_Object Qinvalid_read_syntax
;
63 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
64 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
65 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
66 Lisp_Object Qtext_read_only
;
68 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
69 static Lisp_Object Qnatnump
;
70 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
71 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
72 Lisp_Object Qbuffer_or_string_p
;
73 static Lisp_Object Qkeywordp
, Qboundp
;
75 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
78 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
80 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
81 Lisp_Object Qoverflow_error
, Qunderflow_error
;
84 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
86 Lisp_Object Qinteger
, Qsymbol
;
87 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
89 static Lisp_Object Qoverlay
, Qwindow_configuration
;
90 static Lisp_Object Qprocess
, Qmarker
;
91 static Lisp_Object Qcompiled_function
, Qframe
;
93 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
94 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
95 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
96 static Lisp_Object Qdefun
;
98 Lisp_Object Qinteractive_form
;
100 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
104 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
106 /* If VALUE is not even a valid Lisp object, we'd want to abort here
107 where we can get a backtrace showing where it came from. We used
108 to try and do that by checking the tagbits, but nowadays all
109 tagbits are potentially valid. */
110 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
113 xsignal2 (Qwrong_type_argument
, predicate
, value
);
117 pure_write_error (void)
119 error ("Attempt to modify read-only object");
123 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
125 xsignal2 (Qargs_out_of_range
, a1
, a2
);
129 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
131 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
135 /* Data type predicates. */
137 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
138 doc
: /* Return t if the two args are the same Lisp object. */)
139 (Lisp_Object obj1
, Lisp_Object obj2
)
146 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
147 doc
: /* Return t if OBJECT is nil. */)
155 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
156 doc
: /* Return a symbol representing the type of OBJECT.
157 The symbol returned names the object's basic type;
158 for example, (type-of 1) returns `integer'. */)
161 switch (XTYPE (object
))
176 switch (XMISCTYPE (object
))
178 case Lisp_Misc_Marker
:
180 case Lisp_Misc_Overlay
:
182 case Lisp_Misc_Float
:
187 case Lisp_Vectorlike
:
188 if (WINDOW_CONFIGURATIONP (object
))
189 return Qwindow_configuration
;
190 if (PROCESSP (object
))
192 if (WINDOWP (object
))
196 if (COMPILEDP (object
))
197 return Qcompiled_function
;
198 if (BUFFERP (object
))
200 if (CHAR_TABLE_P (object
))
202 if (BOOL_VECTOR_P (object
))
206 if (HASH_TABLE_P (object
))
208 if (FONT_SPEC_P (object
))
210 if (FONT_ENTITY_P (object
))
212 if (FONT_OBJECT_P (object
))
224 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
225 doc
: /* Return t if OBJECT is a cons cell. */)
233 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
234 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
242 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
243 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
244 Otherwise, return nil. */)
247 if (CONSP (object
) || NILP (object
))
252 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
253 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
256 if (CONSP (object
) || NILP (object
))
261 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
262 doc
: /* Return t if OBJECT is a symbol. */)
265 if (SYMBOLP (object
))
270 /* Define this in C to avoid unnecessarily consing up the symbol
272 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
273 doc
: /* Return t if OBJECT is a keyword.
274 This means that it is a symbol with a print name beginning with `:'
275 interned in the initial obarray. */)
279 && SREF (SYMBOL_NAME (object
), 0) == ':'
280 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
285 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
286 doc
: /* Return t if OBJECT is a vector. */)
289 if (VECTORP (object
))
294 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
295 doc
: /* Return t if OBJECT is a string. */)
298 if (STRINGP (object
))
303 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
305 doc
: /* Return t if OBJECT is a multibyte string. */)
308 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
313 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
314 doc
: /* Return t if OBJECT is a char-table. */)
317 if (CHAR_TABLE_P (object
))
322 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
323 Svector_or_char_table_p
, 1, 1, 0,
324 doc
: /* Return t if OBJECT is a char-table or vector. */)
327 if (VECTORP (object
) || CHAR_TABLE_P (object
))
332 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
333 doc
: /* Return t if OBJECT is a bool-vector. */)
336 if (BOOL_VECTOR_P (object
))
341 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
342 doc
: /* Return t if OBJECT is an array (string or vector). */)
350 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
351 doc
: /* Return t if OBJECT is a sequence (list or array). */)
352 (register Lisp_Object object
)
354 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
359 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
360 doc
: /* Return t if OBJECT is an editor buffer. */)
363 if (BUFFERP (object
))
368 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
369 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
372 if (MARKERP (object
))
377 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is a built-in function. */)
386 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
388 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
391 if (COMPILEDP (object
))
396 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is a character or a string. */)
398 (register Lisp_Object object
)
400 if (CHARACTERP (object
) || STRINGP (object
))
405 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
406 doc
: /* Return t if OBJECT is an integer. */)
409 if (INTEGERP (object
))
414 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
416 (register Lisp_Object object
)
418 if (MARKERP (object
) || INTEGERP (object
))
423 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
424 doc
: /* Return t if OBJECT is a nonnegative integer. */)
427 if (NATNUMP (object
))
432 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
433 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
436 if (NUMBERP (object
))
442 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
443 Snumber_or_marker_p
, 1, 1, 0,
444 doc
: /* Return t if OBJECT is a number or a marker. */)
447 if (NUMBERP (object
) || MARKERP (object
))
452 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
453 doc
: /* Return t if OBJECT is a floating point number. */)
462 /* Extract and set components of lists */
464 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
465 doc
: /* Return the car of LIST. If arg is nil, return nil.
466 Error if arg is not nil and not a cons cell. See also `car-safe'.
468 See Info node `(elisp)Cons Cells' for a discussion of related basic
469 Lisp concepts such as car, cdr, cons cell and list. */)
470 (register Lisp_Object list
)
475 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
476 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
479 return CAR_SAFE (object
);
482 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
483 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
484 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
486 See Info node `(elisp)Cons Cells' for a discussion of related basic
487 Lisp concepts such as cdr, car, cons cell and list. */)
488 (register Lisp_Object list
)
493 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
494 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
497 return CDR_SAFE (object
);
500 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
501 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
502 (register Lisp_Object cell
, Lisp_Object newcar
)
506 XSETCAR (cell
, newcar
);
510 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
511 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
512 (register Lisp_Object cell
, Lisp_Object newcdr
)
516 XSETCDR (cell
, newcdr
);
520 /* Extract and set components of symbols. */
522 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
523 doc
: /* Return t if SYMBOL's value is not void. */)
524 (register Lisp_Object symbol
)
526 Lisp_Object valcontents
;
527 struct Lisp_Symbol
*sym
;
528 CHECK_SYMBOL (symbol
);
529 sym
= XSYMBOL (symbol
);
532 switch (sym
->redirect
)
534 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
535 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
536 case SYMBOL_LOCALIZED
:
538 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
540 /* In set_internal, we un-forward vars when their value is
545 swap_in_symval_forwarding (sym
, blv
);
546 valcontents
= blv_value (blv
);
550 case SYMBOL_FORWARDED
:
551 /* In set_internal, we un-forward vars when their value is
557 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
560 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
561 doc
: /* Return t if SYMBOL's function definition is not void. */)
562 (register Lisp_Object symbol
)
564 CHECK_SYMBOL (symbol
);
565 return EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
;
568 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
569 doc
: /* Make SYMBOL's value be void.
571 (register Lisp_Object symbol
)
573 CHECK_SYMBOL (symbol
);
574 if (SYMBOL_CONSTANT_P (symbol
))
575 xsignal1 (Qsetting_constant
, symbol
);
576 Fset (symbol
, Qunbound
);
580 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
581 doc
: /* Make SYMBOL's function definition be void.
583 (register Lisp_Object symbol
)
585 CHECK_SYMBOL (symbol
);
586 if (NILP (symbol
) || EQ (symbol
, Qt
))
587 xsignal1 (Qsetting_constant
, symbol
);
588 set_symbol_function (symbol
, Qunbound
);
592 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
593 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
594 (register Lisp_Object symbol
)
596 CHECK_SYMBOL (symbol
);
597 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
598 return XSYMBOL (symbol
)->function
;
599 xsignal1 (Qvoid_function
, symbol
);
602 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
603 doc
: /* Return SYMBOL's property list. */)
604 (register Lisp_Object symbol
)
606 CHECK_SYMBOL (symbol
);
607 return XSYMBOL (symbol
)->plist
;
610 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
611 doc
: /* Return SYMBOL's name, a string. */)
612 (register Lisp_Object symbol
)
614 register Lisp_Object name
;
616 CHECK_SYMBOL (symbol
);
617 name
= SYMBOL_NAME (symbol
);
621 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
622 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
623 (register Lisp_Object symbol
, Lisp_Object definition
)
625 register Lisp_Object function
;
627 CHECK_SYMBOL (symbol
);
628 if (NILP (symbol
) || EQ (symbol
, Qt
))
629 xsignal1 (Qsetting_constant
, symbol
);
631 function
= XSYMBOL (symbol
)->function
;
633 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
634 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
636 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
637 Fput (symbol
, Qautoload
, XCDR (function
));
639 set_symbol_function (symbol
, definition
);
640 /* Handle automatic advice activation. */
641 if (CONSP (XSYMBOL (symbol
)->plist
)
642 && !NILP (Fget (symbol
, Qad_advice_info
)))
644 call2 (Qad_activate_internal
, symbol
, Qnil
);
645 definition
= XSYMBOL (symbol
)->function
;
650 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
651 doc
: /* Set SYMBOL's function definition to DEFINITION.
652 Associates the function with the current load file, if any.
653 The optional third argument DOCSTRING specifies the documentation string
654 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
655 determined by DEFINITION.
656 The return value is undefined. */)
657 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
659 CHECK_SYMBOL (symbol
);
660 if (CONSP (XSYMBOL (symbol
)->function
)
661 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
662 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
663 if (!NILP (Vpurify_flag
)
664 /* If `definition' is a keymap, immutable (and copying) is wrong. */
665 && !KEYMAPP (definition
))
666 definition
= Fpurecopy (definition
);
667 definition
= Ffset (symbol
, definition
);
668 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
669 if (!NILP (docstring
))
670 Fput (symbol
, Qfunction_documentation
, docstring
);
671 /* We used to return `definition', but now that `defun' and `defmacro' expand
672 to a call to `defalias', we return `symbol' for backward compatibility
677 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
678 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
679 (register Lisp_Object symbol
, Lisp_Object newplist
)
681 CHECK_SYMBOL (symbol
);
682 set_symbol_plist (symbol
, newplist
);
686 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
687 doc
: /* Return minimum and maximum number of args allowed for SUBR.
688 SUBR must be a built-in function.
689 The returned value is a pair (MIN . MAX). MIN is the minimum number
690 of args. MAX is the maximum number or the symbol `many', for a
691 function with `&rest' args, or `unevalled' for a special form. */)
694 short minargs
, maxargs
;
696 minargs
= XSUBR (subr
)->min_args
;
697 maxargs
= XSUBR (subr
)->max_args
;
699 return Fcons (make_number (minargs
), Qmany
);
700 else if (maxargs
== UNEVALLED
)
701 return Fcons (make_number (minargs
), Qunevalled
);
703 return Fcons (make_number (minargs
), make_number (maxargs
));
706 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
707 doc
: /* Return name of subroutine SUBR.
708 SUBR must be a built-in function. */)
713 name
= XSUBR (subr
)->symbol_name
;
714 return build_string (name
);
717 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
718 doc
: /* Return the interactive form of CMD or nil if none.
719 If CMD is not a command, the return value is nil.
720 Value, if non-nil, is a list \(interactive SPEC). */)
723 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
725 if (NILP (fun
) || EQ (fun
, Qunbound
))
728 /* Use an `interactive-form' property if present, analogous to the
729 function-documentation property. */
731 while (SYMBOLP (fun
))
733 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
737 fun
= Fsymbol_function (fun
);
742 const char *spec
= XSUBR (fun
)->intspec
;
744 return list2 (Qinteractive
,
745 (*spec
!= '(') ? build_string (spec
) :
746 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
748 else if (COMPILEDP (fun
))
750 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
751 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
753 else if (CONSP (fun
))
755 Lisp_Object funcar
= XCAR (fun
);
756 if (EQ (funcar
, Qclosure
))
757 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
758 else if (EQ (funcar
, Qlambda
))
759 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
760 else if (EQ (funcar
, Qautoload
))
764 Fautoload_do_load (fun
, cmd
, Qnil
);
766 return Finteractive_form (cmd
);
773 /***********************************************************************
774 Getting and Setting Values of Symbols
775 ***********************************************************************/
777 /* Return the symbol holding SYMBOL's value. Signal
778 `cyclic-variable-indirection' if SYMBOL's chain of variable
779 indirections contains a loop. */
782 indirect_variable (struct Lisp_Symbol
*symbol
)
784 struct Lisp_Symbol
*tortoise
, *hare
;
786 hare
= tortoise
= symbol
;
788 while (hare
->redirect
== SYMBOL_VARALIAS
)
790 hare
= SYMBOL_ALIAS (hare
);
791 if (hare
->redirect
!= SYMBOL_VARALIAS
)
794 hare
= SYMBOL_ALIAS (hare
);
795 tortoise
= SYMBOL_ALIAS (tortoise
);
797 if (hare
== tortoise
)
800 XSETSYMBOL (tem
, symbol
);
801 xsignal1 (Qcyclic_variable_indirection
, tem
);
809 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
810 doc
: /* Return the variable at the end of OBJECT's variable chain.
811 If OBJECT is a symbol, follow its variable indirections (if any), and
812 return the variable at the end of the chain of aliases. See Info node
813 `(elisp)Variable Aliases'.
815 If OBJECT is not a symbol, just return it. If there is a loop in the
816 chain of aliases, signal a `cyclic-variable-indirection' error. */)
819 if (SYMBOLP (object
))
821 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
822 XSETSYMBOL (object
, sym
);
828 /* Given the raw contents of a symbol value cell,
829 return the Lisp value of the symbol.
830 This does not handle buffer-local variables; use
831 swap_in_symval_forwarding for that. */
834 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
836 register Lisp_Object val
;
837 switch (XFWDTYPE (valcontents
))
840 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
844 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
847 return *XOBJFWD (valcontents
)->objvar
;
849 case Lisp_Fwd_Buffer_Obj
:
850 return per_buffer_value (current_buffer
,
851 XBUFFER_OBJFWD (valcontents
)->offset
);
853 case Lisp_Fwd_Kboard_Obj
:
854 /* We used to simply use current_kboard here, but from Lisp
855 code, its value is often unexpected. It seems nicer to
856 allow constructions like this to work as intuitively expected:
858 (with-selected-frame frame
859 (define-key local-function-map "\eOP" [f1]))
861 On the other hand, this affects the semantics of
862 last-command and real-last-command, and people may rely on
863 that. I took a quick look at the Lisp codebase, and I
864 don't think anything will break. --lorentey */
865 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
866 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
871 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
872 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
873 buffer-independent contents of the value cell: forwarded just one
874 step past the buffer-localness.
876 BUF non-zero means set the value in buffer BUF instead of the
877 current buffer. This only plays a role for per-buffer variables. */
880 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
882 switch (XFWDTYPE (valcontents
))
885 CHECK_NUMBER (newval
);
886 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
890 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
894 *XOBJFWD (valcontents
)->objvar
= newval
;
896 /* If this variable is a default for something stored
897 in the buffer itself, such as default-fill-column,
898 find the buffers that don't have local values for it
900 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
901 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
903 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
904 - (char *) &buffer_defaults
);
905 int idx
= PER_BUFFER_IDX (offset
);
912 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
917 lbuf
= Fcdr (XCAR (tail
));
918 if (!BUFFERP (lbuf
)) continue;
921 if (! PER_BUFFER_VALUE_P (b
, idx
))
922 set_per_buffer_value (b
, offset
, newval
);
927 case Lisp_Fwd_Buffer_Obj
:
929 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
930 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
932 if (!(NILP (type
) || NILP (newval
)
933 || (XINT (type
) == Lisp_Int0
935 : XTYPE (newval
) == XINT (type
))))
936 buffer_slot_type_mismatch (newval
, XINT (type
));
939 buf
= current_buffer
;
940 set_per_buffer_value (buf
, offset
, newval
);
944 case Lisp_Fwd_Kboard_Obj
:
946 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
947 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
948 *(Lisp_Object
*) p
= newval
;
953 abort (); /* goto def; */
957 /* Set up SYMBOL to refer to its global binding.
958 This makes it safe to alter the status of other bindings. */
961 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
963 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
965 /* Unload the previously loaded binding. */
967 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
969 /* Select the global binding in the symbol. */
970 set_blv_valcell (blv
, blv
->defcell
);
972 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
974 /* Indicate that the global binding is set up now. */
975 set_blv_where (blv
, Qnil
);
976 set_blv_found (blv
, 0);
979 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
980 VALCONTENTS is the contents of its value cell,
981 which points to a struct Lisp_Buffer_Local_Value.
983 Return the value forwarded one step past the buffer-local stage.
984 This could be another forwarding pointer. */
987 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
989 register Lisp_Object tem1
;
991 eassert (blv
== SYMBOL_BLV (symbol
));
997 ? !EQ (selected_frame
, tem1
)
998 : current_buffer
!= XBUFFER (tem1
)))
1001 /* Unload the previously loaded binding. */
1002 tem1
= blv
->valcell
;
1004 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1005 /* Choose the new binding. */
1008 XSETSYMBOL (var
, symbol
);
1009 if (blv
->frame_local
)
1011 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1012 set_blv_where (blv
, selected_frame
);
1016 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1017 XSETBUFFER (blv
->where
, current_buffer
);
1020 if (!(blv
->found
= !NILP (tem1
)))
1021 tem1
= blv
->defcell
;
1023 /* Load the new binding. */
1024 set_blv_valcell (blv
, tem1
);
1026 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1030 /* Find the value of a symbol, returning Qunbound if it's not bound.
1031 This is helpful for code which just wants to get a variable's value
1032 if it has one, without signaling an error.
1033 Note that it must not be possible to quit
1034 within this function. Great care is required for this. */
1037 find_symbol_value (Lisp_Object symbol
)
1039 struct Lisp_Symbol
*sym
;
1041 CHECK_SYMBOL (symbol
);
1042 sym
= XSYMBOL (symbol
);
1045 switch (sym
->redirect
)
1047 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1048 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1049 case SYMBOL_LOCALIZED
:
1051 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1052 swap_in_symval_forwarding (sym
, blv
);
1053 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1056 case SYMBOL_FORWARDED
:
1057 return do_symval_forwarding (SYMBOL_FWD (sym
));
1062 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1063 doc
: /* Return SYMBOL's value. Error if that is void. */)
1064 (Lisp_Object symbol
)
1068 val
= find_symbol_value (symbol
);
1069 if (!EQ (val
, Qunbound
))
1072 xsignal1 (Qvoid_variable
, symbol
);
1075 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1076 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1077 (register Lisp_Object symbol
, Lisp_Object newval
)
1079 set_internal (symbol
, newval
, Qnil
, 0);
1083 /* Return true if SYMBOL currently has a let-binding
1084 which was made in the buffer that is now current. */
1087 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1089 struct specbinding
*p
;
1091 for (p
= specpdl_ptr
; p
> specpdl
; )
1092 if ((--p
)->func
== NULL
1093 && CONSP (p
->symbol
))
1095 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1096 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1097 if (symbol
== let_bound_symbol
1098 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1106 let_shadows_global_binding_p (Lisp_Object symbol
)
1108 struct specbinding
*p
;
1110 for (p
= specpdl_ptr
; p
> specpdl
; )
1111 if ((--p
)->func
== NULL
&& EQ (p
->symbol
, symbol
))
1117 /* Store the value NEWVAL into SYMBOL.
1118 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1119 (nil stands for the current buffer/frame).
1121 If BINDFLAG is false, then if this symbol is supposed to become
1122 local in every buffer where it is set, then we make it local.
1123 If BINDFLAG is true, we don't do that. */
1126 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1129 bool voide
= EQ (newval
, Qunbound
);
1130 struct Lisp_Symbol
*sym
;
1133 /* If restoring in a dead buffer, do nothing. */
1134 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1137 CHECK_SYMBOL (symbol
);
1138 if (SYMBOL_CONSTANT_P (symbol
))
1140 if (NILP (Fkeywordp (symbol
))
1141 || !EQ (newval
, Fsymbol_value (symbol
)))
1142 xsignal1 (Qsetting_constant
, symbol
);
1144 /* Allow setting keywords to their own value. */
1148 sym
= XSYMBOL (symbol
);
1151 switch (sym
->redirect
)
1153 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1154 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1155 case SYMBOL_LOCALIZED
:
1157 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1160 if (blv
->frame_local
)
1161 where
= selected_frame
;
1163 XSETBUFFER (where
, current_buffer
);
1165 /* If the current buffer is not the buffer whose binding is
1166 loaded, or if there may be frame-local bindings and the frame
1167 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1168 the default binding is loaded, the loaded binding may be the
1170 if (!EQ (blv
->where
, where
)
1171 /* Also unload a global binding (if the var is local_if_set). */
1172 || (EQ (blv
->valcell
, blv
->defcell
)))
1174 /* The currently loaded binding is not necessarily valid.
1175 We need to unload it, and choose a new binding. */
1177 /* Write out `realvalue' to the old loaded binding. */
1179 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1181 /* Find the new binding. */
1182 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1183 tem1
= Fassq (symbol
,
1185 ? XFRAME (where
)->param_alist
1186 : BVAR (XBUFFER (where
), local_var_alist
)));
1187 set_blv_where (blv
, where
);
1192 /* This buffer still sees the default value. */
1194 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1195 or if this is `let' rather than `set',
1196 make CURRENT-ALIST-ELEMENT point to itself,
1197 indicating that we're seeing the default value.
1198 Likewise if the variable has been let-bound
1199 in the current buffer. */
1200 if (bindflag
|| !blv
->local_if_set
1201 || let_shadows_buffer_binding_p (sym
))
1204 tem1
= blv
->defcell
;
1206 /* If it's a local_if_set, being set not bound,
1207 and we're not within a let that was made for this buffer,
1208 create a new buffer-local binding for the variable.
1209 That means, give this buffer a new assoc for a local value
1210 and load that binding. */
1213 /* local_if_set is only supported for buffer-local
1214 bindings, not for frame-local bindings. */
1215 eassert (!blv
->frame_local
);
1216 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1217 bset_local_var_alist
1219 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1223 /* Record which binding is now loaded. */
1224 set_blv_valcell (blv
, tem1
);
1227 /* Store the new value in the cons cell. */
1228 set_blv_value (blv
, newval
);
1233 /* If storing void (making the symbol void), forward only through
1234 buffer-local indicator, not through Lisp_Objfwd, etc. */
1237 store_symval_forwarding (blv
->fwd
, newval
,
1239 ? XBUFFER (where
) : current_buffer
);
1243 case SYMBOL_FORWARDED
:
1246 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1247 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1248 if (BUFFER_OBJFWDP (innercontents
))
1250 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1251 int idx
= PER_BUFFER_IDX (offset
);
1254 && !let_shadows_buffer_binding_p (sym
))
1255 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1259 { /* If storing void (making the symbol void), forward only through
1260 buffer-local indicator, not through Lisp_Objfwd, etc. */
1261 sym
->redirect
= SYMBOL_PLAINVAL
;
1262 SET_SYMBOL_VAL (sym
, newval
);
1265 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1273 /* Access or set a buffer-local symbol's default value. */
1275 /* Return the default value of SYMBOL, but don't check for voidness.
1276 Return Qunbound if it is void. */
1279 default_value (Lisp_Object symbol
)
1281 struct Lisp_Symbol
*sym
;
1283 CHECK_SYMBOL (symbol
);
1284 sym
= XSYMBOL (symbol
);
1287 switch (sym
->redirect
)
1289 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1290 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1291 case SYMBOL_LOCALIZED
:
1293 /* If var is set up for a buffer that lacks a local value for it,
1294 the current value is nominally the default value.
1295 But the `realvalue' slot may be more up to date, since
1296 ordinary setq stores just that slot. So use that. */
1297 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1298 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1299 return do_symval_forwarding (blv
->fwd
);
1301 return XCDR (blv
->defcell
);
1303 case SYMBOL_FORWARDED
:
1305 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1307 /* For a built-in buffer-local variable, get the default value
1308 rather than letting do_symval_forwarding get the current value. */
1309 if (BUFFER_OBJFWDP (valcontents
))
1311 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1312 if (PER_BUFFER_IDX (offset
) != 0)
1313 return per_buffer_default (offset
);
1316 /* For other variables, get the current value. */
1317 return do_symval_forwarding (valcontents
);
1323 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1324 doc
: /* Return t if SYMBOL has a non-void default value.
1325 This is the value that is seen in buffers that do not have their own values
1326 for this variable. */)
1327 (Lisp_Object symbol
)
1329 register Lisp_Object value
;
1331 value
= default_value (symbol
);
1332 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1335 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1336 doc
: /* Return SYMBOL's default value.
1337 This is the value that is seen in buffers that do not have their own values
1338 for this variable. The default value is meaningful for variables with
1339 local bindings in certain buffers. */)
1340 (Lisp_Object symbol
)
1342 register Lisp_Object value
;
1344 value
= default_value (symbol
);
1345 if (!EQ (value
, Qunbound
))
1348 xsignal1 (Qvoid_variable
, symbol
);
1351 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1352 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1353 The default value is seen in buffers that do not have their own values
1354 for this variable. */)
1355 (Lisp_Object symbol
, Lisp_Object value
)
1357 struct Lisp_Symbol
*sym
;
1359 CHECK_SYMBOL (symbol
);
1360 if (SYMBOL_CONSTANT_P (symbol
))
1362 if (NILP (Fkeywordp (symbol
))
1363 || !EQ (value
, Fdefault_value (symbol
)))
1364 xsignal1 (Qsetting_constant
, symbol
);
1366 /* Allow setting keywords to their own value. */
1369 sym
= XSYMBOL (symbol
);
1372 switch (sym
->redirect
)
1374 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1375 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1376 case SYMBOL_LOCALIZED
:
1378 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1380 /* Store new value into the DEFAULT-VALUE slot. */
1381 XSETCDR (blv
->defcell
, value
);
1383 /* If the default binding is now loaded, set the REALVALUE slot too. */
1384 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1385 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1388 case SYMBOL_FORWARDED
:
1390 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1392 /* Handle variables like case-fold-search that have special slots
1394 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1395 if (BUFFER_OBJFWDP (valcontents
))
1397 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1398 int idx
= PER_BUFFER_IDX (offset
);
1400 set_per_buffer_default (offset
, value
);
1402 /* If this variable is not always local in all buffers,
1403 set it in the buffers that don't nominally have a local value. */
1409 if (!PER_BUFFER_VALUE_P (b
, idx
))
1410 set_per_buffer_value (b
, offset
, value
);
1415 return Fset (symbol
, value
);
1421 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1422 doc
: /* Set the default value of variable VAR to VALUE.
1423 VAR, the variable name, is literal (not evaluated);
1424 VALUE is an expression: it is evaluated and its value returned.
1425 The default value of a variable is seen in buffers
1426 that do not have their own values for the variable.
1428 More generally, you can use multiple variables and values, as in
1429 (setq-default VAR VALUE VAR VALUE...)
1430 This sets each VAR's default value to the corresponding VALUE.
1431 The VALUE for the Nth VAR can refer to the new default values
1433 usage: (setq-default [VAR VALUE]...) */)
1436 register Lisp_Object args_left
;
1437 register Lisp_Object val
, symbol
;
1438 struct gcpro gcpro1
;
1448 val
= eval_sub (Fcar (Fcdr (args_left
)));
1449 symbol
= XCAR (args_left
);
1450 Fset_default (symbol
, val
);
1451 args_left
= Fcdr (XCDR (args_left
));
1453 while (!NILP (args_left
));
1459 /* Lisp functions for creating and removing buffer-local variables. */
1464 union Lisp_Fwd
*fwd
;
1467 static struct Lisp_Buffer_Local_Value
*
1468 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1469 union Lisp_Val_Fwd valcontents
)
1471 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1475 XSETSYMBOL (symbol
, sym
);
1476 tem
= Fcons (symbol
, (forwarded
1477 ? do_symval_forwarding (valcontents
.fwd
)
1478 : valcontents
.value
));
1480 /* Buffer_Local_Values cannot have as realval a buffer-local
1481 or keyboard-local forwarding. */
1482 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1483 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1484 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1485 set_blv_where (blv
, Qnil
);
1486 blv
->frame_local
= 0;
1487 blv
->local_if_set
= 0;
1488 set_blv_defcell (blv
, tem
);
1489 set_blv_valcell (blv
, tem
);
1490 set_blv_found (blv
, 0);
1494 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1495 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1496 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1497 At any time, the value for the current buffer is in effect,
1498 unless the variable has never been set in this buffer,
1499 in which case the default value is in effect.
1500 Note that binding the variable with `let', or setting it while
1501 a `let'-style binding made in this buffer is in effect,
1502 does not make the variable buffer-local. Return VARIABLE.
1504 In most cases it is better to use `make-local-variable',
1505 which makes a variable local in just one buffer.
1507 The function `default-value' gets the default value and `set-default' sets it. */)
1508 (register Lisp_Object variable
)
1510 struct Lisp_Symbol
*sym
;
1511 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1512 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1513 bool forwarded
IF_LINT (= 0);
1515 CHECK_SYMBOL (variable
);
1516 sym
= XSYMBOL (variable
);
1519 switch (sym
->redirect
)
1521 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1522 case SYMBOL_PLAINVAL
:
1523 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1524 if (EQ (valcontents
.value
, Qunbound
))
1525 valcontents
.value
= Qnil
;
1527 case SYMBOL_LOCALIZED
:
1528 blv
= SYMBOL_BLV (sym
);
1529 if (blv
->frame_local
)
1530 error ("Symbol %s may not be buffer-local",
1531 SDATA (SYMBOL_NAME (variable
)));
1533 case SYMBOL_FORWARDED
:
1534 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1535 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1536 error ("Symbol %s may not be buffer-local",
1537 SDATA (SYMBOL_NAME (variable
)));
1538 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1545 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1549 blv
= make_blv (sym
, forwarded
, valcontents
);
1550 sym
->redirect
= SYMBOL_LOCALIZED
;
1551 SET_SYMBOL_BLV (sym
, blv
);
1554 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1555 if (let_shadows_global_binding_p (symbol
))
1556 message ("Making %s buffer-local while let-bound!",
1557 SDATA (SYMBOL_NAME (variable
)));
1561 blv
->local_if_set
= 1;
1565 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1566 1, 1, "vMake Local Variable: ",
1567 doc
: /* Make VARIABLE have a separate value in the current buffer.
1568 Other buffers will continue to share a common default value.
1569 \(The buffer-local value of VARIABLE starts out as the same value
1570 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1573 If the variable is already arranged to become local when set,
1574 this function causes a local value to exist for this buffer,
1575 just as setting the variable would do.
1577 This function returns VARIABLE, and therefore
1578 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1581 See also `make-variable-buffer-local'.
1583 Do not use `make-local-variable' to make a hook variable buffer-local.
1584 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1585 (Lisp_Object variable
)
1588 bool forwarded
IF_LINT (= 0);
1589 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1590 struct Lisp_Symbol
*sym
;
1591 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1593 CHECK_SYMBOL (variable
);
1594 sym
= XSYMBOL (variable
);
1597 switch (sym
->redirect
)
1599 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1600 case SYMBOL_PLAINVAL
:
1601 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1602 case SYMBOL_LOCALIZED
:
1603 blv
= SYMBOL_BLV (sym
);
1604 if (blv
->frame_local
)
1605 error ("Symbol %s may not be buffer-local",
1606 SDATA (SYMBOL_NAME (variable
)));
1608 case SYMBOL_FORWARDED
:
1609 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1610 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1611 error ("Symbol %s may not be buffer-local",
1612 SDATA (SYMBOL_NAME (variable
)));
1618 error ("Symbol %s may not be buffer-local",
1619 SDATA (SYMBOL_NAME (variable
)));
1621 if (blv
? blv
->local_if_set
1622 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1624 tem
= Fboundp (variable
);
1625 /* Make sure the symbol has a local value in this particular buffer,
1626 by setting it to the same value it already has. */
1627 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1632 blv
= make_blv (sym
, forwarded
, valcontents
);
1633 sym
->redirect
= SYMBOL_LOCALIZED
;
1634 SET_SYMBOL_BLV (sym
, blv
);
1637 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1638 if (let_shadows_global_binding_p (symbol
))
1639 message ("Making %s local to %s while let-bound!",
1640 SDATA (SYMBOL_NAME (variable
)),
1641 SDATA (BVAR (current_buffer
, name
)));
1645 /* Make sure this buffer has its own value of symbol. */
1646 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1647 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1650 if (let_shadows_buffer_binding_p (sym
))
1651 message ("Making %s buffer-local while locally let-bound!",
1652 SDATA (SYMBOL_NAME (variable
)));
1654 /* Swap out any local binding for some other buffer, and make
1655 sure the current value is permanently recorded, if it's the
1657 find_symbol_value (variable
);
1659 bset_local_var_alist
1661 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1662 BVAR (current_buffer
, local_var_alist
)));
1664 /* Make sure symbol does not think it is set up for this buffer;
1665 force it to look once again for this buffer's value. */
1666 if (current_buffer
== XBUFFER (blv
->where
))
1667 set_blv_where (blv
, Qnil
);
1668 set_blv_found (blv
, 0);
1671 /* If the symbol forwards into a C variable, then load the binding
1672 for this buffer now. If C code modifies the variable before we
1673 load the binding in, then that new value will clobber the default
1674 binding the next time we unload it. */
1676 swap_in_symval_forwarding (sym
, blv
);
1681 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1682 1, 1, "vKill Local Variable: ",
1683 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1684 From now on the default value will apply in this buffer. Return VARIABLE. */)
1685 (register Lisp_Object variable
)
1687 register Lisp_Object tem
;
1688 struct Lisp_Buffer_Local_Value
*blv
;
1689 struct Lisp_Symbol
*sym
;
1691 CHECK_SYMBOL (variable
);
1692 sym
= XSYMBOL (variable
);
1695 switch (sym
->redirect
)
1697 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1698 case SYMBOL_PLAINVAL
: return variable
;
1699 case SYMBOL_FORWARDED
:
1701 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1702 if (BUFFER_OBJFWDP (valcontents
))
1704 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1705 int idx
= PER_BUFFER_IDX (offset
);
1709 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1710 set_per_buffer_value (current_buffer
, offset
,
1711 per_buffer_default (offset
));
1716 case SYMBOL_LOCALIZED
:
1717 blv
= SYMBOL_BLV (sym
);
1718 if (blv
->frame_local
)
1724 /* Get rid of this buffer's alist element, if any. */
1725 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1726 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1728 bset_local_var_alist
1730 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1732 /* If the symbol is set up with the current buffer's binding
1733 loaded, recompute its value. We have to do it now, or else
1734 forwarded objects won't work right. */
1736 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1737 if (EQ (buf
, blv
->where
))
1739 set_blv_where (blv
, Qnil
);
1741 find_symbol_value (variable
);
1748 /* Lisp functions for creating and removing buffer-local variables. */
1750 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1751 when/if this is removed. */
1753 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1754 1, 1, "vMake Variable Frame Local: ",
1755 doc
: /* Enable VARIABLE to have frame-local bindings.
1756 This does not create any frame-local bindings for VARIABLE,
1757 it just makes them possible.
1759 A frame-local binding is actually a frame parameter value.
1760 If a frame F has a value for the frame parameter named VARIABLE,
1761 that also acts as a frame-local binding for VARIABLE in F--
1762 provided this function has been called to enable VARIABLE
1763 to have frame-local bindings at all.
1765 The only way to create a frame-local binding for VARIABLE in a frame
1766 is to set the VARIABLE frame parameter of that frame. See
1767 `modify-frame-parameters' for how to set frame parameters.
1769 Note that since Emacs 23.1, variables cannot be both buffer-local and
1770 frame-local any more (buffer-local bindings used to take precedence over
1771 frame-local bindings). */)
1772 (Lisp_Object variable
)
1775 union Lisp_Val_Fwd valcontents
;
1776 struct Lisp_Symbol
*sym
;
1777 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1779 CHECK_SYMBOL (variable
);
1780 sym
= XSYMBOL (variable
);
1783 switch (sym
->redirect
)
1785 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1786 case SYMBOL_PLAINVAL
:
1787 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1788 if (EQ (valcontents
.value
, Qunbound
))
1789 valcontents
.value
= Qnil
;
1791 case SYMBOL_LOCALIZED
:
1792 if (SYMBOL_BLV (sym
)->frame_local
)
1795 error ("Symbol %s may not be frame-local",
1796 SDATA (SYMBOL_NAME (variable
)));
1797 case SYMBOL_FORWARDED
:
1798 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1799 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1800 error ("Symbol %s may not be frame-local",
1801 SDATA (SYMBOL_NAME (variable
)));
1807 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1809 blv
= make_blv (sym
, forwarded
, valcontents
);
1810 blv
->frame_local
= 1;
1811 sym
->redirect
= SYMBOL_LOCALIZED
;
1812 SET_SYMBOL_BLV (sym
, blv
);
1815 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1816 if (let_shadows_global_binding_p (symbol
))
1817 message ("Making %s frame-local while let-bound!",
1818 SDATA (SYMBOL_NAME (variable
)));
1823 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1825 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1826 BUFFER defaults to the current buffer. */)
1827 (register Lisp_Object variable
, Lisp_Object buffer
)
1829 register struct buffer
*buf
;
1830 struct Lisp_Symbol
*sym
;
1833 buf
= current_buffer
;
1836 CHECK_BUFFER (buffer
);
1837 buf
= XBUFFER (buffer
);
1840 CHECK_SYMBOL (variable
);
1841 sym
= XSYMBOL (variable
);
1844 switch (sym
->redirect
)
1846 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1847 case SYMBOL_PLAINVAL
: return Qnil
;
1848 case SYMBOL_LOCALIZED
:
1850 Lisp_Object tail
, elt
, tmp
;
1851 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1852 XSETBUFFER (tmp
, buf
);
1853 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1855 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1858 if (EQ (variable
, XCAR (elt
)))
1860 eassert (!blv
->frame_local
);
1861 eassert (blv_found (blv
) || !EQ (blv
->where
, tmp
));
1865 eassert (!blv_found (blv
) || !EQ (blv
->where
, tmp
));
1868 case SYMBOL_FORWARDED
:
1870 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1871 if (BUFFER_OBJFWDP (valcontents
))
1873 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1874 int idx
= PER_BUFFER_IDX (offset
);
1875 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1884 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1886 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1887 More precisely, this means that setting the variable \(with `set' or`setq'),
1888 while it does not have a `let'-style binding that was made in BUFFER,
1889 will produce a buffer local binding. See Info node
1890 `(elisp)Creating Buffer-Local'.
1891 BUFFER defaults to the current buffer. */)
1892 (register Lisp_Object variable
, Lisp_Object buffer
)
1894 struct Lisp_Symbol
*sym
;
1896 CHECK_SYMBOL (variable
);
1897 sym
= XSYMBOL (variable
);
1900 switch (sym
->redirect
)
1902 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1903 case SYMBOL_PLAINVAL
: return Qnil
;
1904 case SYMBOL_LOCALIZED
:
1906 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1907 if (blv
->local_if_set
)
1909 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1910 return Flocal_variable_p (variable
, buffer
);
1912 case SYMBOL_FORWARDED
:
1913 /* All BUFFER_OBJFWD slots become local if they are set. */
1914 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1919 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1921 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1922 If the current binding is buffer-local, the value is the current buffer.
1923 If the current binding is frame-local, the value is the selected frame.
1924 If the current binding is global (the default), the value is nil. */)
1925 (register Lisp_Object variable
)
1927 struct Lisp_Symbol
*sym
;
1929 CHECK_SYMBOL (variable
);
1930 sym
= XSYMBOL (variable
);
1932 /* Make sure the current binding is actually swapped in. */
1933 find_symbol_value (variable
);
1936 switch (sym
->redirect
)
1938 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1939 case SYMBOL_PLAINVAL
: return Qnil
;
1940 case SYMBOL_FORWARDED
:
1942 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1943 if (KBOARD_OBJFWDP (valcontents
))
1944 return Fframe_terminal (Fselected_frame ());
1945 else if (!BUFFER_OBJFWDP (valcontents
))
1949 case SYMBOL_LOCALIZED
:
1950 /* For a local variable, record both the symbol and which
1951 buffer's or frame's value we are saving. */
1952 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1953 return Fcurrent_buffer ();
1954 else if (sym
->redirect
== SYMBOL_LOCALIZED
1955 && blv_found (SYMBOL_BLV (sym
)))
1956 return SYMBOL_BLV (sym
)->where
;
1963 /* This code is disabled now that we use the selected frame to return
1964 keyboard-local-values. */
1966 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1968 DEFUN ("terminal-local-value", Fterminal_local_value
,
1969 Sterminal_local_value
, 2, 2, 0,
1970 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1971 If SYMBOL is not a terminal-local variable, then return its normal
1972 value, like `symbol-value'.
1974 TERMINAL may be a terminal object, a frame, or nil (meaning the
1975 selected frame's terminal device). */)
1976 (Lisp_Object symbol
, Lisp_Object terminal
)
1979 struct terminal
*t
= get_terminal (terminal
, 1);
1980 push_kboard (t
->kboard
);
1981 result
= Fsymbol_value (symbol
);
1986 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1987 Sset_terminal_local_value
, 3, 3, 0,
1988 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1989 If VARIABLE is not a terminal-local variable, then set its normal
1990 binding, like `set'.
1992 TERMINAL may be a terminal object, a frame, or nil (meaning the
1993 selected frame's terminal device). */)
1994 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1997 struct terminal
*t
= get_terminal (terminal
, 1);
1998 push_kboard (d
->kboard
);
1999 result
= Fset (symbol
, value
);
2005 /* Find the function at the end of a chain of symbol function indirections. */
2007 /* If OBJECT is a symbol, find the end of its function chain and
2008 return the value found there. If OBJECT is not a symbol, just
2009 return it. If there is a cycle in the function chain, signal a
2010 cyclic-function-indirection error.
2012 This is like Findirect_function, except that it doesn't signal an
2013 error if the chain ends up unbound. */
2015 indirect_function (register Lisp_Object object
)
2017 Lisp_Object tortoise
, hare
;
2019 hare
= tortoise
= object
;
2023 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2025 hare
= XSYMBOL (hare
)->function
;
2026 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2028 hare
= XSYMBOL (hare
)->function
;
2030 tortoise
= XSYMBOL (tortoise
)->function
;
2032 if (EQ (hare
, tortoise
))
2033 xsignal1 (Qcyclic_function_indirection
, object
);
2039 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2040 doc
: /* Return the function at the end of OBJECT's function chain.
2041 If OBJECT is not a symbol, just return it. Otherwise, follow all
2042 function indirections to find the final function binding and return it.
2043 If the final symbol in the chain is unbound, signal a void-function error.
2044 Optional arg NOERROR non-nil means to return nil instead of signaling.
2045 Signal a cyclic-function-indirection error if there is a loop in the
2046 function chain of symbols. */)
2047 (register Lisp_Object object
, Lisp_Object noerror
)
2051 /* Optimize for no indirection. */
2053 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2054 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2055 result
= indirect_function (result
);
2056 if (!EQ (result
, Qunbound
))
2060 xsignal1 (Qvoid_function
, object
);
2065 /* Extract and set vector and string elements. */
2067 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2068 doc
: /* Return the element of ARRAY at index IDX.
2069 ARRAY may be a vector, a string, a char-table, a bool-vector,
2070 or a byte-code object. IDX starts at 0. */)
2071 (register Lisp_Object array
, Lisp_Object idx
)
2073 register EMACS_INT idxval
;
2076 idxval
= XINT (idx
);
2077 if (STRINGP (array
))
2080 ptrdiff_t idxval_byte
;
2082 if (idxval
< 0 || idxval
>= SCHARS (array
))
2083 args_out_of_range (array
, idx
);
2084 if (! STRING_MULTIBYTE (array
))
2085 return make_number ((unsigned char) SREF (array
, idxval
));
2086 idxval_byte
= string_char_to_byte (array
, idxval
);
2088 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2089 return make_number (c
);
2091 else if (BOOL_VECTOR_P (array
))
2095 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2096 args_out_of_range (array
, idx
);
2098 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2099 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2101 else if (CHAR_TABLE_P (array
))
2103 CHECK_CHARACTER (idx
);
2104 return CHAR_TABLE_REF (array
, idxval
);
2109 if (VECTORP (array
))
2110 size
= ASIZE (array
);
2111 else if (COMPILEDP (array
))
2112 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2114 wrong_type_argument (Qarrayp
, array
);
2116 if (idxval
< 0 || idxval
>= size
)
2117 args_out_of_range (array
, idx
);
2118 return AREF (array
, idxval
);
2122 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2123 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2124 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2125 bool-vector. IDX starts at 0. */)
2126 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2128 register EMACS_INT idxval
;
2131 idxval
= XINT (idx
);
2132 CHECK_ARRAY (array
, Qarrayp
);
2133 CHECK_IMPURE (array
);
2135 if (VECTORP (array
))
2137 if (idxval
< 0 || idxval
>= ASIZE (array
))
2138 args_out_of_range (array
, idx
);
2139 ASET (array
, idxval
, newelt
);
2141 else if (BOOL_VECTOR_P (array
))
2145 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2146 args_out_of_range (array
, idx
);
2148 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2150 if (! NILP (newelt
))
2151 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2153 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2154 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2156 else if (CHAR_TABLE_P (array
))
2158 CHECK_CHARACTER (idx
);
2159 CHAR_TABLE_SET (array
, idxval
, newelt
);
2165 if (idxval
< 0 || idxval
>= SCHARS (array
))
2166 args_out_of_range (array
, idx
);
2167 CHECK_CHARACTER (newelt
);
2168 c
= XFASTINT (newelt
);
2170 if (STRING_MULTIBYTE (array
))
2172 ptrdiff_t idxval_byte
, nbytes
;
2173 int prev_bytes
, new_bytes
;
2174 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2176 nbytes
= SBYTES (array
);
2177 idxval_byte
= string_char_to_byte (array
, idxval
);
2178 p1
= SDATA (array
) + idxval_byte
;
2179 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2180 new_bytes
= CHAR_STRING (c
, p0
);
2181 if (prev_bytes
!= new_bytes
)
2183 /* We must relocate the string data. */
2184 ptrdiff_t nchars
= SCHARS (array
);
2186 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2188 memcpy (str
, SDATA (array
), nbytes
);
2189 allocate_string_data (XSTRING (array
), nchars
,
2190 nbytes
+ new_bytes
- prev_bytes
);
2191 memcpy (SDATA (array
), str
, idxval_byte
);
2192 p1
= SDATA (array
) + idxval_byte
;
2193 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2194 nbytes
- (idxval_byte
+ prev_bytes
));
2196 clear_string_char_byte_cache ();
2203 if (! SINGLE_BYTE_CHAR_P (c
))
2207 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2208 if (SREF (array
, i
) >= 0x80)
2209 args_out_of_range (array
, newelt
);
2210 /* ARRAY is an ASCII string. Convert it to a multibyte
2211 string, and try `aset' again. */
2212 STRING_SET_MULTIBYTE (array
);
2213 return Faset (array
, idx
, newelt
);
2215 SSET (array
, idxval
, c
);
2222 /* Arithmetic functions */
2224 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2227 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2229 double f1
= 0, f2
= 0;
2232 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2233 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2235 if (FLOATP (num1
) || FLOATP (num2
))
2238 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2239 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2245 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2250 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2255 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2260 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2265 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2270 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2279 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2280 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2281 (register Lisp_Object num1
, Lisp_Object num2
)
2283 return arithcompare (num1
, num2
, equal
);
2286 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2287 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2288 (register Lisp_Object num1
, Lisp_Object num2
)
2290 return arithcompare (num1
, num2
, less
);
2293 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2294 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2295 (register Lisp_Object num1
, Lisp_Object num2
)
2297 return arithcompare (num1
, num2
, grtr
);
2300 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2301 doc
: /* Return t if first arg is less than or equal to second arg.
2302 Both must be numbers or markers. */)
2303 (register Lisp_Object num1
, Lisp_Object num2
)
2305 return arithcompare (num1
, num2
, less_or_equal
);
2308 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2309 doc
: /* Return t if first arg is greater than or equal to second arg.
2310 Both must be numbers or markers. */)
2311 (register Lisp_Object num1
, Lisp_Object num2
)
2313 return arithcompare (num1
, num2
, grtr_or_equal
);
2316 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2317 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2318 (register Lisp_Object num1
, Lisp_Object num2
)
2320 return arithcompare (num1
, num2
, notequal
);
2323 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2324 doc
: /* Return t if NUMBER is zero. */)
2325 (register Lisp_Object number
)
2327 CHECK_NUMBER_OR_FLOAT (number
);
2329 if (FLOATP (number
))
2331 if (XFLOAT_DATA (number
) == 0.0)
2341 /* Convert the cons-of-integers, integer, or float value C to an
2342 unsigned value with maximum value MAX. Signal an error if C does not
2343 have a valid format or is out of range. */
2345 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2348 uintmax_t val
IF_LINT (= 0);
2351 valid
= 0 <= XINT (c
);
2354 else if (FLOATP (c
))
2356 double d
= XFLOAT_DATA (c
);
2358 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2364 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2366 uintmax_t top
= XFASTINT (XCAR (c
));
2367 Lisp_Object rest
= XCDR (c
);
2368 if (top
<= UINTMAX_MAX
>> 24 >> 16
2370 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2371 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2373 uintmax_t mid
= XFASTINT (XCAR (rest
));
2374 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2377 else if (top
<= UINTMAX_MAX
>> 16)
2381 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2383 val
= top
<< 16 | XFASTINT (rest
);
2389 if (! (valid
&& val
<= max
))
2390 error ("Not an in-range integer, float, or cons of integers");
2394 /* Convert the cons-of-integers, integer, or float value C to a signed
2395 value with extrema MIN and MAX. Signal an error if C does not have
2396 a valid format or is out of range. */
2398 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2401 intmax_t val
IF_LINT (= 0);
2407 else if (FLOATP (c
))
2409 double d
= XFLOAT_DATA (c
);
2411 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2417 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2419 intmax_t top
= XINT (XCAR (c
));
2420 Lisp_Object rest
= XCDR (c
);
2421 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2423 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2424 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2426 intmax_t mid
= XFASTINT (XCAR (rest
));
2427 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2430 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2434 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2436 val
= top
<< 16 | XFASTINT (rest
);
2442 if (! (valid
&& min
<= val
&& val
<= max
))
2443 error ("Not an in-range integer, float, or cons of integers");
2447 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2448 doc
: /* Return the decimal representation of NUMBER as a string.
2449 Uses a minus sign if negative.
2450 NUMBER may be an integer or a floating point number. */)
2451 (Lisp_Object number
)
2453 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2456 CHECK_NUMBER_OR_FLOAT (number
);
2458 if (FLOATP (number
))
2459 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2461 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2463 return make_unibyte_string (buffer
, len
);
2466 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2467 doc
: /* Parse STRING as a decimal number and return the number.
2468 This parses both integers and floating point numbers.
2469 It ignores leading spaces and tabs, and all trailing chars.
2471 If BASE, interpret STRING as a number in that base. If BASE isn't
2472 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2473 If the base used is not 10, STRING is always parsed as integer. */)
2474 (register Lisp_Object string
, Lisp_Object base
)
2480 CHECK_STRING (string
);
2486 CHECK_NUMBER (base
);
2487 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2488 xsignal1 (Qargs_out_of_range
, base
);
2492 p
= SSDATA (string
);
2493 while (*p
== ' ' || *p
== '\t')
2496 val
= string_to_number (p
, b
, 1);
2497 return NILP (val
) ? make_number (0) : val
;
2513 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2514 ptrdiff_t, Lisp_Object
*);
2516 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2519 ptrdiff_t argnum
, ok_args
;
2520 EMACS_INT accum
= 0;
2521 EMACS_INT next
, ok_accum
;
2542 for (argnum
= 0; argnum
< nargs
; argnum
++)
2550 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2552 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2555 return float_arith_driver (ok_accum
, ok_args
, code
,
2558 next
= XINT (args
[argnum
]);
2562 if (INT_ADD_OVERFLOW (accum
, next
))
2570 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2575 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2578 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2580 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2582 accum
= ab
& INTMASK
;
2593 xsignal0 (Qarith_error
);
2607 if (!argnum
|| next
> accum
)
2611 if (!argnum
|| next
< accum
)
2617 XSETINT (val
, accum
);
2622 #define isnan(x) ((x) != (x))
2625 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2626 ptrdiff_t nargs
, Lisp_Object
*args
)
2628 register Lisp_Object val
;
2631 for (; argnum
< nargs
; argnum
++)
2633 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2634 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2638 next
= XFLOAT_DATA (val
);
2642 args
[argnum
] = val
; /* runs into a compiler bug. */
2643 next
= XINT (args
[argnum
]);
2651 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2661 if (! IEEE_FLOATING_POINT
&& next
== 0)
2662 xsignal0 (Qarith_error
);
2669 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2671 if (!argnum
|| isnan (next
) || next
> accum
)
2675 if (!argnum
|| isnan (next
) || next
< accum
)
2681 return make_float (accum
);
2685 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2686 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2687 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2688 (ptrdiff_t nargs
, Lisp_Object
*args
)
2690 return arith_driver (Aadd
, nargs
, args
);
2693 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2694 doc
: /* Negate number or subtract numbers or markers and return the result.
2695 With one arg, negates it. With more than one arg,
2696 subtracts all but the first from the first.
2697 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2698 (ptrdiff_t nargs
, Lisp_Object
*args
)
2700 return arith_driver (Asub
, nargs
, args
);
2703 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2704 doc
: /* Return product of any number of arguments, which are numbers or markers.
2705 usage: (* &rest NUMBERS-OR-MARKERS) */)
2706 (ptrdiff_t nargs
, Lisp_Object
*args
)
2708 return arith_driver (Amult
, nargs
, args
);
2711 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2712 doc
: /* Return first argument divided by all the remaining arguments.
2713 The arguments must be numbers or markers.
2714 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2715 (ptrdiff_t nargs
, Lisp_Object
*args
)
2718 for (argnum
= 2; argnum
< nargs
; argnum
++)
2719 if (FLOATP (args
[argnum
]))
2720 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2721 return arith_driver (Adiv
, nargs
, args
);
2724 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2725 doc
: /* Return remainder of X divided by Y.
2726 Both must be integers or markers. */)
2727 (register Lisp_Object x
, Lisp_Object y
)
2731 CHECK_NUMBER_COERCE_MARKER (x
);
2732 CHECK_NUMBER_COERCE_MARKER (y
);
2735 xsignal0 (Qarith_error
);
2737 XSETINT (val
, XINT (x
) % XINT (y
));
2743 fmod (double f1
, double f2
)
2750 /* If the magnitude of the result exceeds that of the divisor, or
2751 the sign of the result does not agree with that of the dividend,
2752 iterate with the reduced value. This does not yield a
2753 particularly accurate result, but at least it will be in the
2754 range promised by fmod. */
2756 r
-= f2
* floor (r
/ f2
);
2757 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2761 #endif /* ! HAVE_FMOD */
2763 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2764 doc
: /* Return X modulo Y.
2765 The result falls between zero (inclusive) and Y (exclusive).
2766 Both X and Y must be numbers or markers. */)
2767 (register Lisp_Object x
, Lisp_Object y
)
2772 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2773 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2775 if (FLOATP (x
) || FLOATP (y
))
2776 return fmod_float (x
, y
);
2782 xsignal0 (Qarith_error
);
2786 /* If the "remainder" comes out with the wrong sign, fix it. */
2787 if (i2
< 0 ? i1
> 0 : i1
< 0)
2794 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2795 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2796 The value is always a number; markers are converted to numbers.
2797 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2798 (ptrdiff_t nargs
, Lisp_Object
*args
)
2800 return arith_driver (Amax
, nargs
, args
);
2803 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2804 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2805 The value is always a number; markers are converted to numbers.
2806 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2807 (ptrdiff_t nargs
, Lisp_Object
*args
)
2809 return arith_driver (Amin
, nargs
, args
);
2812 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2813 doc
: /* Return bitwise-and of all the arguments.
2814 Arguments may be integers, or markers converted to integers.
2815 usage: (logand &rest INTS-OR-MARKERS) */)
2816 (ptrdiff_t nargs
, Lisp_Object
*args
)
2818 return arith_driver (Alogand
, nargs
, args
);
2821 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2822 doc
: /* Return bitwise-or of all the arguments.
2823 Arguments may be integers, or markers converted to integers.
2824 usage: (logior &rest INTS-OR-MARKERS) */)
2825 (ptrdiff_t nargs
, Lisp_Object
*args
)
2827 return arith_driver (Alogior
, nargs
, args
);
2830 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2831 doc
: /* Return bitwise-exclusive-or of all the arguments.
2832 Arguments may be integers, or markers converted to integers.
2833 usage: (logxor &rest INTS-OR-MARKERS) */)
2834 (ptrdiff_t nargs
, Lisp_Object
*args
)
2836 return arith_driver (Alogxor
, nargs
, args
);
2839 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2840 doc
: /* Return VALUE with its bits shifted left by COUNT.
2841 If COUNT is negative, shifting is actually to the right.
2842 In this case, the sign bit is duplicated. */)
2843 (register Lisp_Object value
, Lisp_Object count
)
2845 register Lisp_Object val
;
2847 CHECK_NUMBER (value
);
2848 CHECK_NUMBER (count
);
2850 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2852 else if (XINT (count
) > 0)
2853 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2854 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2855 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2857 XSETINT (val
, XINT (value
) >> -XINT (count
));
2861 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2862 doc
: /* Return VALUE with its bits shifted left by COUNT.
2863 If COUNT is negative, shifting is actually to the right.
2864 In this case, zeros are shifted in on the left. */)
2865 (register Lisp_Object value
, Lisp_Object count
)
2867 register Lisp_Object val
;
2869 CHECK_NUMBER (value
);
2870 CHECK_NUMBER (count
);
2872 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2874 else if (XINT (count
) > 0)
2875 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2876 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2879 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2883 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2884 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2885 Markers are converted to integers. */)
2886 (register Lisp_Object number
)
2888 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2890 if (FLOATP (number
))
2891 return (make_float (1.0 + XFLOAT_DATA (number
)));
2893 XSETINT (number
, XINT (number
) + 1);
2897 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2898 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2899 Markers are converted to integers. */)
2900 (register Lisp_Object number
)
2902 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2904 if (FLOATP (number
))
2905 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2907 XSETINT (number
, XINT (number
) - 1);
2911 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2912 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2913 (register Lisp_Object number
)
2915 CHECK_NUMBER (number
);
2916 XSETINT (number
, ~XINT (number
));
2920 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2921 doc
: /* Return the byteorder for the machine.
2922 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2923 lowercase l) for small endian machines. */)
2926 unsigned i
= 0x04030201;
2927 int order
= *(char *)&i
== 1 ? 108 : 66;
2929 return make_number (order
);
2937 Lisp_Object error_tail
, arith_tail
;
2939 DEFSYM (Qquote
, "quote");
2940 DEFSYM (Qlambda
, "lambda");
2941 DEFSYM (Qsubr
, "subr");
2942 DEFSYM (Qerror_conditions
, "error-conditions");
2943 DEFSYM (Qerror_message
, "error-message");
2944 DEFSYM (Qtop_level
, "top-level");
2946 DEFSYM (Qerror
, "error");
2947 DEFSYM (Quser_error
, "user-error");
2948 DEFSYM (Qquit
, "quit");
2949 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2950 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2951 DEFSYM (Qvoid_function
, "void-function");
2952 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2953 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2954 DEFSYM (Qvoid_variable
, "void-variable");
2955 DEFSYM (Qsetting_constant
, "setting-constant");
2956 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2958 DEFSYM (Qinvalid_function
, "invalid-function");
2959 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2960 DEFSYM (Qno_catch
, "no-catch");
2961 DEFSYM (Qend_of_file
, "end-of-file");
2962 DEFSYM (Qarith_error
, "arith-error");
2963 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2964 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2965 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2966 DEFSYM (Qtext_read_only
, "text-read-only");
2967 DEFSYM (Qmark_inactive
, "mark-inactive");
2969 DEFSYM (Qlistp
, "listp");
2970 DEFSYM (Qconsp
, "consp");
2971 DEFSYM (Qsymbolp
, "symbolp");
2972 DEFSYM (Qkeywordp
, "keywordp");
2973 DEFSYM (Qintegerp
, "integerp");
2974 DEFSYM (Qnatnump
, "natnump");
2975 DEFSYM (Qwholenump
, "wholenump");
2976 DEFSYM (Qstringp
, "stringp");
2977 DEFSYM (Qarrayp
, "arrayp");
2978 DEFSYM (Qsequencep
, "sequencep");
2979 DEFSYM (Qbufferp
, "bufferp");
2980 DEFSYM (Qvectorp
, "vectorp");
2981 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2982 DEFSYM (Qmarkerp
, "markerp");
2983 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
2984 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
2985 DEFSYM (Qboundp
, "boundp");
2986 DEFSYM (Qfboundp
, "fboundp");
2988 DEFSYM (Qfloatp
, "floatp");
2989 DEFSYM (Qnumberp
, "numberp");
2990 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
2992 DEFSYM (Qchar_table_p
, "char-table-p");
2993 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
2995 DEFSYM (Qsubrp
, "subrp");
2996 DEFSYM (Qunevalled
, "unevalled");
2997 DEFSYM (Qmany
, "many");
2999 DEFSYM (Qcdr
, "cdr");
3001 /* Handle automatic advice activation. */
3002 DEFSYM (Qad_advice_info
, "ad-advice-info");
3003 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3005 error_tail
= pure_cons (Qerror
, Qnil
);
3007 /* ERROR is used as a signaler for random errors for which nothing else is
3010 Fput (Qerror
, Qerror_conditions
,
3012 Fput (Qerror
, Qerror_message
,
3013 build_pure_c_string ("error"));
3015 #define PUT_ERROR(sym, tail, msg) \
3016 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3017 Fput (sym, Qerror_message, build_pure_c_string (msg))
3019 PUT_ERROR (Qquit
, Qnil
, "Quit");
3021 PUT_ERROR (Quser_error
, error_tail
, "");
3022 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3023 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3024 PUT_ERROR (Qvoid_function
, error_tail
,
3025 "Symbol's function definition is void");
3026 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3027 "Symbol's chain of function indirections contains a loop");
3028 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3029 "Symbol's chain of variable indirections contains a loop");
3030 DEFSYM (Qcircular_list
, "circular-list");
3031 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3032 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3033 PUT_ERROR (Qsetting_constant
, error_tail
,
3034 "Attempt to set a constant symbol");
3035 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3036 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3037 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3038 "Wrong number of arguments");
3039 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3040 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3042 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3043 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3044 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3046 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3047 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3048 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3049 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3050 "Text is read-only");
3052 DEFSYM (Qrange_error
, "range-error");
3053 DEFSYM (Qdomain_error
, "domain-error");
3054 DEFSYM (Qsingularity_error
, "singularity-error");
3055 DEFSYM (Qoverflow_error
, "overflow-error");
3056 DEFSYM (Qunderflow_error
, "underflow-error");
3058 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3060 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3062 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3063 "Arithmetic singularity error");
3065 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3066 "Arithmetic overflow error");
3067 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3068 "Arithmetic underflow error");
3072 staticpro (&Qunbound
);
3074 /* Types that type-of returns. */
3075 DEFSYM (Qinteger
, "integer");
3076 DEFSYM (Qsymbol
, "symbol");
3077 DEFSYM (Qstring
, "string");
3078 DEFSYM (Qcons
, "cons");
3079 DEFSYM (Qmarker
, "marker");
3080 DEFSYM (Qoverlay
, "overlay");
3081 DEFSYM (Qfloat
, "float");
3082 DEFSYM (Qwindow_configuration
, "window-configuration");
3083 DEFSYM (Qprocess
, "process");
3084 DEFSYM (Qwindow
, "window");
3085 DEFSYM (Qcompiled_function
, "compiled-function");
3086 DEFSYM (Qbuffer
, "buffer");
3087 DEFSYM (Qframe
, "frame");
3088 DEFSYM (Qvector
, "vector");
3089 DEFSYM (Qchar_table
, "char-table");
3090 DEFSYM (Qbool_vector
, "bool-vector");
3091 DEFSYM (Qhash_table
, "hash-table");
3092 DEFSYM (Qmisc
, "misc");
3094 DEFSYM (Qdefun
, "defun");
3096 DEFSYM (Qfont_spec
, "font-spec");
3097 DEFSYM (Qfont_entity
, "font-entity");
3098 DEFSYM (Qfont_object
, "font-object");
3100 DEFSYM (Qinteractive_form
, "interactive-form");
3102 defsubr (&Sindirect_variable
);
3103 defsubr (&Sinteractive_form
);
3106 defsubr (&Stype_of
);
3111 defsubr (&Sintegerp
);
3112 defsubr (&Sinteger_or_marker_p
);
3113 defsubr (&Snumberp
);
3114 defsubr (&Snumber_or_marker_p
);
3116 defsubr (&Snatnump
);
3117 defsubr (&Ssymbolp
);
3118 defsubr (&Skeywordp
);
3119 defsubr (&Sstringp
);
3120 defsubr (&Smultibyte_string_p
);
3121 defsubr (&Svectorp
);
3122 defsubr (&Schar_table_p
);
3123 defsubr (&Svector_or_char_table_p
);
3124 defsubr (&Sbool_vector_p
);
3126 defsubr (&Ssequencep
);
3127 defsubr (&Sbufferp
);
3128 defsubr (&Smarkerp
);
3130 defsubr (&Sbyte_code_function_p
);
3131 defsubr (&Schar_or_string_p
);
3134 defsubr (&Scar_safe
);
3135 defsubr (&Scdr_safe
);
3138 defsubr (&Ssymbol_function
);
3139 defsubr (&Sindirect_function
);
3140 defsubr (&Ssymbol_plist
);
3141 defsubr (&Ssymbol_name
);
3142 defsubr (&Smakunbound
);
3143 defsubr (&Sfmakunbound
);
3145 defsubr (&Sfboundp
);
3147 defsubr (&Sdefalias
);
3148 defsubr (&Ssetplist
);
3149 defsubr (&Ssymbol_value
);
3151 defsubr (&Sdefault_boundp
);
3152 defsubr (&Sdefault_value
);
3153 defsubr (&Sset_default
);
3154 defsubr (&Ssetq_default
);
3155 defsubr (&Smake_variable_buffer_local
);
3156 defsubr (&Smake_local_variable
);
3157 defsubr (&Skill_local_variable
);
3158 defsubr (&Smake_variable_frame_local
);
3159 defsubr (&Slocal_variable_p
);
3160 defsubr (&Slocal_variable_if_set_p
);
3161 defsubr (&Svariable_binding_locus
);
3162 #if 0 /* XXX Remove this. --lorentey */
3163 defsubr (&Sterminal_local_value
);
3164 defsubr (&Sset_terminal_local_value
);
3168 defsubr (&Snumber_to_string
);
3169 defsubr (&Sstring_to_number
);
3170 defsubr (&Seqlsign
);
3193 defsubr (&Sbyteorder
);
3194 defsubr (&Ssubr_arity
);
3195 defsubr (&Ssubr_name
);
3197 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3199 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3200 doc
: /* The largest value that is representable in a Lisp integer. */);
3201 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3202 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3204 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3205 doc
: /* The smallest value that is representable in a Lisp integer. */);
3206 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3207 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3210 #ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
3214 arith_error (int signo
)
3216 sigsetmask (SIGEMPTYMASK
);
3218 SIGNAL_THREAD_CHECK (signo
);
3219 xsignal0 (Qarith_error
);
3225 /* Don't do this if just dumping out.
3226 We don't want to call `signal' in this case
3227 so that we don't have trouble with dumping
3228 signal-delivering routines in an inconsistent state. */
3232 #endif /* CANNOT_DUMP */
3233 signal (SIGFPE
, arith_error
);