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 all variable indirections and return the final
812 variable. If OBJECT is not a symbol, just return it.
813 Signal a cyclic-variable-indirection error if there is a loop in the
814 variable chain of symbols. */)
817 if (SYMBOLP (object
))
819 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
820 XSETSYMBOL (object
, sym
);
826 /* Given the raw contents of a symbol value cell,
827 return the Lisp value of the symbol.
828 This does not handle buffer-local variables; use
829 swap_in_symval_forwarding for that. */
832 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
834 register Lisp_Object val
;
835 switch (XFWDTYPE (valcontents
))
838 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
842 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
845 return *XOBJFWD (valcontents
)->objvar
;
847 case Lisp_Fwd_Buffer_Obj
:
848 return PER_BUFFER_VALUE (current_buffer
,
849 XBUFFER_OBJFWD (valcontents
)->offset
);
851 case Lisp_Fwd_Kboard_Obj
:
852 /* We used to simply use current_kboard here, but from Lisp
853 code, its value is often unexpected. It seems nicer to
854 allow constructions like this to work as intuitively expected:
856 (with-selected-frame frame
857 (define-key local-function-map "\eOP" [f1]))
859 On the other hand, this affects the semantics of
860 last-command and real-last-command, and people may rely on
861 that. I took a quick look at the Lisp codebase, and I
862 don't think anything will break. --lorentey */
863 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
864 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
869 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
870 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
871 buffer-independent contents of the value cell: forwarded just one
872 step past the buffer-localness.
874 BUF non-zero means set the value in buffer BUF instead of the
875 current buffer. This only plays a role for per-buffer variables. */
878 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
880 switch (XFWDTYPE (valcontents
))
883 CHECK_NUMBER (newval
);
884 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
888 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
892 *XOBJFWD (valcontents
)->objvar
= newval
;
894 /* If this variable is a default for something stored
895 in the buffer itself, such as default-fill-column,
896 find the buffers that don't have local values for it
898 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
899 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
901 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
902 - (char *) &buffer_defaults
);
903 int idx
= PER_BUFFER_IDX (offset
);
910 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
915 lbuf
= Fcdr (XCAR (tail
));
916 if (!BUFFERP (lbuf
)) continue;
919 if (! PER_BUFFER_VALUE_P (b
, idx
))
920 PER_BUFFER_VALUE (b
, offset
) = newval
;
925 case Lisp_Fwd_Buffer_Obj
:
927 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
928 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
930 if (!(NILP (type
) || NILP (newval
)
931 || (XINT (type
) == Lisp_Int0
933 : XTYPE (newval
) == XINT (type
))))
934 buffer_slot_type_mismatch (newval
, XINT (type
));
937 buf
= current_buffer
;
938 PER_BUFFER_VALUE (buf
, offset
) = newval
;
942 case Lisp_Fwd_Kboard_Obj
:
944 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
945 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
946 *(Lisp_Object
*) p
= newval
;
951 abort (); /* goto def; */
955 /* Set up SYMBOL to refer to its global binding.
956 This makes it safe to alter the status of other bindings. */
959 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
961 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
963 /* Unload the previously loaded binding. */
965 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
967 /* Select the global binding in the symbol. */
968 blv
->valcell
= blv
->defcell
;
970 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
972 /* Indicate that the global binding is set up now. */
974 SET_BLV_FOUND (blv
, 0);
977 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
978 VALCONTENTS is the contents of its value cell,
979 which points to a struct Lisp_Buffer_Local_Value.
981 Return the value forwarded one step past the buffer-local stage.
982 This could be another forwarding pointer. */
985 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
987 register Lisp_Object tem1
;
989 eassert (blv
== SYMBOL_BLV (symbol
));
995 ? !EQ (selected_frame
, tem1
)
996 : current_buffer
!= XBUFFER (tem1
)))
999 /* Unload the previously loaded binding. */
1000 tem1
= blv
->valcell
;
1002 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1003 /* Choose the new binding. */
1006 XSETSYMBOL (var
, symbol
);
1007 if (blv
->frame_local
)
1009 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1010 blv
->where
= selected_frame
;
1014 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1015 XSETBUFFER (blv
->where
, current_buffer
);
1018 if (!(blv
->found
= !NILP (tem1
)))
1019 tem1
= blv
->defcell
;
1021 /* Load the new binding. */
1022 blv
->valcell
= tem1
;
1024 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1028 /* Find the value of a symbol, returning Qunbound if it's not bound.
1029 This is helpful for code which just wants to get a variable's value
1030 if it has one, without signaling an error.
1031 Note that it must not be possible to quit
1032 within this function. Great care is required for this. */
1035 find_symbol_value (Lisp_Object symbol
)
1037 struct Lisp_Symbol
*sym
;
1039 CHECK_SYMBOL (symbol
);
1040 sym
= XSYMBOL (symbol
);
1043 switch (sym
->redirect
)
1045 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1046 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1047 case SYMBOL_LOCALIZED
:
1049 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1050 swap_in_symval_forwarding (sym
, blv
);
1051 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1054 case SYMBOL_FORWARDED
:
1055 return do_symval_forwarding (SYMBOL_FWD (sym
));
1060 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1061 doc
: /* Return SYMBOL's value. Error if that is void. */)
1062 (Lisp_Object symbol
)
1066 val
= find_symbol_value (symbol
);
1067 if (!EQ (val
, Qunbound
))
1070 xsignal1 (Qvoid_variable
, symbol
);
1073 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1074 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1075 (register Lisp_Object symbol
, Lisp_Object newval
)
1077 set_internal (symbol
, newval
, Qnil
, 0);
1081 /* Return 1 if SYMBOL currently has a let-binding
1082 which was made in the buffer that is now current. */
1085 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1087 struct specbinding
*p
;
1089 for (p
= specpdl_ptr
; p
> specpdl
; )
1090 if ((--p
)->func
== NULL
1091 && CONSP (p
->symbol
))
1093 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1094 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1095 if (symbol
== let_bound_symbol
1096 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1104 let_shadows_global_binding_p (Lisp_Object symbol
)
1106 struct specbinding
*p
;
1108 for (p
= specpdl_ptr
; p
> specpdl
; )
1109 if ((--p
)->func
== NULL
&& EQ (p
->symbol
, symbol
))
1115 /* Store the value NEWVAL into SYMBOL.
1116 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1117 (nil stands for the current buffer/frame).
1119 If BINDFLAG is zero, then if this symbol is supposed to become
1120 local in every buffer where it is set, then we make it local.
1121 If BINDFLAG is nonzero, we don't do that. */
1124 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1126 int voide
= EQ (newval
, Qunbound
);
1127 struct Lisp_Symbol
*sym
;
1130 /* If restoring in a dead buffer, do nothing. */
1131 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1134 CHECK_SYMBOL (symbol
);
1135 if (SYMBOL_CONSTANT_P (symbol
))
1137 if (NILP (Fkeywordp (symbol
))
1138 || !EQ (newval
, Fsymbol_value (symbol
)))
1139 xsignal1 (Qsetting_constant
, symbol
);
1141 /* Allow setting keywords to their own value. */
1145 sym
= XSYMBOL (symbol
);
1148 switch (sym
->redirect
)
1150 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1151 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1152 case SYMBOL_LOCALIZED
:
1154 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1157 if (blv
->frame_local
)
1158 where
= selected_frame
;
1160 XSETBUFFER (where
, current_buffer
);
1162 /* If the current buffer is not the buffer whose binding is
1163 loaded, or if there may be frame-local bindings and the frame
1164 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1165 the default binding is loaded, the loaded binding may be the
1167 if (!EQ (blv
->where
, where
)
1168 /* Also unload a global binding (if the var is local_if_set). */
1169 || (EQ (blv
->valcell
, blv
->defcell
)))
1171 /* The currently loaded binding is not necessarily valid.
1172 We need to unload it, and choose a new binding. */
1174 /* Write out `realvalue' to the old loaded binding. */
1176 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1178 /* Find the new binding. */
1179 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1180 tem1
= Fassq (symbol
,
1182 ? XFRAME (where
)->param_alist
1183 : BVAR (XBUFFER (where
), local_var_alist
)));
1189 /* This buffer still sees the default value. */
1191 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1192 or if this is `let' rather than `set',
1193 make CURRENT-ALIST-ELEMENT point to itself,
1194 indicating that we're seeing the default value.
1195 Likewise if the variable has been let-bound
1196 in the current buffer. */
1197 if (bindflag
|| !blv
->local_if_set
1198 || let_shadows_buffer_binding_p (sym
))
1201 tem1
= blv
->defcell
;
1203 /* If it's a local_if_set, being set not bound,
1204 and we're not within a let that was made for this buffer,
1205 create a new buffer-local binding for the variable.
1206 That means, give this buffer a new assoc for a local value
1207 and load that binding. */
1210 /* local_if_set is only supported for buffer-local
1211 bindings, not for frame-local bindings. */
1212 eassert (!blv
->frame_local
);
1213 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1214 BVAR (XBUFFER (where
), local_var_alist
)
1215 = Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
));
1219 /* Record which binding is now loaded. */
1220 blv
->valcell
= tem1
;
1223 /* Store the new value in the cons cell. */
1224 SET_BLV_VALUE (blv
, newval
);
1229 /* If storing void (making the symbol void), forward only through
1230 buffer-local indicator, not through Lisp_Objfwd, etc. */
1233 store_symval_forwarding (blv
->fwd
, newval
,
1235 ? XBUFFER (where
) : current_buffer
);
1239 case SYMBOL_FORWARDED
:
1242 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1243 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1244 if (BUFFER_OBJFWDP (innercontents
))
1246 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1247 int idx
= PER_BUFFER_IDX (offset
);
1250 && !let_shadows_buffer_binding_p (sym
))
1251 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1255 { /* If storing void (making the symbol void), forward only through
1256 buffer-local indicator, not through Lisp_Objfwd, etc. */
1257 sym
->redirect
= SYMBOL_PLAINVAL
;
1258 SET_SYMBOL_VAL (sym
, newval
);
1261 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1269 /* Access or set a buffer-local symbol's default value. */
1271 /* Return the default value of SYMBOL, but don't check for voidness.
1272 Return Qunbound if it is void. */
1275 default_value (Lisp_Object symbol
)
1277 struct Lisp_Symbol
*sym
;
1279 CHECK_SYMBOL (symbol
);
1280 sym
= XSYMBOL (symbol
);
1283 switch (sym
->redirect
)
1285 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1286 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1287 case SYMBOL_LOCALIZED
:
1289 /* If var is set up for a buffer that lacks a local value for it,
1290 the current value is nominally the default value.
1291 But the `realvalue' slot may be more up to date, since
1292 ordinary setq stores just that slot. So use that. */
1293 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1294 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1295 return do_symval_forwarding (blv
->fwd
);
1297 return XCDR (blv
->defcell
);
1299 case SYMBOL_FORWARDED
:
1301 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1303 /* For a built-in buffer-local variable, get the default value
1304 rather than letting do_symval_forwarding get the current value. */
1305 if (BUFFER_OBJFWDP (valcontents
))
1307 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1308 if (PER_BUFFER_IDX (offset
) != 0)
1309 return PER_BUFFER_DEFAULT (offset
);
1312 /* For other variables, get the current value. */
1313 return do_symval_forwarding (valcontents
);
1319 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1320 doc
: /* Return t if SYMBOL has a non-void default value.
1321 This is the value that is seen in buffers that do not have their own values
1322 for this variable. */)
1323 (Lisp_Object symbol
)
1325 register Lisp_Object value
;
1327 value
= default_value (symbol
);
1328 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1331 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1332 doc
: /* Return SYMBOL's default value.
1333 This is the value that is seen in buffers that do not have their own values
1334 for this variable. The default value is meaningful for variables with
1335 local bindings in certain buffers. */)
1336 (Lisp_Object symbol
)
1338 register Lisp_Object value
;
1340 value
= default_value (symbol
);
1341 if (!EQ (value
, Qunbound
))
1344 xsignal1 (Qvoid_variable
, symbol
);
1347 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1348 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1349 The default value is seen in buffers that do not have their own values
1350 for this variable. */)
1351 (Lisp_Object symbol
, Lisp_Object value
)
1353 struct Lisp_Symbol
*sym
;
1355 CHECK_SYMBOL (symbol
);
1356 if (SYMBOL_CONSTANT_P (symbol
))
1358 if (NILP (Fkeywordp (symbol
))
1359 || !EQ (value
, Fdefault_value (symbol
)))
1360 xsignal1 (Qsetting_constant
, symbol
);
1362 /* Allow setting keywords to their own value. */
1365 sym
= XSYMBOL (symbol
);
1368 switch (sym
->redirect
)
1370 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1371 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1372 case SYMBOL_LOCALIZED
:
1374 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1376 /* Store new value into the DEFAULT-VALUE slot. */
1377 XSETCDR (blv
->defcell
, value
);
1379 /* If the default binding is now loaded, set the REALVALUE slot too. */
1380 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1381 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1384 case SYMBOL_FORWARDED
:
1386 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1388 /* Handle variables like case-fold-search that have special slots
1390 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1391 if (BUFFER_OBJFWDP (valcontents
))
1393 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1394 int idx
= PER_BUFFER_IDX (offset
);
1396 PER_BUFFER_DEFAULT (offset
) = value
;
1398 /* If this variable is not always local in all buffers,
1399 set it in the buffers that don't nominally have a local value. */
1405 if (!PER_BUFFER_VALUE_P (b
, idx
))
1406 PER_BUFFER_VALUE (b
, offset
) = value
;
1411 return Fset (symbol
, value
);
1417 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1418 doc
: /* Set the default value of variable VAR to VALUE.
1419 VAR, the variable name, is literal (not evaluated);
1420 VALUE is an expression: it is evaluated and its value returned.
1421 The default value of a variable is seen in buffers
1422 that do not have their own values for the variable.
1424 More generally, you can use multiple variables and values, as in
1425 (setq-default VAR VALUE VAR VALUE...)
1426 This sets each VAR's default value to the corresponding VALUE.
1427 The VALUE for the Nth VAR can refer to the new default values
1429 usage: (setq-default [VAR VALUE]...) */)
1432 register Lisp_Object args_left
;
1433 register Lisp_Object val
, symbol
;
1434 struct gcpro gcpro1
;
1444 val
= eval_sub (Fcar (Fcdr (args_left
)));
1445 symbol
= XCAR (args_left
);
1446 Fset_default (symbol
, val
);
1447 args_left
= Fcdr (XCDR (args_left
));
1449 while (!NILP (args_left
));
1455 /* Lisp functions for creating and removing buffer-local variables. */
1460 union Lisp_Fwd
*fwd
;
1463 static struct Lisp_Buffer_Local_Value
*
1464 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1466 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1470 XSETSYMBOL (symbol
, sym
);
1471 tem
= Fcons (symbol
, (forwarded
1472 ? do_symval_forwarding (valcontents
.fwd
)
1473 : valcontents
.value
));
1475 /* Buffer_Local_Values cannot have as realval a buffer-local
1476 or keyboard-local forwarding. */
1477 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1478 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1479 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1481 blv
->frame_local
= 0;
1482 blv
->local_if_set
= 0;
1485 SET_BLV_FOUND (blv
, 0);
1489 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1490 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1491 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1492 At any time, the value for the current buffer is in effect,
1493 unless the variable has never been set in this buffer,
1494 in which case the default value is in effect.
1495 Note that binding the variable with `let', or setting it while
1496 a `let'-style binding made in this buffer is in effect,
1497 does not make the variable buffer-local. Return VARIABLE.
1499 In most cases it is better to use `make-local-variable',
1500 which makes a variable local in just one buffer.
1502 The function `default-value' gets the default value and `set-default' sets it. */)
1503 (register Lisp_Object variable
)
1505 struct Lisp_Symbol
*sym
;
1506 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1507 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1508 int forwarded
IF_LINT (= 0);
1510 CHECK_SYMBOL (variable
);
1511 sym
= XSYMBOL (variable
);
1514 switch (sym
->redirect
)
1516 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1517 case SYMBOL_PLAINVAL
:
1518 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1519 if (EQ (valcontents
.value
, Qunbound
))
1520 valcontents
.value
= Qnil
;
1522 case SYMBOL_LOCALIZED
:
1523 blv
= SYMBOL_BLV (sym
);
1524 if (blv
->frame_local
)
1525 error ("Symbol %s may not be buffer-local",
1526 SDATA (SYMBOL_NAME (variable
)));
1528 case SYMBOL_FORWARDED
:
1529 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1530 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1531 error ("Symbol %s may not be buffer-local",
1532 SDATA (SYMBOL_NAME (variable
)));
1533 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1540 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1544 blv
= make_blv (sym
, forwarded
, valcontents
);
1545 sym
->redirect
= SYMBOL_LOCALIZED
;
1546 SET_SYMBOL_BLV (sym
, blv
);
1549 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1550 if (let_shadows_global_binding_p (symbol
))
1551 message ("Making %s buffer-local while let-bound!",
1552 SDATA (SYMBOL_NAME (variable
)));
1556 blv
->local_if_set
= 1;
1560 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1561 1, 1, "vMake Local Variable: ",
1562 doc
: /* Make VARIABLE have a separate value in the current buffer.
1563 Other buffers will continue to share a common default value.
1564 \(The buffer-local value of VARIABLE starts out as the same value
1565 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1568 If the variable is already arranged to become local when set,
1569 this function causes a local value to exist for this buffer,
1570 just as setting the variable would do.
1572 This function returns VARIABLE, and therefore
1573 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1576 See also `make-variable-buffer-local'.
1578 Do not use `make-local-variable' to make a hook variable buffer-local.
1579 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1580 (register Lisp_Object variable
)
1582 register Lisp_Object tem
;
1583 int forwarded
IF_LINT (= 0);
1584 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1585 struct Lisp_Symbol
*sym
;
1586 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1588 CHECK_SYMBOL (variable
);
1589 sym
= XSYMBOL (variable
);
1592 switch (sym
->redirect
)
1594 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1595 case SYMBOL_PLAINVAL
:
1596 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1597 case SYMBOL_LOCALIZED
:
1598 blv
= SYMBOL_BLV (sym
);
1599 if (blv
->frame_local
)
1600 error ("Symbol %s may not be buffer-local",
1601 SDATA (SYMBOL_NAME (variable
)));
1603 case SYMBOL_FORWARDED
:
1604 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1605 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1606 error ("Symbol %s may not be buffer-local",
1607 SDATA (SYMBOL_NAME (variable
)));
1613 error ("Symbol %s may not be buffer-local",
1614 SDATA (SYMBOL_NAME (variable
)));
1616 if (blv
? blv
->local_if_set
1617 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1619 tem
= Fboundp (variable
);
1620 /* Make sure the symbol has a local value in this particular buffer,
1621 by setting it to the same value it already has. */
1622 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1627 blv
= make_blv (sym
, forwarded
, valcontents
);
1628 sym
->redirect
= SYMBOL_LOCALIZED
;
1629 SET_SYMBOL_BLV (sym
, blv
);
1632 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1633 if (let_shadows_global_binding_p (symbol
))
1634 message ("Making %s local to %s while let-bound!",
1635 SDATA (SYMBOL_NAME (variable
)),
1636 SDATA (BVAR (current_buffer
, name
)));
1640 /* Make sure this buffer has its own value of symbol. */
1641 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1642 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1645 if (let_shadows_buffer_binding_p (sym
))
1646 message ("Making %s buffer-local while locally let-bound!",
1647 SDATA (SYMBOL_NAME (variable
)));
1649 /* Swap out any local binding for some other buffer, and make
1650 sure the current value is permanently recorded, if it's the
1652 find_symbol_value (variable
);
1654 BVAR (current_buffer
, local_var_alist
)
1655 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1656 BVAR (current_buffer
, local_var_alist
));
1658 /* Make sure symbol does not think it is set up for this buffer;
1659 force it to look once again for this buffer's value. */
1660 if (current_buffer
== XBUFFER (blv
->where
))
1662 /* blv->valcell = blv->defcell;
1663 * SET_BLV_FOUND (blv, 0); */
1667 /* If the symbol forwards into a C variable, then load the binding
1668 for this buffer now. If C code modifies the variable before we
1669 load the binding in, then that new value will clobber the default
1670 binding the next time we unload it. */
1672 swap_in_symval_forwarding (sym
, blv
);
1677 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1678 1, 1, "vKill Local Variable: ",
1679 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1680 From now on the default value will apply in this buffer. Return VARIABLE. */)
1681 (register Lisp_Object variable
)
1683 register Lisp_Object tem
;
1684 struct Lisp_Buffer_Local_Value
*blv
;
1685 struct Lisp_Symbol
*sym
;
1687 CHECK_SYMBOL (variable
);
1688 sym
= XSYMBOL (variable
);
1691 switch (sym
->redirect
)
1693 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1694 case SYMBOL_PLAINVAL
: return variable
;
1695 case SYMBOL_FORWARDED
:
1697 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1698 if (BUFFER_OBJFWDP (valcontents
))
1700 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1701 int idx
= PER_BUFFER_IDX (offset
);
1705 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1706 PER_BUFFER_VALUE (current_buffer
, offset
)
1707 = PER_BUFFER_DEFAULT (offset
);
1712 case SYMBOL_LOCALIZED
:
1713 blv
= SYMBOL_BLV (sym
);
1714 if (blv
->frame_local
)
1720 /* Get rid of this buffer's alist element, if any. */
1721 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1722 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1724 BVAR (current_buffer
, local_var_alist
)
1725 = Fdelq (tem
, BVAR (current_buffer
, local_var_alist
));
1727 /* If the symbol is set up with the current buffer's binding
1728 loaded, recompute its value. We have to do it now, or else
1729 forwarded objects won't work right. */
1731 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1732 if (EQ (buf
, blv
->where
))
1735 /* blv->valcell = blv->defcell;
1736 * SET_BLV_FOUND (blv, 0); */
1738 find_symbol_value (variable
);
1745 /* Lisp functions for creating and removing buffer-local variables. */
1747 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1748 when/if this is removed. */
1750 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1751 1, 1, "vMake Variable Frame Local: ",
1752 doc
: /* Enable VARIABLE to have frame-local bindings.
1753 This does not create any frame-local bindings for VARIABLE,
1754 it just makes them possible.
1756 A frame-local binding is actually a frame parameter value.
1757 If a frame F has a value for the frame parameter named VARIABLE,
1758 that also acts as a frame-local binding for VARIABLE in F--
1759 provided this function has been called to enable VARIABLE
1760 to have frame-local bindings at all.
1762 The only way to create a frame-local binding for VARIABLE in a frame
1763 is to set the VARIABLE frame parameter of that frame. See
1764 `modify-frame-parameters' for how to set frame parameters.
1766 Note that since Emacs 23.1, variables cannot be both buffer-local and
1767 frame-local any more (buffer-local bindings used to take precedence over
1768 frame-local bindings). */)
1769 (register Lisp_Object variable
)
1772 union Lisp_Val_Fwd valcontents
;
1773 struct Lisp_Symbol
*sym
;
1774 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1776 CHECK_SYMBOL (variable
);
1777 sym
= XSYMBOL (variable
);
1780 switch (sym
->redirect
)
1782 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1783 case SYMBOL_PLAINVAL
:
1784 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1785 if (EQ (valcontents
.value
, Qunbound
))
1786 valcontents
.value
= Qnil
;
1788 case SYMBOL_LOCALIZED
:
1789 if (SYMBOL_BLV (sym
)->frame_local
)
1792 error ("Symbol %s may not be frame-local",
1793 SDATA (SYMBOL_NAME (variable
)));
1794 case SYMBOL_FORWARDED
:
1795 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1796 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1797 error ("Symbol %s may not be frame-local",
1798 SDATA (SYMBOL_NAME (variable
)));
1804 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1806 blv
= make_blv (sym
, forwarded
, valcontents
);
1807 blv
->frame_local
= 1;
1808 sym
->redirect
= SYMBOL_LOCALIZED
;
1809 SET_SYMBOL_BLV (sym
, blv
);
1812 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1813 if (let_shadows_global_binding_p (symbol
))
1814 message ("Making %s frame-local while let-bound!",
1815 SDATA (SYMBOL_NAME (variable
)));
1820 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1822 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1823 BUFFER defaults to the current buffer. */)
1824 (register Lisp_Object variable
, Lisp_Object buffer
)
1826 register struct buffer
*buf
;
1827 struct Lisp_Symbol
*sym
;
1830 buf
= current_buffer
;
1833 CHECK_BUFFER (buffer
);
1834 buf
= XBUFFER (buffer
);
1837 CHECK_SYMBOL (variable
);
1838 sym
= XSYMBOL (variable
);
1841 switch (sym
->redirect
)
1843 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1844 case SYMBOL_PLAINVAL
: return Qnil
;
1845 case SYMBOL_LOCALIZED
:
1847 Lisp_Object tail
, elt
, tmp
;
1848 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1849 XSETBUFFER (tmp
, buf
);
1850 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1852 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1855 if (EQ (variable
, XCAR (elt
)))
1857 eassert (!blv
->frame_local
);
1858 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1862 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1865 case SYMBOL_FORWARDED
:
1867 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1868 if (BUFFER_OBJFWDP (valcontents
))
1870 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1871 int idx
= PER_BUFFER_IDX (offset
);
1872 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1881 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1883 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1884 More precisely, this means that setting the variable \(with `set' or`setq'),
1885 while it does not have a `let'-style binding that was made in BUFFER,
1886 will produce a buffer local binding. See Info node
1887 `(elisp)Creating Buffer-Local'.
1888 BUFFER defaults to the current buffer. */)
1889 (register Lisp_Object variable
, Lisp_Object buffer
)
1891 struct Lisp_Symbol
*sym
;
1893 CHECK_SYMBOL (variable
);
1894 sym
= XSYMBOL (variable
);
1897 switch (sym
->redirect
)
1899 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1900 case SYMBOL_PLAINVAL
: return Qnil
;
1901 case SYMBOL_LOCALIZED
:
1903 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1904 if (blv
->local_if_set
)
1906 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1907 return Flocal_variable_p (variable
, buffer
);
1909 case SYMBOL_FORWARDED
:
1910 /* All BUFFER_OBJFWD slots become local if they are set. */
1911 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1916 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1918 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1919 If the current binding is buffer-local, the value is the current buffer.
1920 If the current binding is frame-local, the value is the selected frame.
1921 If the current binding is global (the default), the value is nil. */)
1922 (register Lisp_Object variable
)
1924 struct Lisp_Symbol
*sym
;
1926 CHECK_SYMBOL (variable
);
1927 sym
= XSYMBOL (variable
);
1929 /* Make sure the current binding is actually swapped in. */
1930 find_symbol_value (variable
);
1933 switch (sym
->redirect
)
1935 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1936 case SYMBOL_PLAINVAL
: return Qnil
;
1937 case SYMBOL_FORWARDED
:
1939 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1940 if (KBOARD_OBJFWDP (valcontents
))
1941 return Fframe_terminal (Fselected_frame ());
1942 else if (!BUFFER_OBJFWDP (valcontents
))
1946 case SYMBOL_LOCALIZED
:
1947 /* For a local variable, record both the symbol and which
1948 buffer's or frame's value we are saving. */
1949 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1950 return Fcurrent_buffer ();
1951 else if (sym
->redirect
== SYMBOL_LOCALIZED
1952 && BLV_FOUND (SYMBOL_BLV (sym
)))
1953 return SYMBOL_BLV (sym
)->where
;
1960 /* This code is disabled now that we use the selected frame to return
1961 keyboard-local-values. */
1963 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1965 DEFUN ("terminal-local-value", Fterminal_local_value
,
1966 Sterminal_local_value
, 2, 2, 0,
1967 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1968 If SYMBOL is not a terminal-local variable, then return its normal
1969 value, like `symbol-value'.
1971 TERMINAL may be a terminal object, a frame, or nil (meaning the
1972 selected frame's terminal device). */)
1973 (Lisp_Object symbol
, Lisp_Object terminal
)
1976 struct terminal
*t
= get_terminal (terminal
, 1);
1977 push_kboard (t
->kboard
);
1978 result
= Fsymbol_value (symbol
);
1983 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1984 Sset_terminal_local_value
, 3, 3, 0,
1985 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1986 If VARIABLE is not a terminal-local variable, then set its normal
1987 binding, like `set'.
1989 TERMINAL may be a terminal object, a frame, or nil (meaning the
1990 selected frame's terminal device). */)
1991 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1994 struct terminal
*t
= get_terminal (terminal
, 1);
1995 push_kboard (d
->kboard
);
1996 result
= Fset (symbol
, value
);
2002 /* Find the function at the end of a chain of symbol function indirections. */
2004 /* If OBJECT is a symbol, find the end of its function chain and
2005 return the value found there. If OBJECT is not a symbol, just
2006 return it. If there is a cycle in the function chain, signal a
2007 cyclic-function-indirection error.
2009 This is like Findirect_function, except that it doesn't signal an
2010 error if the chain ends up unbound. */
2012 indirect_function (register Lisp_Object object
)
2014 Lisp_Object tortoise
, hare
;
2016 hare
= tortoise
= object
;
2020 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2022 hare
= XSYMBOL (hare
)->function
;
2023 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2025 hare
= XSYMBOL (hare
)->function
;
2027 tortoise
= XSYMBOL (tortoise
)->function
;
2029 if (EQ (hare
, tortoise
))
2030 xsignal1 (Qcyclic_function_indirection
, object
);
2036 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2037 doc
: /* Return the function at the end of OBJECT's function chain.
2038 If OBJECT is not a symbol, just return it. Otherwise, follow all
2039 function indirections to find the final function binding and return it.
2040 If the final symbol in the chain is unbound, signal a void-function error.
2041 Optional arg NOERROR non-nil means to return nil instead of signaling.
2042 Signal a cyclic-function-indirection error if there is a loop in the
2043 function chain of symbols. */)
2044 (register Lisp_Object object
, Lisp_Object noerror
)
2048 /* Optimize for no indirection. */
2050 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2051 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2052 result
= indirect_function (result
);
2053 if (!EQ (result
, Qunbound
))
2057 xsignal1 (Qvoid_function
, object
);
2062 /* Extract and set vector and string elements. */
2064 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2065 doc
: /* Return the element of ARRAY at index IDX.
2066 ARRAY may be a vector, a string, a char-table, a bool-vector,
2067 or a byte-code object. IDX starts at 0. */)
2068 (register Lisp_Object array
, Lisp_Object idx
)
2070 register EMACS_INT idxval
;
2073 idxval
= XINT (idx
);
2074 if (STRINGP (array
))
2077 ptrdiff_t idxval_byte
;
2079 if (idxval
< 0 || idxval
>= SCHARS (array
))
2080 args_out_of_range (array
, idx
);
2081 if (! STRING_MULTIBYTE (array
))
2082 return make_number ((unsigned char) SREF (array
, idxval
));
2083 idxval_byte
= string_char_to_byte (array
, idxval
);
2085 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2086 return make_number (c
);
2088 else if (BOOL_VECTOR_P (array
))
2092 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2093 args_out_of_range (array
, idx
);
2095 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2096 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2098 else if (CHAR_TABLE_P (array
))
2100 CHECK_CHARACTER (idx
);
2101 return CHAR_TABLE_REF (array
, idxval
);
2106 if (VECTORP (array
))
2107 size
= ASIZE (array
);
2108 else if (COMPILEDP (array
))
2109 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2111 wrong_type_argument (Qarrayp
, array
);
2113 if (idxval
< 0 || idxval
>= size
)
2114 args_out_of_range (array
, idx
);
2115 return AREF (array
, idxval
);
2119 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2120 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2121 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2122 bool-vector. IDX starts at 0. */)
2123 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2125 register EMACS_INT idxval
;
2128 idxval
= XINT (idx
);
2129 CHECK_ARRAY (array
, Qarrayp
);
2130 CHECK_IMPURE (array
);
2132 if (VECTORP (array
))
2134 if (idxval
< 0 || idxval
>= ASIZE (array
))
2135 args_out_of_range (array
, idx
);
2136 ASET (array
, idxval
, newelt
);
2138 else if (BOOL_VECTOR_P (array
))
2142 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2143 args_out_of_range (array
, idx
);
2145 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2147 if (! NILP (newelt
))
2148 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2150 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2151 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2153 else if (CHAR_TABLE_P (array
))
2155 CHECK_CHARACTER (idx
);
2156 CHAR_TABLE_SET (array
, idxval
, newelt
);
2162 if (idxval
< 0 || idxval
>= SCHARS (array
))
2163 args_out_of_range (array
, idx
);
2164 CHECK_CHARACTER (newelt
);
2165 c
= XFASTINT (newelt
);
2167 if (STRING_MULTIBYTE (array
))
2169 ptrdiff_t idxval_byte
, nbytes
;
2170 int prev_bytes
, new_bytes
;
2171 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2173 nbytes
= SBYTES (array
);
2174 idxval_byte
= string_char_to_byte (array
, idxval
);
2175 p1
= SDATA (array
) + idxval_byte
;
2176 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2177 new_bytes
= CHAR_STRING (c
, p0
);
2178 if (prev_bytes
!= new_bytes
)
2180 /* We must relocate the string data. */
2181 ptrdiff_t nchars
= SCHARS (array
);
2183 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2185 memcpy (str
, SDATA (array
), nbytes
);
2186 allocate_string_data (XSTRING (array
), nchars
,
2187 nbytes
+ new_bytes
- prev_bytes
);
2188 memcpy (SDATA (array
), str
, idxval_byte
);
2189 p1
= SDATA (array
) + idxval_byte
;
2190 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2191 nbytes
- (idxval_byte
+ prev_bytes
));
2193 clear_string_char_byte_cache ();
2200 if (! SINGLE_BYTE_CHAR_P (c
))
2204 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2205 if (SREF (array
, i
) >= 0x80)
2206 args_out_of_range (array
, newelt
);
2207 /* ARRAY is an ASCII string. Convert it to a multibyte
2208 string, and try `aset' again. */
2209 STRING_SET_MULTIBYTE (array
);
2210 return Faset (array
, idx
, newelt
);
2212 SSET (array
, idxval
, c
);
2219 /* Arithmetic functions */
2221 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2224 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2226 double f1
= 0, f2
= 0;
2229 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2230 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2232 if (FLOATP (num1
) || FLOATP (num2
))
2235 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2236 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2242 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2247 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2252 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2257 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2262 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2267 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2276 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2277 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2278 (register Lisp_Object num1
, Lisp_Object num2
)
2280 return arithcompare (num1
, num2
, equal
);
2283 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2284 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2285 (register Lisp_Object num1
, Lisp_Object num2
)
2287 return arithcompare (num1
, num2
, less
);
2290 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2291 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2292 (register Lisp_Object num1
, Lisp_Object num2
)
2294 return arithcompare (num1
, num2
, grtr
);
2297 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2298 doc
: /* Return t if first arg is less than or equal to second arg.
2299 Both must be numbers or markers. */)
2300 (register Lisp_Object num1
, Lisp_Object num2
)
2302 return arithcompare (num1
, num2
, less_or_equal
);
2305 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2306 doc
: /* Return t if first arg is greater than or equal to second arg.
2307 Both must be numbers or markers. */)
2308 (register Lisp_Object num1
, Lisp_Object num2
)
2310 return arithcompare (num1
, num2
, grtr_or_equal
);
2313 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2314 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2315 (register Lisp_Object num1
, Lisp_Object num2
)
2317 return arithcompare (num1
, num2
, notequal
);
2320 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2321 doc
: /* Return t if NUMBER is zero. */)
2322 (register Lisp_Object number
)
2324 CHECK_NUMBER_OR_FLOAT (number
);
2326 if (FLOATP (number
))
2328 if (XFLOAT_DATA (number
) == 0.0)
2338 /* Convert the cons-of-integers, integer, or float value C to an
2339 unsigned value with maximum value MAX. Signal an error if C does not
2340 have a valid format or is out of range. */
2342 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2345 uintmax_t val
IF_LINT (= 0);
2348 valid
= 0 <= XINT (c
);
2351 else if (FLOATP (c
))
2353 double d
= XFLOAT_DATA (c
);
2355 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2361 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2363 uintmax_t top
= XFASTINT (XCAR (c
));
2364 Lisp_Object rest
= XCDR (c
);
2365 if (top
<= UINTMAX_MAX
>> 24 >> 16
2367 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2368 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2370 uintmax_t mid
= XFASTINT (XCAR (rest
));
2371 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2374 else if (top
<= UINTMAX_MAX
>> 16)
2378 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2380 val
= top
<< 16 | XFASTINT (rest
);
2386 if (! (valid
&& val
<= max
))
2387 error ("Not an in-range integer, float, or cons of integers");
2391 /* Convert the cons-of-integers, integer, or float value C to a signed
2392 value with extrema MIN and MAX. Signal an error if C does not have
2393 a valid format or is out of range. */
2395 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2398 intmax_t val
IF_LINT (= 0);
2404 else if (FLOATP (c
))
2406 double d
= XFLOAT_DATA (c
);
2408 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2414 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2416 intmax_t top
= XINT (XCAR (c
));
2417 Lisp_Object rest
= XCDR (c
);
2418 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2420 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2421 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2423 intmax_t mid
= XFASTINT (XCAR (rest
));
2424 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2427 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2431 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2433 val
= top
<< 16 | XFASTINT (rest
);
2439 if (! (valid
&& min
<= val
&& val
<= max
))
2440 error ("Not an in-range integer, float, or cons of integers");
2444 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2445 doc
: /* Return the decimal representation of NUMBER as a string.
2446 Uses a minus sign if negative.
2447 NUMBER may be an integer or a floating point number. */)
2448 (Lisp_Object number
)
2450 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2453 CHECK_NUMBER_OR_FLOAT (number
);
2455 if (FLOATP (number
))
2456 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2458 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2460 return make_unibyte_string (buffer
, len
);
2463 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2464 doc
: /* Parse STRING as a decimal number and return the number.
2465 This parses both integers and floating point numbers.
2466 It ignores leading spaces and tabs, and all trailing chars.
2468 If BASE, interpret STRING as a number in that base. If BASE isn't
2469 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2470 If the base used is not 10, STRING is always parsed as integer. */)
2471 (register Lisp_Object string
, Lisp_Object base
)
2477 CHECK_STRING (string
);
2483 CHECK_NUMBER (base
);
2484 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2485 xsignal1 (Qargs_out_of_range
, base
);
2489 p
= SSDATA (string
);
2490 while (*p
== ' ' || *p
== '\t')
2493 val
= string_to_number (p
, b
, 1);
2494 return NILP (val
) ? make_number (0) : val
;
2510 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2511 ptrdiff_t, Lisp_Object
*);
2513 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2515 register Lisp_Object val
;
2517 register EMACS_INT accum
= 0;
2518 register EMACS_INT next
;
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 /* Used by Fgarbage_collect. */
3093 DEFSYM (Qinterval
, "interval");
3094 DEFSYM (Qmisc
, "misc");
3096 DEFSYM (Qdefun
, "defun");
3098 DEFSYM (Qfont_spec
, "font-spec");
3099 DEFSYM (Qfont_entity
, "font-entity");
3100 DEFSYM (Qfont_object
, "font-object");
3102 DEFSYM (Qinteractive_form
, "interactive-form");
3104 defsubr (&Sindirect_variable
);
3105 defsubr (&Sinteractive_form
);
3108 defsubr (&Stype_of
);
3113 defsubr (&Sintegerp
);
3114 defsubr (&Sinteger_or_marker_p
);
3115 defsubr (&Snumberp
);
3116 defsubr (&Snumber_or_marker_p
);
3118 defsubr (&Snatnump
);
3119 defsubr (&Ssymbolp
);
3120 defsubr (&Skeywordp
);
3121 defsubr (&Sstringp
);
3122 defsubr (&Smultibyte_string_p
);
3123 defsubr (&Svectorp
);
3124 defsubr (&Schar_table_p
);
3125 defsubr (&Svector_or_char_table_p
);
3126 defsubr (&Sbool_vector_p
);
3128 defsubr (&Ssequencep
);
3129 defsubr (&Sbufferp
);
3130 defsubr (&Smarkerp
);
3132 defsubr (&Sbyte_code_function_p
);
3133 defsubr (&Schar_or_string_p
);
3136 defsubr (&Scar_safe
);
3137 defsubr (&Scdr_safe
);
3140 defsubr (&Ssymbol_function
);
3141 defsubr (&Sindirect_function
);
3142 defsubr (&Ssymbol_plist
);
3143 defsubr (&Ssymbol_name
);
3144 defsubr (&Smakunbound
);
3145 defsubr (&Sfmakunbound
);
3147 defsubr (&Sfboundp
);
3149 defsubr (&Sdefalias
);
3150 defsubr (&Ssetplist
);
3151 defsubr (&Ssymbol_value
);
3153 defsubr (&Sdefault_boundp
);
3154 defsubr (&Sdefault_value
);
3155 defsubr (&Sset_default
);
3156 defsubr (&Ssetq_default
);
3157 defsubr (&Smake_variable_buffer_local
);
3158 defsubr (&Smake_local_variable
);
3159 defsubr (&Skill_local_variable
);
3160 defsubr (&Smake_variable_frame_local
);
3161 defsubr (&Slocal_variable_p
);
3162 defsubr (&Slocal_variable_if_set_p
);
3163 defsubr (&Svariable_binding_locus
);
3164 #if 0 /* XXX Remove this. --lorentey */
3165 defsubr (&Sterminal_local_value
);
3166 defsubr (&Sset_terminal_local_value
);
3170 defsubr (&Snumber_to_string
);
3171 defsubr (&Sstring_to_number
);
3172 defsubr (&Seqlsign
);
3195 defsubr (&Sbyteorder
);
3196 defsubr (&Ssubr_arity
);
3197 defsubr (&Ssubr_name
);
3199 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3201 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3202 doc
: /* The largest value that is representable in a Lisp integer. */);
3203 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3204 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3206 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3207 doc
: /* The smallest value that is representable in a Lisp integer. */);
3208 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3209 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3212 #ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
3216 arith_error (int signo
)
3218 sigsetmask (SIGEMPTYMASK
);
3220 SIGNAL_THREAD_CHECK (signo
);
3221 xsignal0 (Qarith_error
);
3227 /* Don't do this if just dumping out.
3228 We don't want to call `signal' in this case
3229 so that we don't have trouble with dumping
3230 signal-delivering routines in an inconsistent state. */
3234 #endif /* CANNOT_DUMP */
3235 signal (SIGFPE
, arith_error
);