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/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
37 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
38 static Lisp_Object Qsubr
;
39 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
40 Lisp_Object Qerror
, Quser_error
, Qquit
, Qargs_out_of_range
;
41 static Lisp_Object Qwrong_type_argument
;
42 Lisp_Object Qvoid_variable
, Qvoid_function
;
43 static Lisp_Object Qcyclic_function_indirection
;
44 static Lisp_Object Qcyclic_variable_indirection
;
45 Lisp_Object Qcircular_list
;
46 static Lisp_Object Qsetting_constant
;
47 Lisp_Object Qinvalid_read_syntax
;
48 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
49 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
50 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
51 Lisp_Object Qtext_read_only
;
53 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
54 static Lisp_Object Qnatnump
;
55 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
56 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
57 Lisp_Object Qbuffer_or_string_p
;
58 static Lisp_Object Qkeywordp
, Qboundp
;
60 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
63 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
65 static Lisp_Object Qdomain_error
, Qsingularity_error
, Qunderflow_error
;
66 Lisp_Object Qrange_error
, Qoverflow_error
;
69 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
71 Lisp_Object Qinteger
, Qsymbol
;
72 static Lisp_Object Qcons
, Qfloat
, Qmisc
, Qstring
, Qvector
;
74 static Lisp_Object Qoverlay
, Qwindow_configuration
;
75 static Lisp_Object Qprocess
, Qmarker
;
76 static Lisp_Object Qcompiled_function
, Qframe
;
78 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
79 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
80 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
81 static Lisp_Object Qdefun
;
83 Lisp_Object Qinteractive_form
;
84 static Lisp_Object Qdefalias_fset_function
;
86 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
90 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
92 /* If VALUE is not even a valid Lisp object, we'd want to abort here
93 where we can get a backtrace showing where it came from. We used
94 to try and do that by checking the tagbits, but nowadays all
95 tagbits are potentially valid. */
96 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
99 xsignal2 (Qwrong_type_argument
, predicate
, value
);
103 pure_write_error (void)
105 error ("Attempt to modify read-only object");
109 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
111 xsignal2 (Qargs_out_of_range
, a1
, a2
);
115 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
117 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
121 /* Data type predicates. */
123 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
124 doc
: /* Return t if the two args are the same Lisp object. */)
125 (Lisp_Object obj1
, Lisp_Object obj2
)
132 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
133 doc
: /* Return t if OBJECT is nil. */)
141 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
142 doc
: /* Return a symbol representing the type of OBJECT.
143 The symbol returned names the object's basic type;
144 for example, (type-of 1) returns `integer'. */)
147 switch (XTYPE (object
))
162 switch (XMISCTYPE (object
))
164 case Lisp_Misc_Marker
:
166 case Lisp_Misc_Overlay
:
168 case Lisp_Misc_Float
:
173 case Lisp_Vectorlike
:
174 if (WINDOW_CONFIGURATIONP (object
))
175 return Qwindow_configuration
;
176 if (PROCESSP (object
))
178 if (WINDOWP (object
))
182 if (COMPILEDP (object
))
183 return Qcompiled_function
;
184 if (BUFFERP (object
))
186 if (CHAR_TABLE_P (object
))
188 if (BOOL_VECTOR_P (object
))
192 if (HASH_TABLE_P (object
))
194 if (FONT_SPEC_P (object
))
196 if (FONT_ENTITY_P (object
))
198 if (FONT_OBJECT_P (object
))
210 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
211 doc
: /* Return t if OBJECT is a cons cell. */)
219 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
220 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
228 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
229 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
230 Otherwise, return nil. */)
233 if (CONSP (object
) || NILP (object
))
238 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
239 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
242 if (CONSP (object
) || NILP (object
))
247 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
248 doc
: /* Return t if OBJECT is a symbol. */)
251 if (SYMBOLP (object
))
256 /* Define this in C to avoid unnecessarily consing up the symbol
258 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
259 doc
: /* Return t if OBJECT is a keyword.
260 This means that it is a symbol with a print name beginning with `:'
261 interned in the initial obarray. */)
265 && SREF (SYMBOL_NAME (object
), 0) == ':'
266 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
271 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
272 doc
: /* Return t if OBJECT is a vector. */)
275 if (VECTORP (object
))
280 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
281 doc
: /* Return t if OBJECT is a string. */)
284 if (STRINGP (object
))
289 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
291 doc
: /* Return t if OBJECT is a multibyte string. */)
294 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
299 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
300 doc
: /* Return t if OBJECT is a char-table. */)
303 if (CHAR_TABLE_P (object
))
308 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
309 Svector_or_char_table_p
, 1, 1, 0,
310 doc
: /* Return t if OBJECT is a char-table or vector. */)
313 if (VECTORP (object
) || CHAR_TABLE_P (object
))
318 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
319 doc
: /* Return t if OBJECT is a bool-vector. */)
322 if (BOOL_VECTOR_P (object
))
327 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
328 doc
: /* Return t if OBJECT is an array (string or vector). */)
336 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
337 doc
: /* Return t if OBJECT is a sequence (list or array). */)
338 (register Lisp_Object object
)
340 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
345 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
346 doc
: /* Return t if OBJECT is an editor buffer. */)
349 if (BUFFERP (object
))
354 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
355 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
358 if (MARKERP (object
))
363 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
364 doc
: /* Return t if OBJECT is a built-in function. */)
372 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
374 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
377 if (COMPILEDP (object
))
382 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is a character or a string. */)
384 (register Lisp_Object object
)
386 if (CHARACTERP (object
) || STRINGP (object
))
391 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
392 doc
: /* Return t if OBJECT is an integer. */)
395 if (INTEGERP (object
))
400 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
401 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
402 (register Lisp_Object object
)
404 if (MARKERP (object
) || INTEGERP (object
))
409 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
410 doc
: /* Return t if OBJECT is a nonnegative integer. */)
413 if (NATNUMP (object
))
418 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
422 if (NUMBERP (object
))
428 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
429 Snumber_or_marker_p
, 1, 1, 0,
430 doc
: /* Return t if OBJECT is a number or a marker. */)
433 if (NUMBERP (object
) || MARKERP (object
))
438 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
439 doc
: /* Return t if OBJECT is a floating point number. */)
448 /* Extract and set components of lists. */
450 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
451 doc
: /* Return the car of LIST. If arg is nil, return nil.
452 Error if arg is not nil and not a cons cell. See also `car-safe'.
454 See Info node `(elisp)Cons Cells' for a discussion of related basic
455 Lisp concepts such as car, cdr, cons cell and list. */)
456 (register Lisp_Object list
)
461 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
462 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
465 return CAR_SAFE (object
);
468 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
469 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
470 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
472 See Info node `(elisp)Cons Cells' for a discussion of related basic
473 Lisp concepts such as cdr, car, cons cell and list. */)
474 (register Lisp_Object list
)
479 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
480 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
483 return CDR_SAFE (object
);
486 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
487 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
488 (register Lisp_Object cell
, Lisp_Object newcar
)
492 XSETCAR (cell
, newcar
);
496 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
497 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
498 (register Lisp_Object cell
, Lisp_Object newcdr
)
502 XSETCDR (cell
, newcdr
);
506 /* Extract and set components of symbols. */
508 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
509 doc
: /* Return t if SYMBOL's value is not void. */)
510 (register Lisp_Object symbol
)
512 Lisp_Object valcontents
;
513 struct Lisp_Symbol
*sym
;
514 CHECK_SYMBOL (symbol
);
515 sym
= XSYMBOL (symbol
);
518 switch (sym
->redirect
)
520 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
521 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
522 case SYMBOL_LOCALIZED
:
524 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
526 /* In set_internal, we un-forward vars when their value is
531 swap_in_symval_forwarding (sym
, blv
);
532 valcontents
= blv_value (blv
);
536 case SYMBOL_FORWARDED
:
537 /* In set_internal, we un-forward vars when their value is
540 default: emacs_abort ();
543 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
546 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
547 doc
: /* Return t if SYMBOL's function definition is not void. */)
548 (register Lisp_Object symbol
)
550 CHECK_SYMBOL (symbol
);
551 return EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
;
554 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
555 doc
: /* Make SYMBOL's value be void.
557 (register Lisp_Object symbol
)
559 CHECK_SYMBOL (symbol
);
560 if (SYMBOL_CONSTANT_P (symbol
))
561 xsignal1 (Qsetting_constant
, symbol
);
562 Fset (symbol
, Qunbound
);
566 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
567 doc
: /* Make SYMBOL's function definition be void.
569 (register Lisp_Object symbol
)
571 CHECK_SYMBOL (symbol
);
572 if (NILP (symbol
) || EQ (symbol
, Qt
))
573 xsignal1 (Qsetting_constant
, symbol
);
574 set_symbol_function (symbol
, Qunbound
);
578 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
579 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
580 (register Lisp_Object symbol
)
582 CHECK_SYMBOL (symbol
);
583 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
584 return XSYMBOL (symbol
)->function
;
585 xsignal1 (Qvoid_function
, symbol
);
588 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
589 doc
: /* Return SYMBOL's property list. */)
590 (register Lisp_Object symbol
)
592 CHECK_SYMBOL (symbol
);
593 return XSYMBOL (symbol
)->plist
;
596 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
597 doc
: /* Return SYMBOL's name, a string. */)
598 (register Lisp_Object symbol
)
600 register Lisp_Object name
;
602 CHECK_SYMBOL (symbol
);
603 name
= SYMBOL_NAME (symbol
);
607 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
608 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
609 (register Lisp_Object symbol
, Lisp_Object definition
)
611 register Lisp_Object function
;
612 CHECK_SYMBOL (symbol
);
614 function
= XSYMBOL (symbol
)->function
;
616 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
617 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
619 if (AUTOLOADP (function
))
620 Fput (symbol
, Qautoload
, XCDR (function
));
622 set_symbol_function (symbol
, definition
);
627 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
628 doc
: /* Set SYMBOL's function definition to DEFINITION.
629 Associates the function with the current load file, if any.
630 The optional third argument DOCSTRING specifies the documentation string
631 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
632 determined by DEFINITION.
633 The return value is undefined. */)
634 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
636 CHECK_SYMBOL (symbol
);
637 if (!NILP (Vpurify_flag
)
638 /* If `definition' is a keymap, immutable (and copying) is wrong. */
639 && !KEYMAPP (definition
))
640 definition
= Fpurecopy (definition
);
643 bool autoload
= AUTOLOADP (definition
);
644 if (NILP (Vpurify_flag
) || !autoload
)
645 { /* Only add autoload entries after dumping, because the ones before are
646 not useful and else we get loads of them from the loaddefs.el. */
648 if (AUTOLOADP (XSYMBOL (symbol
)->function
))
649 /* Remember that the function was already an autoload. */
650 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
651 LOADHIST_ATTACH (Fcons (autoload
? Qautoload
: Qdefun
, symbol
));
655 { /* Handle automatic advice activation. */
656 Lisp_Object hook
= Fget (symbol
, Qdefalias_fset_function
);
658 call2 (hook
, symbol
, definition
);
660 Ffset (symbol
, definition
);
663 if (!NILP (docstring
))
664 Fput (symbol
, Qfunction_documentation
, docstring
);
665 /* We used to return `definition', but now that `defun' and `defmacro' expand
666 to a call to `defalias', we return `symbol' for backward compatibility
671 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
672 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
673 (register Lisp_Object symbol
, Lisp_Object newplist
)
675 CHECK_SYMBOL (symbol
);
676 set_symbol_plist (symbol
, newplist
);
680 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
681 doc
: /* Return minimum and maximum number of args allowed for SUBR.
682 SUBR must be a built-in function.
683 The returned value is a pair (MIN . MAX). MIN is the minimum number
684 of args. MAX is the maximum number or the symbol `many', for a
685 function with `&rest' args, or `unevalled' for a special form. */)
688 short minargs
, maxargs
;
690 minargs
= XSUBR (subr
)->min_args
;
691 maxargs
= XSUBR (subr
)->max_args
;
692 return Fcons (make_number (minargs
),
693 maxargs
== MANY
? Qmany
694 : maxargs
== UNEVALLED
? Qunevalled
695 : make_number (maxargs
));
698 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
699 doc
: /* Return name of subroutine SUBR.
700 SUBR must be a built-in function. */)
705 name
= XSUBR (subr
)->symbol_name
;
706 return build_string (name
);
709 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
710 doc
: /* Return the interactive form of CMD or nil if none.
711 If CMD is not a command, the return value is nil.
712 Value, if non-nil, is a list \(interactive SPEC). */)
715 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
717 if (NILP (fun
) || EQ (fun
, Qunbound
))
720 /* Use an `interactive-form' property if present, analogous to the
721 function-documentation property. */
723 while (SYMBOLP (fun
))
725 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
729 fun
= Fsymbol_function (fun
);
734 const char *spec
= XSUBR (fun
)->intspec
;
736 return list2 (Qinteractive
,
737 (*spec
!= '(') ? build_string (spec
) :
738 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
740 else if (COMPILEDP (fun
))
742 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
743 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
745 else if (AUTOLOADP (fun
))
746 return Finteractive_form (Fautoload_do_load (fun
, cmd
, Qnil
));
747 else if (CONSP (fun
))
749 Lisp_Object funcar
= XCAR (fun
);
750 if (EQ (funcar
, Qclosure
))
751 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
752 else if (EQ (funcar
, Qlambda
))
753 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
759 /***********************************************************************
760 Getting and Setting Values of Symbols
761 ***********************************************************************/
763 /* Return the symbol holding SYMBOL's value. Signal
764 `cyclic-variable-indirection' if SYMBOL's chain of variable
765 indirections contains a loop. */
768 indirect_variable (struct Lisp_Symbol
*symbol
)
770 struct Lisp_Symbol
*tortoise
, *hare
;
772 hare
= tortoise
= symbol
;
774 while (hare
->redirect
== SYMBOL_VARALIAS
)
776 hare
= SYMBOL_ALIAS (hare
);
777 if (hare
->redirect
!= SYMBOL_VARALIAS
)
780 hare
= SYMBOL_ALIAS (hare
);
781 tortoise
= SYMBOL_ALIAS (tortoise
);
783 if (hare
== tortoise
)
786 XSETSYMBOL (tem
, symbol
);
787 xsignal1 (Qcyclic_variable_indirection
, tem
);
795 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
796 doc
: /* Return the variable at the end of OBJECT's variable chain.
797 If OBJECT is a symbol, follow its variable indirections (if any), and
798 return the variable at the end of the chain of aliases. See Info node
799 `(elisp)Variable Aliases'.
801 If OBJECT is not a symbol, just return it. If there is a loop in the
802 chain of aliases, signal a `cyclic-variable-indirection' error. */)
805 if (SYMBOLP (object
))
807 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
808 XSETSYMBOL (object
, sym
);
814 /* Given the raw contents of a symbol value cell,
815 return the Lisp value of the symbol.
816 This does not handle buffer-local variables; use
817 swap_in_symval_forwarding for that. */
820 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
822 register Lisp_Object val
;
823 switch (XFWDTYPE (valcontents
))
826 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
830 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
833 return *XOBJFWD (valcontents
)->objvar
;
835 case Lisp_Fwd_Buffer_Obj
:
836 return per_buffer_value (current_buffer
,
837 XBUFFER_OBJFWD (valcontents
)->offset
);
839 case Lisp_Fwd_Kboard_Obj
:
840 /* We used to simply use current_kboard here, but from Lisp
841 code, its value is often unexpected. It seems nicer to
842 allow constructions like this to work as intuitively expected:
844 (with-selected-frame frame
845 (define-key local-function-map "\eOP" [f1]))
847 On the other hand, this affects the semantics of
848 last-command and real-last-command, and people may rely on
849 that. I took a quick look at the Lisp codebase, and I
850 don't think anything will break. --lorentey */
851 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
852 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
853 default: emacs_abort ();
857 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
858 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
859 buffer-independent contents of the value cell: forwarded just one
860 step past the buffer-localness.
862 BUF non-zero means set the value in buffer BUF instead of the
863 current buffer. This only plays a role for per-buffer variables. */
866 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
868 switch (XFWDTYPE (valcontents
))
871 CHECK_NUMBER (newval
);
872 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
876 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
880 *XOBJFWD (valcontents
)->objvar
= newval
;
882 /* If this variable is a default for something stored
883 in the buffer itself, such as default-fill-column,
884 find the buffers that don't have local values for it
886 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
887 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
889 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
890 - (char *) &buffer_defaults
);
891 int idx
= PER_BUFFER_IDX (offset
);
898 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
903 lbuf
= Fcdr (XCAR (tail
));
904 if (!BUFFERP (lbuf
)) continue;
907 if (! PER_BUFFER_VALUE_P (b
, idx
))
908 set_per_buffer_value (b
, offset
, newval
);
913 case Lisp_Fwd_Buffer_Obj
:
915 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
916 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
918 if (!(NILP (type
) || NILP (newval
)
919 || (XINT (type
) == Lisp_Int0
921 : XTYPE (newval
) == XINT (type
))))
922 buffer_slot_type_mismatch (newval
, XINT (type
));
925 buf
= current_buffer
;
926 set_per_buffer_value (buf
, offset
, newval
);
930 case Lisp_Fwd_Kboard_Obj
:
932 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
933 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
934 *(Lisp_Object
*) p
= newval
;
939 emacs_abort (); /* goto def; */
943 /* Set up SYMBOL to refer to its global binding. This makes it safe
944 to alter the status of other bindings. BEWARE: this may be called
945 during the mark phase of GC, where we assume that Lisp_Object slots
946 of BLV are marked after this function has changed them. */
949 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
951 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
953 /* Unload the previously loaded binding. */
955 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
957 /* Select the global binding in the symbol. */
958 set_blv_valcell (blv
, blv
->defcell
);
960 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
962 /* Indicate that the global binding is set up now. */
963 set_blv_where (blv
, Qnil
);
964 set_blv_found (blv
, 0);
967 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
968 VALCONTENTS is the contents of its value cell,
969 which points to a struct Lisp_Buffer_Local_Value.
971 Return the value forwarded one step past the buffer-local stage.
972 This could be another forwarding pointer. */
975 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
977 register Lisp_Object tem1
;
979 eassert (blv
== SYMBOL_BLV (symbol
));
985 ? !EQ (selected_frame
, tem1
)
986 : current_buffer
!= XBUFFER (tem1
)))
989 /* Unload the previously loaded binding. */
992 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
993 /* Choose the new binding. */
996 XSETSYMBOL (var
, symbol
);
997 if (blv
->frame_local
)
999 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1000 set_blv_where (blv
, selected_frame
);
1004 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1005 set_blv_where (blv
, Fcurrent_buffer ());
1008 if (!(blv
->found
= !NILP (tem1
)))
1009 tem1
= blv
->defcell
;
1011 /* Load the new binding. */
1012 set_blv_valcell (blv
, tem1
);
1014 store_symval_forwarding (blv
->fwd
, blv_value (blv
), NULL
);
1018 /* Find the value of a symbol, returning Qunbound if it's not bound.
1019 This is helpful for code which just wants to get a variable's value
1020 if it has one, without signaling an error.
1021 Note that it must not be possible to quit
1022 within this function. Great care is required for this. */
1025 find_symbol_value (Lisp_Object symbol
)
1027 struct Lisp_Symbol
*sym
;
1029 CHECK_SYMBOL (symbol
);
1030 sym
= XSYMBOL (symbol
);
1033 switch (sym
->redirect
)
1035 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1036 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1037 case SYMBOL_LOCALIZED
:
1039 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1040 swap_in_symval_forwarding (sym
, blv
);
1041 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : blv_value (blv
);
1044 case SYMBOL_FORWARDED
:
1045 return do_symval_forwarding (SYMBOL_FWD (sym
));
1046 default: emacs_abort ();
1050 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1051 doc
: /* Return SYMBOL's value. Error if that is void. */)
1052 (Lisp_Object symbol
)
1056 val
= find_symbol_value (symbol
);
1057 if (!EQ (val
, Qunbound
))
1060 xsignal1 (Qvoid_variable
, symbol
);
1063 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1064 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1065 (register Lisp_Object symbol
, Lisp_Object newval
)
1067 set_internal (symbol
, newval
, Qnil
, 0);
1071 /* Return true if SYMBOL currently has a let-binding
1072 which was made in the buffer that is now current. */
1075 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1077 struct specbinding
*p
;
1079 for (p
= specpdl_ptr
; p
> specpdl
; )
1080 if ((--p
)->func
== NULL
1081 && CONSP (p
->symbol
))
1083 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1084 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1085 if (symbol
== let_bound_symbol
1086 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1094 let_shadows_global_binding_p (Lisp_Object symbol
)
1096 struct specbinding
*p
;
1098 for (p
= specpdl_ptr
; p
> specpdl
; )
1099 if ((--p
)->func
== NULL
&& EQ (p
->symbol
, symbol
))
1105 /* Store the value NEWVAL into SYMBOL.
1106 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1107 (nil stands for the current buffer/frame).
1109 If BINDFLAG is false, then if this symbol is supposed to become
1110 local in every buffer where it is set, then we make it local.
1111 If BINDFLAG is true, we don't do that. */
1114 set_internal (Lisp_Object symbol
, Lisp_Object newval
, Lisp_Object where
,
1117 bool voide
= EQ (newval
, Qunbound
);
1118 struct Lisp_Symbol
*sym
;
1121 /* If restoring in a dead buffer, do nothing. */
1122 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1125 CHECK_SYMBOL (symbol
);
1126 if (SYMBOL_CONSTANT_P (symbol
))
1128 if (NILP (Fkeywordp (symbol
))
1129 || !EQ (newval
, Fsymbol_value (symbol
)))
1130 xsignal1 (Qsetting_constant
, symbol
);
1132 /* Allow setting keywords to their own value. */
1136 sym
= XSYMBOL (symbol
);
1139 switch (sym
->redirect
)
1141 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1142 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1143 case SYMBOL_LOCALIZED
:
1145 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1148 if (blv
->frame_local
)
1149 where
= selected_frame
;
1151 XSETBUFFER (where
, current_buffer
);
1153 /* If the current buffer is not the buffer whose binding is
1154 loaded, or if there may be frame-local bindings and the frame
1155 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1156 the default binding is loaded, the loaded binding may be the
1158 if (!EQ (blv
->where
, where
)
1159 /* Also unload a global binding (if the var is local_if_set). */
1160 || (EQ (blv
->valcell
, blv
->defcell
)))
1162 /* The currently loaded binding is not necessarily valid.
1163 We need to unload it, and choose a new binding. */
1165 /* Write out `realvalue' to the old loaded binding. */
1167 set_blv_value (blv
, do_symval_forwarding (blv
->fwd
));
1169 /* Find the new binding. */
1170 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1171 tem1
= Fassq (symbol
,
1173 ? XFRAME (where
)->param_alist
1174 : BVAR (XBUFFER (where
), local_var_alist
)));
1175 set_blv_where (blv
, where
);
1180 /* This buffer still sees the default value. */
1182 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1183 or if this is `let' rather than `set',
1184 make CURRENT-ALIST-ELEMENT point to itself,
1185 indicating that we're seeing the default value.
1186 Likewise if the variable has been let-bound
1187 in the current buffer. */
1188 if (bindflag
|| !blv
->local_if_set
1189 || let_shadows_buffer_binding_p (sym
))
1192 tem1
= blv
->defcell
;
1194 /* If it's a local_if_set, being set not bound,
1195 and we're not within a let that was made for this buffer,
1196 create a new buffer-local binding for the variable.
1197 That means, give this buffer a new assoc for a local value
1198 and load that binding. */
1201 /* local_if_set is only supported for buffer-local
1202 bindings, not for frame-local bindings. */
1203 eassert (!blv
->frame_local
);
1204 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1205 bset_local_var_alist
1207 Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
)));
1211 /* Record which binding is now loaded. */
1212 set_blv_valcell (blv
, tem1
);
1215 /* Store the new value in the cons cell. */
1216 set_blv_value (blv
, newval
);
1221 /* If storing void (making the symbol void), forward only through
1222 buffer-local indicator, not through Lisp_Objfwd, etc. */
1225 store_symval_forwarding (blv
->fwd
, newval
,
1227 ? XBUFFER (where
) : current_buffer
);
1231 case SYMBOL_FORWARDED
:
1234 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1235 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1236 if (BUFFER_OBJFWDP (innercontents
))
1238 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1239 int idx
= PER_BUFFER_IDX (offset
);
1242 && !let_shadows_buffer_binding_p (sym
))
1243 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1247 { /* If storing void (making the symbol void), forward only through
1248 buffer-local indicator, not through Lisp_Objfwd, etc. */
1249 sym
->redirect
= SYMBOL_PLAINVAL
;
1250 SET_SYMBOL_VAL (sym
, newval
);
1253 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1256 default: emacs_abort ();
1261 /* Access or set a buffer-local symbol's default value. */
1263 /* Return the default value of SYMBOL, but don't check for voidness.
1264 Return Qunbound if it is void. */
1267 default_value (Lisp_Object symbol
)
1269 struct Lisp_Symbol
*sym
;
1271 CHECK_SYMBOL (symbol
);
1272 sym
= XSYMBOL (symbol
);
1275 switch (sym
->redirect
)
1277 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1278 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1279 case SYMBOL_LOCALIZED
:
1281 /* If var is set up for a buffer that lacks a local value for it,
1282 the current value is nominally the default value.
1283 But the `realvalue' slot may be more up to date, since
1284 ordinary setq stores just that slot. So use that. */
1285 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1286 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1287 return do_symval_forwarding (blv
->fwd
);
1289 return XCDR (blv
->defcell
);
1291 case SYMBOL_FORWARDED
:
1293 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1295 /* For a built-in buffer-local variable, get the default value
1296 rather than letting do_symval_forwarding get the current value. */
1297 if (BUFFER_OBJFWDP (valcontents
))
1299 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1300 if (PER_BUFFER_IDX (offset
) != 0)
1301 return per_buffer_default (offset
);
1304 /* For other variables, get the current value. */
1305 return do_symval_forwarding (valcontents
);
1307 default: emacs_abort ();
1311 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1312 doc
: /* Return t if SYMBOL has a non-void default value.
1313 This is the value that is seen in buffers that do not have their own values
1314 for this variable. */)
1315 (Lisp_Object symbol
)
1317 register Lisp_Object value
;
1319 value
= default_value (symbol
);
1320 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1323 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1324 doc
: /* Return SYMBOL's default value.
1325 This is the value that is seen in buffers that do not have their own values
1326 for this variable. The default value is meaningful for variables with
1327 local bindings in certain buffers. */)
1328 (Lisp_Object symbol
)
1330 register Lisp_Object value
;
1332 value
= default_value (symbol
);
1333 if (!EQ (value
, Qunbound
))
1336 xsignal1 (Qvoid_variable
, symbol
);
1339 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1340 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1341 The default value is seen in buffers that do not have their own values
1342 for this variable. */)
1343 (Lisp_Object symbol
, Lisp_Object value
)
1345 struct Lisp_Symbol
*sym
;
1347 CHECK_SYMBOL (symbol
);
1348 if (SYMBOL_CONSTANT_P (symbol
))
1350 if (NILP (Fkeywordp (symbol
))
1351 || !EQ (value
, Fdefault_value (symbol
)))
1352 xsignal1 (Qsetting_constant
, symbol
);
1354 /* Allow setting keywords to their own value. */
1357 sym
= XSYMBOL (symbol
);
1360 switch (sym
->redirect
)
1362 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1363 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1364 case SYMBOL_LOCALIZED
:
1366 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1368 /* Store new value into the DEFAULT-VALUE slot. */
1369 XSETCDR (blv
->defcell
, value
);
1371 /* If the default binding is now loaded, set the REALVALUE slot too. */
1372 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1373 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1376 case SYMBOL_FORWARDED
:
1378 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1380 /* Handle variables like case-fold-search that have special slots
1382 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1383 if (BUFFER_OBJFWDP (valcontents
))
1385 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1386 int idx
= PER_BUFFER_IDX (offset
);
1388 set_per_buffer_default (offset
, value
);
1390 /* If this variable is not always local in all buffers,
1391 set it in the buffers that don't nominally have a local value. */
1397 if (!PER_BUFFER_VALUE_P (b
, idx
))
1398 set_per_buffer_value (b
, offset
, value
);
1403 return Fset (symbol
, value
);
1405 default: emacs_abort ();
1409 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1410 doc
: /* Set the default value of variable VAR to VALUE.
1411 VAR, the variable name, is literal (not evaluated);
1412 VALUE is an expression: it is evaluated and its value returned.
1413 The default value of a variable is seen in buffers
1414 that do not have their own values for the variable.
1416 More generally, you can use multiple variables and values, as in
1417 (setq-default VAR VALUE VAR VALUE...)
1418 This sets each VAR's default value to the corresponding VALUE.
1419 The VALUE for the Nth VAR can refer to the new default values
1421 usage: (setq-default [VAR VALUE]...) */)
1424 register Lisp_Object args_left
;
1425 register Lisp_Object val
, symbol
;
1426 struct gcpro gcpro1
;
1436 val
= eval_sub (Fcar (Fcdr (args_left
)));
1437 symbol
= XCAR (args_left
);
1438 Fset_default (symbol
, val
);
1439 args_left
= Fcdr (XCDR (args_left
));
1441 while (!NILP (args_left
));
1447 /* Lisp functions for creating and removing buffer-local variables. */
1452 union Lisp_Fwd
*fwd
;
1455 static struct Lisp_Buffer_Local_Value
*
1456 make_blv (struct Lisp_Symbol
*sym
, bool forwarded
,
1457 union Lisp_Val_Fwd valcontents
)
1459 struct Lisp_Buffer_Local_Value
*blv
= xmalloc (sizeof *blv
);
1463 XSETSYMBOL (symbol
, sym
);
1464 tem
= Fcons (symbol
, (forwarded
1465 ? do_symval_forwarding (valcontents
.fwd
)
1466 : valcontents
.value
));
1468 /* Buffer_Local_Values cannot have as realval a buffer-local
1469 or keyboard-local forwarding. */
1470 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1471 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1472 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1473 set_blv_where (blv
, Qnil
);
1474 blv
->frame_local
= 0;
1475 blv
->local_if_set
= 0;
1476 set_blv_defcell (blv
, tem
);
1477 set_blv_valcell (blv
, tem
);
1478 set_blv_found (blv
, 0);
1482 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1483 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1484 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1485 At any time, the value for the current buffer is in effect,
1486 unless the variable has never been set in this buffer,
1487 in which case the default value is in effect.
1488 Note that binding the variable with `let', or setting it while
1489 a `let'-style binding made in this buffer is in effect,
1490 does not make the variable buffer-local. Return VARIABLE.
1492 In most cases it is better to use `make-local-variable',
1493 which makes a variable local in just one buffer.
1495 The function `default-value' gets the default value and `set-default' sets it. */)
1496 (register Lisp_Object variable
)
1498 struct Lisp_Symbol
*sym
;
1499 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1500 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1501 bool forwarded
IF_LINT (= 0);
1503 CHECK_SYMBOL (variable
);
1504 sym
= XSYMBOL (variable
);
1507 switch (sym
->redirect
)
1509 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1510 case SYMBOL_PLAINVAL
:
1511 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1512 if (EQ (valcontents
.value
, Qunbound
))
1513 valcontents
.value
= Qnil
;
1515 case SYMBOL_LOCALIZED
:
1516 blv
= SYMBOL_BLV (sym
);
1517 if (blv
->frame_local
)
1518 error ("Symbol %s may not be buffer-local",
1519 SDATA (SYMBOL_NAME (variable
)));
1521 case SYMBOL_FORWARDED
:
1522 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1523 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1524 error ("Symbol %s may not be buffer-local",
1525 SDATA (SYMBOL_NAME (variable
)));
1526 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1529 default: emacs_abort ();
1533 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1537 blv
= make_blv (sym
, forwarded
, valcontents
);
1538 sym
->redirect
= SYMBOL_LOCALIZED
;
1539 SET_SYMBOL_BLV (sym
, blv
);
1542 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1543 if (let_shadows_global_binding_p (symbol
))
1544 message ("Making %s buffer-local while let-bound!",
1545 SDATA (SYMBOL_NAME (variable
)));
1549 blv
->local_if_set
= 1;
1553 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1554 1, 1, "vMake Local Variable: ",
1555 doc
: /* Make VARIABLE have a separate value in the current buffer.
1556 Other buffers will continue to share a common default value.
1557 \(The buffer-local value of VARIABLE starts out as the same value
1558 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1561 If the variable is already arranged to become local when set,
1562 this function causes a local value to exist for this buffer,
1563 just as setting the variable would do.
1565 This function returns VARIABLE, and therefore
1566 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1569 See also `make-variable-buffer-local'.
1571 Do not use `make-local-variable' to make a hook variable buffer-local.
1572 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1573 (Lisp_Object variable
)
1576 bool forwarded
IF_LINT (= 0);
1577 union Lisp_Val_Fwd valcontents
IF_LINT (= {LISP_INITIALLY_ZERO
});
1578 struct Lisp_Symbol
*sym
;
1579 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1581 CHECK_SYMBOL (variable
);
1582 sym
= XSYMBOL (variable
);
1585 switch (sym
->redirect
)
1587 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1588 case SYMBOL_PLAINVAL
:
1589 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1590 case SYMBOL_LOCALIZED
:
1591 blv
= SYMBOL_BLV (sym
);
1592 if (blv
->frame_local
)
1593 error ("Symbol %s may not be buffer-local",
1594 SDATA (SYMBOL_NAME (variable
)));
1596 case SYMBOL_FORWARDED
:
1597 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1598 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1599 error ("Symbol %s may not be buffer-local",
1600 SDATA (SYMBOL_NAME (variable
)));
1602 default: emacs_abort ();
1606 error ("Symbol %s may not be buffer-local",
1607 SDATA (SYMBOL_NAME (variable
)));
1609 if (blv
? blv
->local_if_set
1610 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1612 tem
= Fboundp (variable
);
1613 /* Make sure the symbol has a local value in this particular buffer,
1614 by setting it to the same value it already has. */
1615 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1620 blv
= make_blv (sym
, forwarded
, valcontents
);
1621 sym
->redirect
= SYMBOL_LOCALIZED
;
1622 SET_SYMBOL_BLV (sym
, blv
);
1625 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1626 if (let_shadows_global_binding_p (symbol
))
1627 message ("Making %s local to %s while let-bound!",
1628 SDATA (SYMBOL_NAME (variable
)),
1629 SDATA (BVAR (current_buffer
, name
)));
1633 /* Make sure this buffer has its own value of symbol. */
1634 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1635 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1638 if (let_shadows_buffer_binding_p (sym
))
1639 message ("Making %s buffer-local while locally let-bound!",
1640 SDATA (SYMBOL_NAME (variable
)));
1642 /* Swap out any local binding for some other buffer, and make
1643 sure the current value is permanently recorded, if it's the
1645 find_symbol_value (variable
);
1647 bset_local_var_alist
1649 Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1650 BVAR (current_buffer
, local_var_alist
)));
1652 /* Make sure symbol does not think it is set up for this buffer;
1653 force it to look once again for this buffer's value. */
1654 if (current_buffer
== XBUFFER (blv
->where
))
1655 set_blv_where (blv
, Qnil
);
1656 set_blv_found (blv
, 0);
1659 /* If the symbol forwards into a C variable, then load the binding
1660 for this buffer now. If C code modifies the variable before we
1661 load the binding in, then that new value will clobber the default
1662 binding the next time we unload it. */
1664 swap_in_symval_forwarding (sym
, blv
);
1669 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1670 1, 1, "vKill Local Variable: ",
1671 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1672 From now on the default value will apply in this buffer. Return VARIABLE. */)
1673 (register Lisp_Object variable
)
1675 register Lisp_Object tem
;
1676 struct Lisp_Buffer_Local_Value
*blv
;
1677 struct Lisp_Symbol
*sym
;
1679 CHECK_SYMBOL (variable
);
1680 sym
= XSYMBOL (variable
);
1683 switch (sym
->redirect
)
1685 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1686 case SYMBOL_PLAINVAL
: return variable
;
1687 case SYMBOL_FORWARDED
:
1689 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1690 if (BUFFER_OBJFWDP (valcontents
))
1692 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1693 int idx
= PER_BUFFER_IDX (offset
);
1697 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1698 set_per_buffer_value (current_buffer
, offset
,
1699 per_buffer_default (offset
));
1704 case SYMBOL_LOCALIZED
:
1705 blv
= SYMBOL_BLV (sym
);
1706 if (blv
->frame_local
)
1709 default: emacs_abort ();
1712 /* Get rid of this buffer's alist element, if any. */
1713 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1714 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1716 bset_local_var_alist
1718 Fdelq (tem
, BVAR (current_buffer
, local_var_alist
)));
1720 /* If the symbol is set up with the current buffer's binding
1721 loaded, recompute its value. We have to do it now, or else
1722 forwarded objects won't work right. */
1724 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1725 if (EQ (buf
, blv
->where
))
1727 set_blv_where (blv
, Qnil
);
1729 find_symbol_value (variable
);
1736 /* Lisp functions for creating and removing buffer-local variables. */
1738 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1739 when/if this is removed. */
1741 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1742 1, 1, "vMake Variable Frame Local: ",
1743 doc
: /* Enable VARIABLE to have frame-local bindings.
1744 This does not create any frame-local bindings for VARIABLE,
1745 it just makes them possible.
1747 A frame-local binding is actually a frame parameter value.
1748 If a frame F has a value for the frame parameter named VARIABLE,
1749 that also acts as a frame-local binding for VARIABLE in F--
1750 provided this function has been called to enable VARIABLE
1751 to have frame-local bindings at all.
1753 The only way to create a frame-local binding for VARIABLE in a frame
1754 is to set the VARIABLE frame parameter of that frame. See
1755 `modify-frame-parameters' for how to set frame parameters.
1757 Note that since Emacs 23.1, variables cannot be both buffer-local and
1758 frame-local any more (buffer-local bindings used to take precedence over
1759 frame-local bindings). */)
1760 (Lisp_Object variable
)
1763 union Lisp_Val_Fwd valcontents
;
1764 struct Lisp_Symbol
*sym
;
1765 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1767 CHECK_SYMBOL (variable
);
1768 sym
= XSYMBOL (variable
);
1771 switch (sym
->redirect
)
1773 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1774 case SYMBOL_PLAINVAL
:
1775 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1776 if (EQ (valcontents
.value
, Qunbound
))
1777 valcontents
.value
= Qnil
;
1779 case SYMBOL_LOCALIZED
:
1780 if (SYMBOL_BLV (sym
)->frame_local
)
1783 error ("Symbol %s may not be frame-local",
1784 SDATA (SYMBOL_NAME (variable
)));
1785 case SYMBOL_FORWARDED
:
1786 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1787 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1788 error ("Symbol %s may not be frame-local",
1789 SDATA (SYMBOL_NAME (variable
)));
1791 default: emacs_abort ();
1795 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1797 blv
= make_blv (sym
, forwarded
, valcontents
);
1798 blv
->frame_local
= 1;
1799 sym
->redirect
= SYMBOL_LOCALIZED
;
1800 SET_SYMBOL_BLV (sym
, blv
);
1803 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1804 if (let_shadows_global_binding_p (symbol
))
1805 message ("Making %s frame-local while let-bound!",
1806 SDATA (SYMBOL_NAME (variable
)));
1811 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1813 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1814 BUFFER defaults to the current buffer. */)
1815 (register Lisp_Object variable
, Lisp_Object buffer
)
1817 register struct buffer
*buf
;
1818 struct Lisp_Symbol
*sym
;
1821 buf
= current_buffer
;
1824 CHECK_BUFFER (buffer
);
1825 buf
= XBUFFER (buffer
);
1828 CHECK_SYMBOL (variable
);
1829 sym
= XSYMBOL (variable
);
1832 switch (sym
->redirect
)
1834 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1835 case SYMBOL_PLAINVAL
: return Qnil
;
1836 case SYMBOL_LOCALIZED
:
1838 Lisp_Object tail
, elt
, tmp
;
1839 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1840 XSETBUFFER (tmp
, buf
);
1841 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1843 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1846 if (EQ (variable
, XCAR (elt
)))
1848 eassert (!blv
->frame_local
);
1849 eassert (blv_found (blv
) || !EQ (blv
->where
, tmp
));
1853 eassert (!blv_found (blv
) || !EQ (blv
->where
, tmp
));
1856 case SYMBOL_FORWARDED
:
1858 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1859 if (BUFFER_OBJFWDP (valcontents
))
1861 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1862 int idx
= PER_BUFFER_IDX (offset
);
1863 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1868 default: emacs_abort ();
1872 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1874 doc
: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1875 BUFFER defaults to the current buffer.
1877 More precisely, return non-nil if either VARIABLE already has a local
1878 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1879 `make-variable-buffer-local'). */)
1880 (register Lisp_Object variable
, Lisp_Object buffer
)
1882 struct Lisp_Symbol
*sym
;
1884 CHECK_SYMBOL (variable
);
1885 sym
= XSYMBOL (variable
);
1888 switch (sym
->redirect
)
1890 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1891 case SYMBOL_PLAINVAL
: return Qnil
;
1892 case SYMBOL_LOCALIZED
:
1894 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1895 if (blv
->local_if_set
)
1897 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1898 return Flocal_variable_p (variable
, buffer
);
1900 case SYMBOL_FORWARDED
:
1901 /* All BUFFER_OBJFWD slots become local if they are set. */
1902 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1903 default: emacs_abort ();
1907 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1909 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1910 If the current binding is buffer-local, the value is the current buffer.
1911 If the current binding is frame-local, the value is the selected frame.
1912 If the current binding is global (the default), the value is nil. */)
1913 (register Lisp_Object variable
)
1915 struct Lisp_Symbol
*sym
;
1917 CHECK_SYMBOL (variable
);
1918 sym
= XSYMBOL (variable
);
1920 /* Make sure the current binding is actually swapped in. */
1921 find_symbol_value (variable
);
1924 switch (sym
->redirect
)
1926 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1927 case SYMBOL_PLAINVAL
: return Qnil
;
1928 case SYMBOL_FORWARDED
:
1930 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1931 if (KBOARD_OBJFWDP (valcontents
))
1932 return Fframe_terminal (Fselected_frame ());
1933 else if (!BUFFER_OBJFWDP (valcontents
))
1937 case SYMBOL_LOCALIZED
:
1938 /* For a local variable, record both the symbol and which
1939 buffer's or frame's value we are saving. */
1940 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1941 return Fcurrent_buffer ();
1942 else if (sym
->redirect
== SYMBOL_LOCALIZED
1943 && blv_found (SYMBOL_BLV (sym
)))
1944 return SYMBOL_BLV (sym
)->where
;
1947 default: emacs_abort ();
1951 /* This code is disabled now that we use the selected frame to return
1952 keyboard-local-values. */
1954 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1956 DEFUN ("terminal-local-value", Fterminal_local_value
,
1957 Sterminal_local_value
, 2, 2, 0,
1958 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1959 If SYMBOL is not a terminal-local variable, then return its normal
1960 value, like `symbol-value'.
1962 TERMINAL may be a terminal object, a frame, or nil (meaning the
1963 selected frame's terminal device). */)
1964 (Lisp_Object symbol
, Lisp_Object terminal
)
1967 struct terminal
*t
= get_terminal (terminal
, 1);
1968 push_kboard (t
->kboard
);
1969 result
= Fsymbol_value (symbol
);
1974 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1975 Sset_terminal_local_value
, 3, 3, 0,
1976 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1977 If VARIABLE is not a terminal-local variable, then set its normal
1978 binding, like `set'.
1980 TERMINAL may be a terminal object, a frame, or nil (meaning the
1981 selected frame's terminal device). */)
1982 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1985 struct terminal
*t
= get_terminal (terminal
, 1);
1986 push_kboard (d
->kboard
);
1987 result
= Fset (symbol
, value
);
1993 /* Find the function at the end of a chain of symbol function indirections. */
1995 /* If OBJECT is a symbol, find the end of its function chain and
1996 return the value found there. If OBJECT is not a symbol, just
1997 return it. If there is a cycle in the function chain, signal a
1998 cyclic-function-indirection error.
2000 This is like Findirect_function, except that it doesn't signal an
2001 error if the chain ends up unbound. */
2003 indirect_function (register Lisp_Object object
)
2005 Lisp_Object tortoise
, hare
;
2007 hare
= tortoise
= object
;
2011 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2013 hare
= XSYMBOL (hare
)->function
;
2014 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2016 hare
= XSYMBOL (hare
)->function
;
2018 tortoise
= XSYMBOL (tortoise
)->function
;
2020 if (EQ (hare
, tortoise
))
2021 xsignal1 (Qcyclic_function_indirection
, object
);
2027 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2028 doc
: /* Return the function at the end of OBJECT's function chain.
2029 If OBJECT is not a symbol, just return it. Otherwise, follow all
2030 function indirections to find the final function binding and return it.
2031 If the final symbol in the chain is unbound, signal a void-function error.
2032 Optional arg NOERROR non-nil means to return nil instead of signaling.
2033 Signal a cyclic-function-indirection error if there is a loop in the
2034 function chain of symbols. */)
2035 (register Lisp_Object object
, Lisp_Object noerror
)
2039 /* Optimize for no indirection. */
2041 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2042 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2043 result
= indirect_function (result
);
2044 if (!EQ (result
, Qunbound
))
2048 xsignal1 (Qvoid_function
, object
);
2053 /* Extract and set vector and string elements. */
2055 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2056 doc
: /* Return the element of ARRAY at index IDX.
2057 ARRAY may be a vector, a string, a char-table, a bool-vector,
2058 or a byte-code object. IDX starts at 0. */)
2059 (register Lisp_Object array
, Lisp_Object idx
)
2061 register EMACS_INT idxval
;
2064 idxval
= XINT (idx
);
2065 if (STRINGP (array
))
2068 ptrdiff_t idxval_byte
;
2070 if (idxval
< 0 || idxval
>= SCHARS (array
))
2071 args_out_of_range (array
, idx
);
2072 if (! STRING_MULTIBYTE (array
))
2073 return make_number ((unsigned char) SREF (array
, idxval
));
2074 idxval_byte
= string_char_to_byte (array
, idxval
);
2076 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2077 return make_number (c
);
2079 else if (BOOL_VECTOR_P (array
))
2083 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2084 args_out_of_range (array
, idx
);
2086 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2087 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2089 else if (CHAR_TABLE_P (array
))
2091 CHECK_CHARACTER (idx
);
2092 return CHAR_TABLE_REF (array
, idxval
);
2097 if (VECTORP (array
))
2098 size
= ASIZE (array
);
2099 else if (COMPILEDP (array
))
2100 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2102 wrong_type_argument (Qarrayp
, array
);
2104 if (idxval
< 0 || idxval
>= size
)
2105 args_out_of_range (array
, idx
);
2106 return AREF (array
, idxval
);
2110 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2111 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2112 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2113 bool-vector. IDX starts at 0. */)
2114 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2116 register EMACS_INT idxval
;
2119 idxval
= XINT (idx
);
2120 CHECK_ARRAY (array
, Qarrayp
);
2121 CHECK_IMPURE (array
);
2123 if (VECTORP (array
))
2125 if (idxval
< 0 || idxval
>= ASIZE (array
))
2126 args_out_of_range (array
, idx
);
2127 ASET (array
, idxval
, newelt
);
2129 else if (BOOL_VECTOR_P (array
))
2133 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2134 args_out_of_range (array
, idx
);
2136 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2138 if (! NILP (newelt
))
2139 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2141 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2142 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2144 else if (CHAR_TABLE_P (array
))
2146 CHECK_CHARACTER (idx
);
2147 CHAR_TABLE_SET (array
, idxval
, newelt
);
2153 if (idxval
< 0 || idxval
>= SCHARS (array
))
2154 args_out_of_range (array
, idx
);
2155 CHECK_CHARACTER (newelt
);
2156 c
= XFASTINT (newelt
);
2158 if (STRING_MULTIBYTE (array
))
2160 ptrdiff_t idxval_byte
, nbytes
;
2161 int prev_bytes
, new_bytes
;
2162 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2164 nbytes
= SBYTES (array
);
2165 idxval_byte
= string_char_to_byte (array
, idxval
);
2166 p1
= SDATA (array
) + idxval_byte
;
2167 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2168 new_bytes
= CHAR_STRING (c
, p0
);
2169 if (prev_bytes
!= new_bytes
)
2171 /* We must relocate the string data. */
2172 ptrdiff_t nchars
= SCHARS (array
);
2174 unsigned char *str
= SAFE_ALLOCA (nbytes
);
2176 memcpy (str
, SDATA (array
), nbytes
);
2177 allocate_string_data (XSTRING (array
), nchars
,
2178 nbytes
+ new_bytes
- prev_bytes
);
2179 memcpy (SDATA (array
), str
, idxval_byte
);
2180 p1
= SDATA (array
) + idxval_byte
;
2181 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2182 nbytes
- (idxval_byte
+ prev_bytes
));
2184 clear_string_char_byte_cache ();
2191 if (! SINGLE_BYTE_CHAR_P (c
))
2195 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2196 if (SREF (array
, i
) >= 0x80)
2197 args_out_of_range (array
, newelt
);
2198 /* ARRAY is an ASCII string. Convert it to a multibyte
2199 string, and try `aset' again. */
2200 STRING_SET_MULTIBYTE (array
);
2201 return Faset (array
, idx
, newelt
);
2203 SSET (array
, idxval
, c
);
2210 /* Arithmetic functions */
2212 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2215 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2217 double f1
= 0, f2
= 0;
2220 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2221 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2223 if (FLOATP (num1
) || FLOATP (num2
))
2226 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2227 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2233 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2238 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2243 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2248 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2253 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2258 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2267 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2268 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2269 (register Lisp_Object num1
, Lisp_Object num2
)
2271 return arithcompare (num1
, num2
, equal
);
2274 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2275 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2276 (register Lisp_Object num1
, Lisp_Object num2
)
2278 return arithcompare (num1
, num2
, less
);
2281 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2282 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2283 (register Lisp_Object num1
, Lisp_Object num2
)
2285 return arithcompare (num1
, num2
, grtr
);
2288 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2289 doc
: /* Return t if first arg is less than or equal to second arg.
2290 Both must be numbers or markers. */)
2291 (register Lisp_Object num1
, Lisp_Object num2
)
2293 return arithcompare (num1
, num2
, less_or_equal
);
2296 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2297 doc
: /* Return t if first arg is greater than or equal to second arg.
2298 Both must be numbers or markers. */)
2299 (register Lisp_Object num1
, Lisp_Object num2
)
2301 return arithcompare (num1
, num2
, grtr_or_equal
);
2304 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2305 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2306 (register Lisp_Object num1
, Lisp_Object num2
)
2308 return arithcompare (num1
, num2
, notequal
);
2311 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2312 doc
: /* Return t if NUMBER is zero. */)
2313 (register Lisp_Object number
)
2315 CHECK_NUMBER_OR_FLOAT (number
);
2317 if (FLOATP (number
))
2319 if (XFLOAT_DATA (number
) == 0.0)
2329 /* Convert the cons-of-integers, integer, or float value C to an
2330 unsigned value with maximum value MAX. Signal an error if C does not
2331 have a valid format or is out of range. */
2333 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2336 uintmax_t val
IF_LINT (= 0);
2339 valid
= 0 <= XINT (c
);
2342 else if (FLOATP (c
))
2344 double d
= XFLOAT_DATA (c
);
2346 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2352 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2354 uintmax_t top
= XFASTINT (XCAR (c
));
2355 Lisp_Object rest
= XCDR (c
);
2356 if (top
<= UINTMAX_MAX
>> 24 >> 16
2358 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2359 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2361 uintmax_t mid
= XFASTINT (XCAR (rest
));
2362 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2365 else if (top
<= UINTMAX_MAX
>> 16)
2369 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2371 val
= top
<< 16 | XFASTINT (rest
);
2377 if (! (valid
&& val
<= max
))
2378 error ("Not an in-range integer, float, or cons of integers");
2382 /* Convert the cons-of-integers, integer, or float value C to a signed
2383 value with extrema MIN and MAX. Signal an error if C does not have
2384 a valid format or is out of range. */
2386 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2389 intmax_t val
IF_LINT (= 0);
2395 else if (FLOATP (c
))
2397 double d
= XFLOAT_DATA (c
);
2399 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2405 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2407 intmax_t top
= XINT (XCAR (c
));
2408 Lisp_Object rest
= XCDR (c
);
2409 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2411 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2412 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2414 intmax_t mid
= XFASTINT (XCAR (rest
));
2415 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2418 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2422 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2424 val
= top
<< 16 | XFASTINT (rest
);
2430 if (! (valid
&& min
<= val
&& val
<= max
))
2431 error ("Not an in-range integer, float, or cons of integers");
2435 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2436 doc
: /* Return the decimal representation of NUMBER as a string.
2437 Uses a minus sign if negative.
2438 NUMBER may be an integer or a floating point number. */)
2439 (Lisp_Object number
)
2441 char buffer
[max (FLOAT_TO_STRING_BUFSIZE
, INT_BUFSIZE_BOUND (EMACS_INT
))];
2444 CHECK_NUMBER_OR_FLOAT (number
);
2446 if (FLOATP (number
))
2447 len
= float_to_string (buffer
, XFLOAT_DATA (number
));
2449 len
= sprintf (buffer
, "%"pI
"d", XINT (number
));
2451 return make_unibyte_string (buffer
, len
);
2454 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2455 doc
: /* Parse STRING as a decimal number and return the number.
2456 This parses both integers and floating point numbers.
2457 It ignores leading spaces and tabs, and all trailing chars.
2459 If BASE, interpret STRING as a number in that base. If BASE isn't
2460 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2461 If the base used is not 10, STRING is always parsed as integer. */)
2462 (register Lisp_Object string
, Lisp_Object base
)
2468 CHECK_STRING (string
);
2474 CHECK_NUMBER (base
);
2475 if (! (2 <= XINT (base
) && XINT (base
) <= 16))
2476 xsignal1 (Qargs_out_of_range
, base
);
2480 p
= SSDATA (string
);
2481 while (*p
== ' ' || *p
== '\t')
2484 val
= string_to_number (p
, b
, 1);
2485 return NILP (val
) ? make_number (0) : val
;
2501 static Lisp_Object
float_arith_driver (double, ptrdiff_t, enum arithop
,
2502 ptrdiff_t, Lisp_Object
*);
2504 arith_driver (enum arithop code
, ptrdiff_t nargs
, Lisp_Object
*args
)
2507 ptrdiff_t argnum
, ok_args
;
2508 EMACS_INT accum
= 0;
2509 EMACS_INT next
, ok_accum
;
2530 for (argnum
= 0; argnum
< nargs
; argnum
++)
2538 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2540 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2543 return float_arith_driver (ok_accum
, ok_args
, code
,
2546 next
= XINT (args
[argnum
]);
2550 if (INT_ADD_OVERFLOW (accum
, next
))
2558 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2563 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2566 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2568 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2570 accum
= ab
& INTMASK
;
2581 xsignal0 (Qarith_error
);
2595 if (!argnum
|| next
> accum
)
2599 if (!argnum
|| next
< accum
)
2605 XSETINT (val
, accum
);
2610 #define isnan(x) ((x) != (x))
2613 float_arith_driver (double accum
, ptrdiff_t argnum
, enum arithop code
,
2614 ptrdiff_t nargs
, Lisp_Object
*args
)
2616 register Lisp_Object val
;
2619 for (; argnum
< nargs
; argnum
++)
2621 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2622 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2626 next
= XFLOAT_DATA (val
);
2630 args
[argnum
] = val
; /* runs into a compiler bug. */
2631 next
= XINT (args
[argnum
]);
2639 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2649 if (! IEEE_FLOATING_POINT
&& next
== 0)
2650 xsignal0 (Qarith_error
);
2657 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2659 if (!argnum
|| isnan (next
) || next
> accum
)
2663 if (!argnum
|| isnan (next
) || next
< accum
)
2669 return make_float (accum
);
2673 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2674 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2675 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2676 (ptrdiff_t nargs
, Lisp_Object
*args
)
2678 return arith_driver (Aadd
, nargs
, args
);
2681 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2682 doc
: /* Negate number or subtract numbers or markers and return the result.
2683 With one arg, negates it. With more than one arg,
2684 subtracts all but the first from the first.
2685 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2686 (ptrdiff_t nargs
, Lisp_Object
*args
)
2688 return arith_driver (Asub
, nargs
, args
);
2691 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2692 doc
: /* Return product of any number of arguments, which are numbers or markers.
2693 usage: (* &rest NUMBERS-OR-MARKERS) */)
2694 (ptrdiff_t nargs
, Lisp_Object
*args
)
2696 return arith_driver (Amult
, nargs
, args
);
2699 DEFUN ("/", Fquo
, Squo
, 1, MANY
, 0,
2700 doc
: /* Return first argument divided by all the remaining arguments.
2701 The arguments must be numbers or markers.
2702 usage: (/ DIVIDEND &rest DIVISORS) */)
2703 (ptrdiff_t nargs
, Lisp_Object
*args
)
2706 for (argnum
= 2; argnum
< nargs
; argnum
++)
2707 if (FLOATP (args
[argnum
]))
2708 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2709 return arith_driver (Adiv
, nargs
, args
);
2712 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2713 doc
: /* Return remainder of X divided by Y.
2714 Both must be integers or markers. */)
2715 (register Lisp_Object x
, Lisp_Object y
)
2719 CHECK_NUMBER_COERCE_MARKER (x
);
2720 CHECK_NUMBER_COERCE_MARKER (y
);
2723 xsignal0 (Qarith_error
);
2725 XSETINT (val
, XINT (x
) % XINT (y
));
2729 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2730 doc
: /* Return X modulo Y.
2731 The result falls between zero (inclusive) and Y (exclusive).
2732 Both X and Y must be numbers or markers. */)
2733 (register Lisp_Object x
, Lisp_Object y
)
2738 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2739 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2741 if (FLOATP (x
) || FLOATP (y
))
2742 return fmod_float (x
, y
);
2748 xsignal0 (Qarith_error
);
2752 /* If the "remainder" comes out with the wrong sign, fix it. */
2753 if (i2
< 0 ? i1
> 0 : i1
< 0)
2760 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2761 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2762 The value is always a number; markers are converted to numbers.
2763 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2764 (ptrdiff_t nargs
, Lisp_Object
*args
)
2766 return arith_driver (Amax
, nargs
, args
);
2769 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2770 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2771 The value is always a number; markers are converted to numbers.
2772 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2773 (ptrdiff_t nargs
, Lisp_Object
*args
)
2775 return arith_driver (Amin
, nargs
, args
);
2778 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2779 doc
: /* Return bitwise-and of all the arguments.
2780 Arguments may be integers, or markers converted to integers.
2781 usage: (logand &rest INTS-OR-MARKERS) */)
2782 (ptrdiff_t nargs
, Lisp_Object
*args
)
2784 return arith_driver (Alogand
, nargs
, args
);
2787 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2788 doc
: /* Return bitwise-or of all the arguments.
2789 Arguments may be integers, or markers converted to integers.
2790 usage: (logior &rest INTS-OR-MARKERS) */)
2791 (ptrdiff_t nargs
, Lisp_Object
*args
)
2793 return arith_driver (Alogior
, nargs
, args
);
2796 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2797 doc
: /* Return bitwise-exclusive-or of all the arguments.
2798 Arguments may be integers, or markers converted to integers.
2799 usage: (logxor &rest INTS-OR-MARKERS) */)
2800 (ptrdiff_t nargs
, Lisp_Object
*args
)
2802 return arith_driver (Alogxor
, nargs
, args
);
2805 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2806 doc
: /* Return VALUE with its bits shifted left by COUNT.
2807 If COUNT is negative, shifting is actually to the right.
2808 In this case, the sign bit is duplicated. */)
2809 (register Lisp_Object value
, Lisp_Object count
)
2811 register Lisp_Object val
;
2813 CHECK_NUMBER (value
);
2814 CHECK_NUMBER (count
);
2816 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2818 else if (XINT (count
) > 0)
2819 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2820 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2821 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2823 XSETINT (val
, XINT (value
) >> -XINT (count
));
2827 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2828 doc
: /* Return VALUE with its bits shifted left by COUNT.
2829 If COUNT is negative, shifting is actually to the right.
2830 In this case, zeros are shifted in on the left. */)
2831 (register Lisp_Object value
, Lisp_Object count
)
2833 register Lisp_Object val
;
2835 CHECK_NUMBER (value
);
2836 CHECK_NUMBER (count
);
2838 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2840 else if (XINT (count
) > 0)
2841 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2842 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2845 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2849 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2850 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2851 Markers are converted to integers. */)
2852 (register Lisp_Object number
)
2854 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2856 if (FLOATP (number
))
2857 return (make_float (1.0 + XFLOAT_DATA (number
)));
2859 XSETINT (number
, XINT (number
) + 1);
2863 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2864 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2865 Markers are converted to integers. */)
2866 (register Lisp_Object number
)
2868 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2870 if (FLOATP (number
))
2871 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2873 XSETINT (number
, XINT (number
) - 1);
2877 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2878 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2879 (register Lisp_Object number
)
2881 CHECK_NUMBER (number
);
2882 XSETINT (number
, ~XINT (number
));
2886 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2887 doc
: /* Return the byteorder for the machine.
2888 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2889 lowercase l) for small endian machines. */)
2892 unsigned i
= 0x04030201;
2893 int order
= *(char *)&i
== 1 ? 108 : 66;
2895 return make_number (order
);
2903 Lisp_Object error_tail
, arith_tail
;
2905 DEFSYM (Qquote
, "quote");
2906 DEFSYM (Qlambda
, "lambda");
2907 DEFSYM (Qsubr
, "subr");
2908 DEFSYM (Qerror_conditions
, "error-conditions");
2909 DEFSYM (Qerror_message
, "error-message");
2910 DEFSYM (Qtop_level
, "top-level");
2912 DEFSYM (Qerror
, "error");
2913 DEFSYM (Quser_error
, "user-error");
2914 DEFSYM (Qquit
, "quit");
2915 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2916 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2917 DEFSYM (Qvoid_function
, "void-function");
2918 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2919 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2920 DEFSYM (Qvoid_variable
, "void-variable");
2921 DEFSYM (Qsetting_constant
, "setting-constant");
2922 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2924 DEFSYM (Qinvalid_function
, "invalid-function");
2925 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2926 DEFSYM (Qno_catch
, "no-catch");
2927 DEFSYM (Qend_of_file
, "end-of-file");
2928 DEFSYM (Qarith_error
, "arith-error");
2929 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2930 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2931 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2932 DEFSYM (Qtext_read_only
, "text-read-only");
2933 DEFSYM (Qmark_inactive
, "mark-inactive");
2935 DEFSYM (Qlistp
, "listp");
2936 DEFSYM (Qconsp
, "consp");
2937 DEFSYM (Qsymbolp
, "symbolp");
2938 DEFSYM (Qkeywordp
, "keywordp");
2939 DEFSYM (Qintegerp
, "integerp");
2940 DEFSYM (Qnatnump
, "natnump");
2941 DEFSYM (Qwholenump
, "wholenump");
2942 DEFSYM (Qstringp
, "stringp");
2943 DEFSYM (Qarrayp
, "arrayp");
2944 DEFSYM (Qsequencep
, "sequencep");
2945 DEFSYM (Qbufferp
, "bufferp");
2946 DEFSYM (Qvectorp
, "vectorp");
2947 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2948 DEFSYM (Qmarkerp
, "markerp");
2949 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
2950 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
2951 DEFSYM (Qboundp
, "boundp");
2952 DEFSYM (Qfboundp
, "fboundp");
2954 DEFSYM (Qfloatp
, "floatp");
2955 DEFSYM (Qnumberp
, "numberp");
2956 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
2958 DEFSYM (Qchar_table_p
, "char-table-p");
2959 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
2961 DEFSYM (Qsubrp
, "subrp");
2962 DEFSYM (Qunevalled
, "unevalled");
2963 DEFSYM (Qmany
, "many");
2965 DEFSYM (Qcdr
, "cdr");
2967 /* Handle automatic advice activation. */
2968 DEFSYM (Qad_advice_info
, "ad-advice-info");
2969 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
2971 error_tail
= pure_cons (Qerror
, Qnil
);
2973 /* ERROR is used as a signaler for random errors for which nothing else is
2976 Fput (Qerror
, Qerror_conditions
,
2978 Fput (Qerror
, Qerror_message
,
2979 build_pure_c_string ("error"));
2981 #define PUT_ERROR(sym, tail, msg) \
2982 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
2983 Fput (sym, Qerror_message, build_pure_c_string (msg))
2985 PUT_ERROR (Qquit
, Qnil
, "Quit");
2987 PUT_ERROR (Quser_error
, error_tail
, "");
2988 PUT_ERROR (Qwrong_type_argument
, error_tail
, "Wrong type argument");
2989 PUT_ERROR (Qargs_out_of_range
, error_tail
, "Args out of range");
2990 PUT_ERROR (Qvoid_function
, error_tail
,
2991 "Symbol's function definition is void");
2992 PUT_ERROR (Qcyclic_function_indirection
, error_tail
,
2993 "Symbol's chain of function indirections contains a loop");
2994 PUT_ERROR (Qcyclic_variable_indirection
, error_tail
,
2995 "Symbol's chain of variable indirections contains a loop");
2996 DEFSYM (Qcircular_list
, "circular-list");
2997 PUT_ERROR (Qcircular_list
, error_tail
, "List contains a loop");
2998 PUT_ERROR (Qvoid_variable
, error_tail
, "Symbol's value as variable is void");
2999 PUT_ERROR (Qsetting_constant
, error_tail
,
3000 "Attempt to set a constant symbol");
3001 PUT_ERROR (Qinvalid_read_syntax
, error_tail
, "Invalid read syntax");
3002 PUT_ERROR (Qinvalid_function
, error_tail
, "Invalid function");
3003 PUT_ERROR (Qwrong_number_of_arguments
, error_tail
,
3004 "Wrong number of arguments");
3005 PUT_ERROR (Qno_catch
, error_tail
, "No catch for tag");
3006 PUT_ERROR (Qend_of_file
, error_tail
, "End of file during parsing");
3008 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3009 Fput (Qarith_error
, Qerror_conditions
, arith_tail
);
3010 Fput (Qarith_error
, Qerror_message
, build_pure_c_string ("Arithmetic error"));
3012 PUT_ERROR (Qbeginning_of_buffer
, error_tail
, "Beginning of buffer");
3013 PUT_ERROR (Qend_of_buffer
, error_tail
, "End of buffer");
3014 PUT_ERROR (Qbuffer_read_only
, error_tail
, "Buffer is read-only");
3015 PUT_ERROR (Qtext_read_only
, pure_cons (Qbuffer_read_only
, error_tail
),
3016 "Text is read-only");
3018 DEFSYM (Qrange_error
, "range-error");
3019 DEFSYM (Qdomain_error
, "domain-error");
3020 DEFSYM (Qsingularity_error
, "singularity-error");
3021 DEFSYM (Qoverflow_error
, "overflow-error");
3022 DEFSYM (Qunderflow_error
, "underflow-error");
3024 PUT_ERROR (Qdomain_error
, arith_tail
, "Arithmetic domain error");
3026 PUT_ERROR (Qrange_error
, arith_tail
, "Arithmetic range error");
3028 PUT_ERROR (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
),
3029 "Arithmetic singularity error");
3031 PUT_ERROR (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
),
3032 "Arithmetic overflow error");
3033 PUT_ERROR (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
),
3034 "Arithmetic underflow error");
3038 staticpro (&Qunbound
);
3040 /* Types that type-of returns. */
3041 DEFSYM (Qinteger
, "integer");
3042 DEFSYM (Qsymbol
, "symbol");
3043 DEFSYM (Qstring
, "string");
3044 DEFSYM (Qcons
, "cons");
3045 DEFSYM (Qmarker
, "marker");
3046 DEFSYM (Qoverlay
, "overlay");
3047 DEFSYM (Qfloat
, "float");
3048 DEFSYM (Qwindow_configuration
, "window-configuration");
3049 DEFSYM (Qprocess
, "process");
3050 DEFSYM (Qwindow
, "window");
3051 DEFSYM (Qcompiled_function
, "compiled-function");
3052 DEFSYM (Qbuffer
, "buffer");
3053 DEFSYM (Qframe
, "frame");
3054 DEFSYM (Qvector
, "vector");
3055 DEFSYM (Qchar_table
, "char-table");
3056 DEFSYM (Qbool_vector
, "bool-vector");
3057 DEFSYM (Qhash_table
, "hash-table");
3058 DEFSYM (Qmisc
, "misc");
3060 DEFSYM (Qdefun
, "defun");
3062 DEFSYM (Qfont_spec
, "font-spec");
3063 DEFSYM (Qfont_entity
, "font-entity");
3064 DEFSYM (Qfont_object
, "font-object");
3066 DEFSYM (Qinteractive_form
, "interactive-form");
3067 DEFSYM (Qdefalias_fset_function
, "defalias-fset-function");
3069 defsubr (&Sindirect_variable
);
3070 defsubr (&Sinteractive_form
);
3073 defsubr (&Stype_of
);
3078 defsubr (&Sintegerp
);
3079 defsubr (&Sinteger_or_marker_p
);
3080 defsubr (&Snumberp
);
3081 defsubr (&Snumber_or_marker_p
);
3083 defsubr (&Snatnump
);
3084 defsubr (&Ssymbolp
);
3085 defsubr (&Skeywordp
);
3086 defsubr (&Sstringp
);
3087 defsubr (&Smultibyte_string_p
);
3088 defsubr (&Svectorp
);
3089 defsubr (&Schar_table_p
);
3090 defsubr (&Svector_or_char_table_p
);
3091 defsubr (&Sbool_vector_p
);
3093 defsubr (&Ssequencep
);
3094 defsubr (&Sbufferp
);
3095 defsubr (&Smarkerp
);
3097 defsubr (&Sbyte_code_function_p
);
3098 defsubr (&Schar_or_string_p
);
3101 defsubr (&Scar_safe
);
3102 defsubr (&Scdr_safe
);
3105 defsubr (&Ssymbol_function
);
3106 defsubr (&Sindirect_function
);
3107 defsubr (&Ssymbol_plist
);
3108 defsubr (&Ssymbol_name
);
3109 defsubr (&Smakunbound
);
3110 defsubr (&Sfmakunbound
);
3112 defsubr (&Sfboundp
);
3114 defsubr (&Sdefalias
);
3115 defsubr (&Ssetplist
);
3116 defsubr (&Ssymbol_value
);
3118 defsubr (&Sdefault_boundp
);
3119 defsubr (&Sdefault_value
);
3120 defsubr (&Sset_default
);
3121 defsubr (&Ssetq_default
);
3122 defsubr (&Smake_variable_buffer_local
);
3123 defsubr (&Smake_local_variable
);
3124 defsubr (&Skill_local_variable
);
3125 defsubr (&Smake_variable_frame_local
);
3126 defsubr (&Slocal_variable_p
);
3127 defsubr (&Slocal_variable_if_set_p
);
3128 defsubr (&Svariable_binding_locus
);
3129 #if 0 /* XXX Remove this. --lorentey */
3130 defsubr (&Sterminal_local_value
);
3131 defsubr (&Sset_terminal_local_value
);
3135 defsubr (&Snumber_to_string
);
3136 defsubr (&Sstring_to_number
);
3137 defsubr (&Seqlsign
);
3160 defsubr (&Sbyteorder
);
3161 defsubr (&Ssubr_arity
);
3162 defsubr (&Ssubr_name
);
3164 set_symbol_function (Qwholenump
, XSYMBOL (Qnatnump
)->function
);
3166 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3167 doc
: /* The largest value that is representable in a Lisp integer. */);
3168 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3169 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3171 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3172 doc
: /* The smallest value that is representable in a Lisp integer. */);
3173 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3174 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;