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
, Qinterval
, Qfloat
, Qvector
;
87 Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmisc
;
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 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 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 blv
->valcell
= blv
->defcell
;
972 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
974 /* Indicate that the global binding is set up now. */
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 blv
->where
= 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 blv
->valcell
= 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 1 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 zero, 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 nonzero, we don't do that. */
1126 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1128 int 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
)));
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 (XBUFFER (where
), local_var_alist
,
1217 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1221 /* Record which binding is now loaded. */
1222 blv
->valcell
= tem1
;
1225 /* Store the new value in the cons cell. */
1226 SET_BLV_VALUE (blv
, newval
);
1231 /* If storing void (making the symbol void), forward only through
1232 buffer-local indicator, not through Lisp_Objfwd, etc. */
1235 store_symval_forwarding (blv
->fwd
, newval
,
1237 ? XBUFFER (where
) : current_buffer
);
1241 case SYMBOL_FORWARDED
:
1244 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1245 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1246 if (BUFFER_OBJFWDP (innercontents
))
1248 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1249 int idx
= PER_BUFFER_IDX (offset
);
1252 && !let_shadows_buffer_binding_p (sym
))
1253 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1257 { /* If storing void (making the symbol void), forward only through
1258 buffer-local indicator, not through Lisp_Objfwd, etc. */
1259 sym
->redirect
= SYMBOL_PLAINVAL
;
1260 SET_SYMBOL_VAL (sym
, newval
);
1263 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1271 /* Access or set a buffer-local symbol's default value. */
1273 /* Return the default value of SYMBOL, but don't check for voidness.
1274 Return Qunbound if it is void. */
1277 default_value (Lisp_Object symbol
)
1279 struct Lisp_Symbol
*sym
;
1281 CHECK_SYMBOL (symbol
);
1282 sym
= XSYMBOL (symbol
);
1285 switch (sym
->redirect
)
1287 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1288 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1289 case SYMBOL_LOCALIZED
:
1291 /* If var is set up for a buffer that lacks a local value for it,
1292 the current value is nominally the default value.
1293 But the `realvalue' slot may be more up to date, since
1294 ordinary setq stores just that slot. So use that. */
1295 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1296 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1297 return do_symval_forwarding (blv
->fwd
);
1299 return XCDR (blv
->defcell
);
1301 case SYMBOL_FORWARDED
:
1303 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1305 /* For a built-in buffer-local variable, get the default value
1306 rather than letting do_symval_forwarding get the current value. */
1307 if (BUFFER_OBJFWDP (valcontents
))
1309 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1310 if (PER_BUFFER_IDX (offset
) != 0)
1311 return PER_BUFFER_DEFAULT (offset
);
1314 /* For other variables, get the current value. */
1315 return do_symval_forwarding (valcontents
);
1321 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1322 doc
: /* Return t if SYMBOL has a non-void default value.
1323 This is the value that is seen in buffers that do not have their own values
1324 for this variable. */)
1325 (Lisp_Object symbol
)
1327 register Lisp_Object value
;
1329 value
= default_value (symbol
);
1330 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1333 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1334 doc
: /* Return SYMBOL's default value.
1335 This is the value that is seen in buffers that do not have their own values
1336 for this variable. The default value is meaningful for variables with
1337 local bindings in certain buffers. */)
1338 (Lisp_Object symbol
)
1340 register Lisp_Object value
;
1342 value
= default_value (symbol
);
1343 if (!EQ (value
, Qunbound
))
1346 xsignal1 (Qvoid_variable
, symbol
);
1349 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1350 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1351 The default value is seen in buffers that do not have their own values
1352 for this variable. */)
1353 (Lisp_Object symbol
, Lisp_Object value
)
1355 struct Lisp_Symbol
*sym
;
1357 CHECK_SYMBOL (symbol
);
1358 if (SYMBOL_CONSTANT_P (symbol
))
1360 if (NILP (Fkeywordp (symbol
))
1361 || !EQ (value
, Fdefault_value (symbol
)))
1362 xsignal1 (Qsetting_constant
, symbol
);
1364 /* Allow setting keywords to their own value. */
1367 sym
= XSYMBOL (symbol
);
1370 switch (sym
->redirect
)
1372 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1373 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1374 case SYMBOL_LOCALIZED
:
1376 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1378 /* Store new value into the DEFAULT-VALUE slot. */
1379 XSETCDR (blv
->defcell
, value
);
1381 /* If the default binding is now loaded, set the REALVALUE slot too. */
1382 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1383 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1386 case SYMBOL_FORWARDED
:
1388 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1390 /* Handle variables like case-fold-search that have special slots
1392 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1393 if (BUFFER_OBJFWDP (valcontents
))
1395 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1396 int idx
= PER_BUFFER_IDX (offset
);
1398 PER_BUFFER_DEFAULT (offset
) = value
;
1400 /* If this variable is not always local in all buffers,
1401 set it in the buffers that don't nominally have a local value. */
1407 if (!PER_BUFFER_VALUE_P (b
, idx
))
1408 PER_BUFFER_VALUE (b
, offset
) = value
;
1413 return Fset (symbol
, value
);
1419 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1420 doc
: /* Set the default value of variable VAR to VALUE.
1421 VAR, the variable name, is literal (not evaluated);
1422 VALUE is an expression: it is evaluated and its value returned.
1423 The default value of a variable is seen in buffers
1424 that do not have their own values for the variable.
1426 More generally, you can use multiple variables and values, as in
1427 (setq-default VAR VALUE VAR VALUE...)
1428 This sets each VAR's default value to the corresponding VALUE.
1429 The VALUE for the Nth VAR can refer to the new default values
1431 usage: (setq-default [VAR VALUE]...) */)
1434 register Lisp_Object args_left
;
1435 register Lisp_Object val
, symbol
;
1436 struct gcpro gcpro1
;
1446 val
= eval_sub (Fcar (Fcdr (args_left
)));
1447 symbol
= XCAR (args_left
);
1448 Fset_default (symbol
, val
);
1449 args_left
= Fcdr (XCDR (args_left
));
1451 while (!NILP (args_left
));
1457 /* Lisp functions for creating and removing buffer-local variables. */
1462 union Lisp_Fwd
*fwd
;
1465 static struct Lisp_Buffer_Local_Value
*
1466 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1468 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1472 XSETSYMBOL (symbol
, sym
);
1473 tem
= Fcons (symbol
, (forwarded
1474 ? do_symval_forwarding (valcontents
.fwd
)
1475 : valcontents
.value
));
1477 /* Buffer_Local_Values cannot have as realval a buffer-local
1478 or keyboard-local forwarding. */
1479 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1480 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1481 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1483 blv
->frame_local
= 0;
1484 blv
->local_if_set
= 0;
1487 SET_BLV_FOUND (blv
, 0);
1491 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1492 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1493 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1494 At any time, the value for the current buffer is in effect,
1495 unless the variable has never been set in this buffer,
1496 in which case the default value is in effect.
1497 Note that binding the variable with `let', or setting it while
1498 a `let'-style binding made in this buffer is in effect,
1499 does not make the variable buffer-local. Return VARIABLE.
1501 In most cases it is better to use `make-local-variable',
1502 which makes a variable local in just one buffer.
1504 The function `default-value' gets the default value and `set-default' sets it. */)
1505 (register Lisp_Object variable
)
1507 struct Lisp_Symbol
*sym
;
1508 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1509 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1510 int forwarded
IF_LINT (= 0);
1512 CHECK_SYMBOL (variable
);
1513 sym
= XSYMBOL (variable
);
1516 switch (sym
->redirect
)
1518 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1519 case SYMBOL_PLAINVAL
:
1520 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1521 if (EQ (valcontents
.value
, Qunbound
))
1522 valcontents
.value
= Qnil
;
1524 case SYMBOL_LOCALIZED
:
1525 blv
= SYMBOL_BLV (sym
);
1526 if (blv
->frame_local
)
1527 error ("Symbol %s may not be buffer-local",
1528 SDATA (SYMBOL_NAME (variable
)));
1530 case SYMBOL_FORWARDED
:
1531 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1532 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1533 error ("Symbol %s may not be buffer-local",
1534 SDATA (SYMBOL_NAME (variable
)));
1535 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1542 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1546 blv
= make_blv (sym
, forwarded
, valcontents
);
1547 sym
->redirect
= SYMBOL_LOCALIZED
;
1548 SET_SYMBOL_BLV (sym
, blv
);
1551 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1552 if (let_shadows_global_binding_p (symbol
))
1553 message ("Making %s buffer-local while let-bound!",
1554 SDATA (SYMBOL_NAME (variable
)));
1558 blv
->local_if_set
= 1;
1562 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1563 1, 1, "vMake Local Variable: ",
1564 doc
: /* Make VARIABLE have a separate value in the current buffer.
1565 Other buffers will continue to share a common default value.
1566 \(The buffer-local value of VARIABLE starts out as the same value
1567 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1570 If the variable is already arranged to become local when set,
1571 this function causes a local value to exist for this buffer,
1572 just as setting the variable would do.
1574 This function returns VARIABLE, and therefore
1575 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1578 See also `make-variable-buffer-local'.
1580 Do not use `make-local-variable' to make a hook variable buffer-local.
1581 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1582 (register Lisp_Object variable
)
1584 register Lisp_Object tem
;
1585 int forwarded
IF_LINT (= 0);
1586 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1587 struct Lisp_Symbol
*sym
;
1588 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1590 CHECK_SYMBOL (variable
);
1591 sym
= XSYMBOL (variable
);
1594 switch (sym
->redirect
)
1596 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1597 case SYMBOL_PLAINVAL
:
1598 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1599 case SYMBOL_LOCALIZED
:
1600 blv
= SYMBOL_BLV (sym
);
1601 if (blv
->frame_local
)
1602 error ("Symbol %s may not be buffer-local",
1603 SDATA (SYMBOL_NAME (variable
)));
1605 case SYMBOL_FORWARDED
:
1606 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1607 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1608 error ("Symbol %s may not be buffer-local",
1609 SDATA (SYMBOL_NAME (variable
)));
1615 error ("Symbol %s may not be buffer-local",
1616 SDATA (SYMBOL_NAME (variable
)));
1618 if (blv
? blv
->local_if_set
1619 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1621 tem
= Fboundp (variable
);
1622 /* Make sure the symbol has a local value in this particular buffer,
1623 by setting it to the same value it already has. */
1624 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1629 blv
= make_blv (sym
, forwarded
, valcontents
);
1630 sym
->redirect
= SYMBOL_LOCALIZED
;
1631 SET_SYMBOL_BLV (sym
, blv
);
1634 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1635 if (let_shadows_global_binding_p (symbol
))
1636 message ("Making %s local to %s while let-bound!",
1637 SDATA (SYMBOL_NAME (variable
)),
1638 SDATA (BVAR (current_buffer
, name
)));
1642 /* Make sure this buffer has its own value of symbol. */
1643 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1644 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1647 if (let_shadows_buffer_binding_p (sym
))
1648 message ("Making %s buffer-local while locally let-bound!",
1649 SDATA (SYMBOL_NAME (variable
)));
1651 /* Swap out any local binding for some other buffer, and make
1652 sure the current value is permanently recorded, if it's the
1654 find_symbol_value (variable
);
1656 BSET (current_buffer
, local_var_alist
,
1657 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1658 BVAR (current_buffer
, local_var_alist
)));
1660 /* Make sure symbol does not think it is set up for this buffer;
1661 force it to look once again for this buffer's value. */
1662 if (current_buffer
== XBUFFER (blv
->where
))
1664 /* blv->valcell = blv->defcell;
1665 * SET_BLV_FOUND (blv, 0); */
1669 /* If the symbol forwards into a C variable, then load the binding
1670 for this buffer now. If C code modifies the variable before we
1671 load the binding in, then that new value will clobber the default
1672 binding the next time we unload it. */
1674 swap_in_symval_forwarding (sym
, blv
);
1679 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1680 1, 1, "vKill Local Variable: ",
1681 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1682 From now on the default value will apply in this buffer. Return VARIABLE. */)
1683 (register Lisp_Object variable
)
1685 register Lisp_Object tem
;
1686 struct Lisp_Buffer_Local_Value
*blv
;
1687 struct Lisp_Symbol
*sym
;
1689 CHECK_SYMBOL (variable
);
1690 sym
= XSYMBOL (variable
);
1693 switch (sym
->redirect
)
1695 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1696 case SYMBOL_PLAINVAL
: return variable
;
1697 case SYMBOL_FORWARDED
:
1699 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1700 if (BUFFER_OBJFWDP (valcontents
))
1702 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1703 int idx
= PER_BUFFER_IDX (offset
);
1707 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1708 PER_BUFFER_VALUE (current_buffer
, offset
)
1709 = PER_BUFFER_DEFAULT (offset
);
1714 case SYMBOL_LOCALIZED
:
1715 blv
= SYMBOL_BLV (sym
);
1716 if (blv
->frame_local
)
1722 /* Get rid of this buffer's alist element, if any. */
1723 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1724 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1726 BSET (current_buffer
, local_var_alist
,
1727 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1729 /* If the symbol is set up with the current buffer's binding
1730 loaded, recompute its value. We have to do it now, or else
1731 forwarded objects won't work right. */
1733 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1734 if (EQ (buf
, blv
->where
))
1737 /* blv->valcell = blv->defcell;
1738 * SET_BLV_FOUND (blv, 0); */
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 (register 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
)));
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
))
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
);
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
;
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
)
2517 register Lisp_Object val
;
2519 register EMACS_INT accum
= 0;
2520 register EMACS_INT next
;
2544 for (argnum
= 0; argnum
< nargs
; argnum
++)
2552 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2554 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2557 return float_arith_driver (ok_accum
, ok_args
, code
,
2560 next
= XINT (args
[argnum
]);
2564 if (INT_ADD_OVERFLOW (accum
, next
))
2572 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2577 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2580 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2582 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2584 accum
= ab
& INTMASK
;
2595 xsignal0 (Qarith_error
);
2609 if (!argnum
|| next
> accum
)
2613 if (!argnum
|| next
< accum
)
2619 XSETINT (val
, accum
);
2624 #define isnan(x) ((x) != (x))
2627 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2628 ptrdiff_t nargs
, Lisp_Object
*args
)
2630 register Lisp_Object val
;
2633 for (; argnum
< nargs
; argnum
++)
2635 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2636 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2640 next
= XFLOAT_DATA (val
);
2644 args
[argnum
] = val
; /* runs into a compiler bug. */
2645 next
= XINT (args
[argnum
]);
2653 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2663 if (! IEEE_FLOATING_POINT
&& next
== 0)
2664 xsignal0 (Qarith_error
);
2671 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2673 if (!argnum
|| isnan (next
) || next
> accum
)
2677 if (!argnum
|| isnan (next
) || next
< accum
)
2683 return make_float (accum
);
2687 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2688 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2689 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2690 (ptrdiff_t nargs
, Lisp_Object
*args
)
2692 return arith_driver (Aadd
, nargs
, args
);
2695 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2696 doc
: /* Negate number or subtract numbers or markers and return the result.
2697 With one arg, negates it. With more than one arg,
2698 subtracts all but the first from the first.
2699 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2700 (ptrdiff_t nargs
, Lisp_Object
*args
)
2702 return arith_driver (Asub
, nargs
, args
);
2705 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2706 doc
: /* Return product of any number of arguments, which are numbers or markers.
2707 usage: (* &rest NUMBERS-OR-MARKERS) */)
2708 (ptrdiff_t nargs
, Lisp_Object
*args
)
2710 return arith_driver (Amult
, nargs
, args
);
2713 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2714 doc
: /* Return first argument divided by all the remaining arguments.
2715 The arguments must be numbers or markers.
2716 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2717 (ptrdiff_t nargs
, Lisp_Object
*args
)
2720 for (argnum
= 2; argnum
< nargs
; argnum
++)
2721 if (FLOATP (args
[argnum
]))
2722 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2723 return arith_driver (Adiv
, nargs
, args
);
2726 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2727 doc
: /* Return remainder of X divided by Y.
2728 Both must be integers or markers. */)
2729 (register Lisp_Object x
, Lisp_Object y
)
2733 CHECK_NUMBER_COERCE_MARKER (x
);
2734 CHECK_NUMBER_COERCE_MARKER (y
);
2737 xsignal0 (Qarith_error
);
2739 XSETINT (val
, XINT (x
) % XINT (y
));
2745 fmod (double f1
, double f2
)
2752 /* If the magnitude of the result exceeds that of the divisor, or
2753 the sign of the result does not agree with that of the dividend,
2754 iterate with the reduced value. This does not yield a
2755 particularly accurate result, but at least it will be in the
2756 range promised by fmod. */
2758 r
-= f2
* floor (r
/ f2
);
2759 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2763 #endif /* ! HAVE_FMOD */
2765 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2766 doc
: /* Return X modulo Y.
2767 The result falls between zero (inclusive) and Y (exclusive).
2768 Both X and Y must be numbers or markers. */)
2769 (register Lisp_Object x
, Lisp_Object y
)
2774 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2775 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2777 if (FLOATP (x
) || FLOATP (y
))
2778 return fmod_float (x
, y
);
2784 xsignal0 (Qarith_error
);
2788 /* If the "remainder" comes out with the wrong sign, fix it. */
2789 if (i2
< 0 ? i1
> 0 : i1
< 0)
2796 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2797 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2798 The value is always a number; markers are converted to numbers.
2799 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2800 (ptrdiff_t nargs
, Lisp_Object
*args
)
2802 return arith_driver (Amax
, nargs
, args
);
2805 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2806 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2807 The value is always a number; markers are converted to numbers.
2808 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2809 (ptrdiff_t nargs
, Lisp_Object
*args
)
2811 return arith_driver (Amin
, nargs
, args
);
2814 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2815 doc
: /* Return bitwise-and of all the arguments.
2816 Arguments may be integers, or markers converted to integers.
2817 usage: (logand &rest INTS-OR-MARKERS) */)
2818 (ptrdiff_t nargs
, Lisp_Object
*args
)
2820 return arith_driver (Alogand
, nargs
, args
);
2823 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2824 doc
: /* Return bitwise-or of all the arguments.
2825 Arguments may be integers, or markers converted to integers.
2826 usage: (logior &rest INTS-OR-MARKERS) */)
2827 (ptrdiff_t nargs
, Lisp_Object
*args
)
2829 return arith_driver (Alogior
, nargs
, args
);
2832 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2833 doc
: /* Return bitwise-exclusive-or of all the arguments.
2834 Arguments may be integers, or markers converted to integers.
2835 usage: (logxor &rest INTS-OR-MARKERS) */)
2836 (ptrdiff_t nargs
, Lisp_Object
*args
)
2838 return arith_driver (Alogxor
, nargs
, args
);
2841 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2842 doc
: /* Return VALUE with its bits shifted left by COUNT.
2843 If COUNT is negative, shifting is actually to the right.
2844 In this case, the sign bit is duplicated. */)
2845 (register Lisp_Object value
, Lisp_Object count
)
2847 register Lisp_Object val
;
2849 CHECK_NUMBER (value
);
2850 CHECK_NUMBER (count
);
2852 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2854 else if (XINT (count
) > 0)
2855 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2856 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2857 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2859 XSETINT (val
, XINT (value
) >> -XINT (count
));
2863 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2864 doc
: /* Return VALUE with its bits shifted left by COUNT.
2865 If COUNT is negative, shifting is actually to the right.
2866 In this case, zeros are shifted in on the left. */)
2867 (register Lisp_Object value
, Lisp_Object count
)
2869 register Lisp_Object val
;
2871 CHECK_NUMBER (value
);
2872 CHECK_NUMBER (count
);
2874 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2876 else if (XINT (count
) > 0)
2877 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2878 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2881 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2885 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2886 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2887 Markers are converted to integers. */)
2888 (register Lisp_Object number
)
2890 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2892 if (FLOATP (number
))
2893 return (make_float (1.0 + XFLOAT_DATA (number
)));
2895 XSETINT (number
, XINT (number
) + 1);
2899 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2900 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2901 Markers are converted to integers. */)
2902 (register Lisp_Object number
)
2904 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2906 if (FLOATP (number
))
2907 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2909 XSETINT (number
, XINT (number
) - 1);
2913 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2914 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2915 (register Lisp_Object number
)
2917 CHECK_NUMBER (number
);
2918 XSETINT (number
, ~XINT (number
));
2922 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2923 doc
: /* Return the byteorder for the machine.
2924 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2925 lowercase l) for small endian machines. */)
2928 unsigned i
= 0x04030201;
2929 int order
= *(char *)&i
== 1 ? 108 : 66;
2931 return make_number (order
);
2939 Lisp_Object error_tail
, arith_tail
;
2941 DEFSYM (Qquote
, "quote");
2942 DEFSYM (Qlambda
, "lambda");
2943 DEFSYM (Qsubr
, "subr");
2944 DEFSYM (Qerror_conditions
, "error-conditions");
2945 DEFSYM (Qerror_message
, "error-message");
2946 DEFSYM (Qtop_level
, "top-level");
2948 DEFSYM (Qerror
, "error");
2949 DEFSYM (Quser_error
, "user-error");
2950 DEFSYM (Qquit
, "quit");
2951 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2952 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2953 DEFSYM (Qvoid_function
, "void-function");
2954 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2955 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2956 DEFSYM (Qvoid_variable
, "void-variable");
2957 DEFSYM (Qsetting_constant
, "setting-constant");
2958 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2960 DEFSYM (Qinvalid_function
, "invalid-function");
2961 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2962 DEFSYM (Qno_catch
, "no-catch");
2963 DEFSYM (Qend_of_file
, "end-of-file");
2964 DEFSYM (Qarith_error
, "arith-error");
2965 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2966 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2967 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2968 DEFSYM (Qtext_read_only
, "text-read-only");
2969 DEFSYM (Qmark_inactive
, "mark-inactive");
2971 DEFSYM (Qlistp
, "listp");
2972 DEFSYM (Qconsp
, "consp");
2973 DEFSYM (Qsymbolp
, "symbolp");
2974 DEFSYM (Qkeywordp
, "keywordp");
2975 DEFSYM (Qintegerp
, "integerp");
2976 DEFSYM (Qnatnump
, "natnump");
2977 DEFSYM (Qwholenump
, "wholenump");
2978 DEFSYM (Qstringp
, "stringp");
2979 DEFSYM (Qarrayp
, "arrayp");
2980 DEFSYM (Qsequencep
, "sequencep");
2981 DEFSYM (Qbufferp
, "bufferp");
2982 DEFSYM (Qvectorp
, "vectorp");
2983 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2984 DEFSYM (Qmarkerp
, "markerp");
2985 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
2986 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
2987 DEFSYM (Qboundp
, "boundp");
2988 DEFSYM (Qfboundp
, "fboundp");
2990 DEFSYM (Qfloatp
, "floatp");
2991 DEFSYM (Qnumberp
, "numberp");
2992 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
2994 DEFSYM (Qchar_table_p
, "char-table-p");
2995 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
2997 DEFSYM (Qsubrp
, "subrp");
2998 DEFSYM (Qunevalled
, "unevalled");
2999 DEFSYM (Qmany
, "many");
3001 DEFSYM (Qcdr
, "cdr");
3003 /* Handle automatic advice activation. */
3004 DEFSYM (Qad_advice_info
, "ad-advice-info");
3005 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3007 error_tail
= pure_cons (Qerror
, Qnil
);
3009 /* ERROR is used as a signaler for random errors for which nothing else is
3012 Fput (Qerror
, Qerror_conditions
,
3014 Fput (Qerror
, Qerror_message
,
3015 build_pure_c_string ("error"));
3017 #define PUT_ERROR(sym, tail, msg) \
3018 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3019 Fput (sym, Qerror_message, build_pure_c_string (msg))
3021 PUT_ERROR (Qquit
, Qnil
, "Quit");
3023 PUT_ERROR (Quser_error
, error_tail
, "");
3024 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
3025 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
3026 PUT_ERROR (Qvoid_function
, error_tail
,
3027 "Symbol's function definition is void");
3028 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
3029 "Symbol's chain of function indirections contains a loop");
3030 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
3031 "Symbol's chain of variable indirections contains a loop");
3032 DEFSYM (Qcircular_list
, "circular-list");
3033 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
3034 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
3035 PUT_ERROR (Qsetting_constant
, error_tail
,
3036 "Attempt to set a constant symbol");
3037 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3038 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3039 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3040 "Wrong number of arguments");
3041 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3042 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3044 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3045 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3046 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3048 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3049 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3050 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3051 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3052 "Text is read-only");
3054 DEFSYM (Qrange_error
, "range-error");
3055 DEFSYM (Qdomain_error
, "domain-error");
3056 DEFSYM (Qsingularity_error
, "singularity-error");
3057 DEFSYM (Qoverflow_error
, "overflow-error");
3058 DEFSYM (Qunderflow_error
, "underflow-error");
3060 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3062 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3064 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3065 "Arithmetic singularity error");
3067 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3068 "Arithmetic overflow error");
3069 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3070 "Arithmetic underflow error");
3074 staticpro (&Qunbound
);
3076 /* Types that type-of returns. */
3077 DEFSYM (Qinteger
, "integer");
3078 DEFSYM (Qsymbol
, "symbol");
3079 DEFSYM (Qstring
, "string");
3080 DEFSYM (Qcons
, "cons");
3081 DEFSYM (Qmarker
, "marker");
3082 DEFSYM (Qoverlay
, "overlay");
3083 DEFSYM (Qfloat
, "float");
3084 DEFSYM (Qwindow_configuration
, "window-configuration");
3085 DEFSYM (Qprocess
, "process");
3086 DEFSYM (Qwindow
, "window");
3087 DEFSYM (Qcompiled_function
, "compiled-function");
3088 DEFSYM (Qbuffer
, "buffer");
3089 DEFSYM (Qframe
, "frame");
3090 DEFSYM (Qvector
, "vector");
3091 DEFSYM (Qchar_table
, "char-table");
3092 DEFSYM (Qbool_vector
, "bool-vector");
3093 DEFSYM (Qhash_table
, "hash-table");
3094 /* Used by Fgarbage_collect. */
3095 DEFSYM (Qinterval
, "interval");
3096 DEFSYM (Qmisc
, "misc");
3098 DEFSYM (Qdefun
, "defun");
3100 DEFSYM (Qfont_spec
, "font-spec");
3101 DEFSYM (Qfont_entity
, "font-entity");
3102 DEFSYM (Qfont_object
, "font-object");
3104 DEFSYM (Qinteractive_form
, "interactive-form");
3106 defsubr (&Sindirect_variable
);
3107 defsubr (&Sinteractive_form
);
3110 defsubr (&Stype_of
);
3115 defsubr (&Sintegerp
);
3116 defsubr (&Sinteger_or_marker_p
);
3117 defsubr (&Snumberp
);
3118 defsubr (&Snumber_or_marker_p
);
3120 defsubr (&Snatnump
);
3121 defsubr (&Ssymbolp
);
3122 defsubr (&Skeywordp
);
3123 defsubr (&Sstringp
);
3124 defsubr (&Smultibyte_string_p
);
3125 defsubr (&Svectorp
);
3126 defsubr (&Schar_table_p
);
3127 defsubr (&Svector_or_char_table_p
);
3128 defsubr (&Sbool_vector_p
);
3130 defsubr (&Ssequencep
);
3131 defsubr (&Sbufferp
);
3132 defsubr (&Smarkerp
);
3134 defsubr (&Sbyte_code_function_p
);
3135 defsubr (&Schar_or_string_p
);
3138 defsubr (&Scar_safe
);
3139 defsubr (&Scdr_safe
);
3142 defsubr (&Ssymbol_function
);
3143 defsubr (&Sindirect_function
);
3144 defsubr (&Ssymbol_plist
);
3145 defsubr (&Ssymbol_name
);
3146 defsubr (&Smakunbound
);
3147 defsubr (&Sfmakunbound
);
3149 defsubr (&Sfboundp
);
3151 defsubr (&Sdefalias
);
3152 defsubr (&Ssetplist
);
3153 defsubr (&Ssymbol_value
);
3155 defsubr (&Sdefault_boundp
);
3156 defsubr (&Sdefault_value
);
3157 defsubr (&Sset_default
);
3158 defsubr (&Ssetq_default
);
3159 defsubr (&Smake_variable_buffer_local
);
3160 defsubr (&Smake_local_variable
);
3161 defsubr (&Skill_local_variable
);
3162 defsubr (&Smake_variable_frame_local
);
3163 defsubr (&Slocal_variable_p
);
3164 defsubr (&Slocal_variable_if_set_p
);
3165 defsubr (&Svariable_binding_locus
);
3166 #if 0 /* XXX Remove this. --lorentey */
3167 defsubr (&Sterminal_local_value
);
3168 defsubr (&Sset_terminal_local_value
);
3172 defsubr (&Snumber_to_string
);
3173 defsubr (&Sstring_to_number
);
3174 defsubr (&Seqlsign
);
3197 defsubr (&Sbyteorder
);
3198 defsubr (&Ssubr_arity
);
3199 defsubr (&Ssubr_name
);
3201 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3203 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3204 doc
: /* The largest value that is representable in a Lisp integer. */);
3205 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3206 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3208 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3209 doc
: /* The smallest value that is representable in a Lisp integer. */);
3210 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3211 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3214 #ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
3218 arith_error (int signo
)
3220 sigsetmask (SIGEMPTYMASK
);
3222 SIGNAL_THREAD_CHECK (signo
);
3223 xsignal0 (Qarith_error
);
3229 /* Don't do this if just dumping out.
3230 We don't want to call `signal' in this case
3231 so that we don't have trouble with dumping
3232 signal-delivering routines in an inconsistent state. */
3236 #endif /* CANNOT_DUMP */
3237 signal (SIGFPE
, arith_error
);