1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 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. */
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
53 extern double atof ();
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
87 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
96 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
100 circular_list_error (list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (predicate
, value
)
109 register Lisp_Object predicate
, value
;
111 /* If VALUE is not even a valid Lisp object, abort here
112 where we can get a backtrace showing where it came from. */
113 if ((unsigned int) XTYPE (value
) >= Lisp_Type_Limit
)
116 xsignal2 (Qwrong_type_argument
, predicate
, value
);
122 error ("Attempt to modify read-only object");
126 args_out_of_range (a1
, a2
)
129 xsignal2 (Qargs_out_of_range
, a1
, a2
);
133 args_out_of_range_3 (a1
, a2
, a3
)
134 Lisp_Object a1
, a2
, a3
;
136 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
139 /* On some machines, XINT needs a temporary location.
140 Here it is, in case it is needed. */
142 int sign_extend_temp
;
144 /* On a few machines, XINT can only be done by calling this. */
147 sign_extend_lisp_int (num
)
150 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
151 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
153 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
156 /* Data type predicates */
158 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
159 doc
: /* Return t if the two args are the same Lisp object. */)
161 Lisp_Object obj1
, obj2
;
168 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
169 doc
: /* Return t if OBJECT is nil. */)
178 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
179 doc
: /* Return a symbol representing the type of OBJECT.
180 The symbol returned names the object's basic type;
181 for example, (type-of 1) returns `integer'. */)
185 switch (XTYPE (object
))
200 switch (XMISCTYPE (object
))
202 case Lisp_Misc_Marker
:
204 case Lisp_Misc_Overlay
:
206 case Lisp_Misc_Float
:
211 case Lisp_Vectorlike
:
212 if (WINDOW_CONFIGURATIONP (object
))
213 return Qwindow_configuration
;
214 if (PROCESSP (object
))
216 if (WINDOWP (object
))
220 if (COMPILEDP (object
))
221 return Qcompiled_function
;
222 if (BUFFERP (object
))
224 if (CHAR_TABLE_P (object
))
226 if (BOOL_VECTOR_P (object
))
230 if (HASH_TABLE_P (object
))
232 if (FONT_SPEC_P (object
))
234 if (FONT_ENTITY_P (object
))
236 if (FONT_OBJECT_P (object
))
248 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
249 doc
: /* Return t if OBJECT is a cons cell. */)
258 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
259 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
268 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
269 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
270 Otherwise, return nil. */)
274 if (CONSP (object
) || NILP (object
))
279 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
290 doc
: /* Return t if OBJECT is a symbol. */)
294 if (SYMBOLP (object
))
299 /* Define this in C to avoid unnecessarily consing up the symbol
301 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
302 doc
: /* Return t if OBJECT is a keyword.
303 This means that it is a symbol with a print name beginning with `:'
304 interned in the initial obarray. */)
309 && SREF (SYMBOL_NAME (object
), 0) == ':'
310 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
315 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is a vector. */)
320 if (VECTORP (object
))
325 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
326 doc
: /* Return t if OBJECT is a string. */)
330 if (STRINGP (object
))
335 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
337 doc
: /* Return t if OBJECT is a multibyte string. */)
341 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
346 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
347 doc
: /* Return t if OBJECT is a char-table. */)
351 if (CHAR_TABLE_P (object
))
356 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
357 Svector_or_char_table_p
, 1, 1, 0,
358 doc
: /* Return t if OBJECT is a char-table or vector. */)
362 if (VECTORP (object
) || CHAR_TABLE_P (object
))
367 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a bool-vector. */)
372 if (BOOL_VECTOR_P (object
))
377 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
388 doc
: /* Return t if OBJECT is a sequence (list or array). */)
390 register Lisp_Object object
;
392 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
397 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is an editor buffer. */)
402 if (BUFFERP (object
))
407 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
412 if (MARKERP (object
))
417 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a built-in function. */)
427 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
429 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
433 if (COMPILEDP (object
))
438 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
439 doc
: /* Return t if OBJECT is a character or a string. */)
441 register Lisp_Object object
;
443 if (CHARACTERP (object
) || STRINGP (object
))
448 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is an integer. */)
453 if (INTEGERP (object
))
458 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
461 register Lisp_Object object
;
463 if (MARKERP (object
) || INTEGERP (object
))
468 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is a nonnegative integer. */)
473 if (NATNUMP (object
))
478 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
479 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
483 if (NUMBERP (object
))
489 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
490 Snumber_or_marker_p
, 1, 1, 0,
491 doc
: /* Return t if OBJECT is a number or a marker. */)
495 if (NUMBERP (object
) || MARKERP (object
))
500 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a floating point number. */)
511 /* Extract and set components of lists */
513 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
514 doc
: /* Return the car of LIST. If arg is nil, return nil.
515 Error if arg is not nil and not a cons cell. See also `car-safe'.
517 See Info node `(elisp)Cons Cells' for a discussion of related basic
518 Lisp concepts such as car, cdr, cons cell and list. */)
520 register Lisp_Object list
;
525 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
526 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
530 return CAR_SAFE (object
);
533 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
534 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
535 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
537 See Info node `(elisp)Cons Cells' for a discussion of related basic
538 Lisp concepts such as cdr, car, cons cell and list. */)
540 register Lisp_Object list
;
545 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
546 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
550 return CDR_SAFE (object
);
553 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
554 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
556 register Lisp_Object cell
, newcar
;
560 XSETCAR (cell
, newcar
);
564 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
565 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
567 register Lisp_Object cell
, newcdr
;
571 XSETCDR (cell
, newcdr
);
575 /* Extract and set components of symbols */
577 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
578 doc
: /* Return t if SYMBOL's value is not void. */)
580 register Lisp_Object symbol
;
582 Lisp_Object valcontents
;
583 CHECK_SYMBOL (symbol
);
585 valcontents
= SYMBOL_VALUE (symbol
);
587 if (BUFFER_LOCAL_VALUEP (valcontents
))
588 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
590 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
593 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
594 doc
: /* Return t if SYMBOL's function definition is not void. */)
596 register Lisp_Object symbol
;
598 CHECK_SYMBOL (symbol
);
599 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
602 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
603 doc
: /* Make SYMBOL's value be void.
606 register Lisp_Object symbol
;
608 CHECK_SYMBOL (symbol
);
609 if (SYMBOL_CONSTANT_P (symbol
))
610 xsignal1 (Qsetting_constant
, symbol
);
611 Fset (symbol
, Qunbound
);
615 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
616 doc
: /* Make SYMBOL's function definition be void.
619 register Lisp_Object symbol
;
621 CHECK_SYMBOL (symbol
);
622 if (NILP (symbol
) || EQ (symbol
, Qt
))
623 xsignal1 (Qsetting_constant
, symbol
);
624 XSYMBOL (symbol
)->function
= Qunbound
;
628 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
629 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
);
634 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
635 return XSYMBOL (symbol
)->function
;
636 xsignal1 (Qvoid_function
, symbol
);
639 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
640 doc
: /* Return SYMBOL's property list. */)
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
);
645 return XSYMBOL (symbol
)->plist
;
648 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
649 doc
: /* Return SYMBOL's name, a string. */)
651 register Lisp_Object symbol
;
653 register Lisp_Object name
;
655 CHECK_SYMBOL (symbol
);
656 name
= SYMBOL_NAME (symbol
);
660 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
661 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
663 register Lisp_Object symbol
, definition
;
665 register Lisp_Object function
;
667 CHECK_SYMBOL (symbol
);
668 if (NILP (symbol
) || EQ (symbol
, Qt
))
669 xsignal1 (Qsetting_constant
, symbol
);
671 function
= XSYMBOL (symbol
)->function
;
673 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
674 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
676 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
677 Fput (symbol
, Qautoload
, XCDR (function
));
679 XSYMBOL (symbol
)->function
= definition
;
680 /* Handle automatic advice activation */
681 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
683 call2 (Qad_activate_internal
, symbol
, Qnil
);
684 definition
= XSYMBOL (symbol
)->function
;
689 extern Lisp_Object Qfunction_documentation
;
691 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
692 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
693 Associates the function with the current load file, if any.
694 The optional third argument DOCSTRING specifies the documentation string
695 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
696 determined by DEFINITION. */)
697 (symbol
, definition
, docstring
)
698 register Lisp_Object symbol
, definition
, docstring
;
700 CHECK_SYMBOL (symbol
);
701 if (CONSP (XSYMBOL (symbol
)->function
)
702 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
703 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
704 definition
= Ffset (symbol
, definition
);
705 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
706 if (!NILP (docstring
))
707 Fput (symbol
, Qfunction_documentation
, docstring
);
711 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
712 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
714 register Lisp_Object symbol
, newplist
;
716 CHECK_SYMBOL (symbol
);
717 XSYMBOL (symbol
)->plist
= newplist
;
721 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
722 doc
: /* Return minimum and maximum number of args allowed for SUBR.
723 SUBR must be a built-in function.
724 The returned value is a pair (MIN . MAX). MIN is the minimum number
725 of args. MAX is the maximum number or the symbol `many', for a
726 function with `&rest' args, or `unevalled' for a special form. */)
730 short minargs
, maxargs
;
732 minargs
= XSUBR (subr
)->min_args
;
733 maxargs
= XSUBR (subr
)->max_args
;
735 return Fcons (make_number (minargs
), Qmany
);
736 else if (maxargs
== UNEVALLED
)
737 return Fcons (make_number (minargs
), Qunevalled
);
739 return Fcons (make_number (minargs
), make_number (maxargs
));
742 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
743 doc
: /* Return name of subroutine SUBR.
744 SUBR must be a built-in function. */)
750 name
= XSUBR (subr
)->symbol_name
;
751 return make_string (name
, strlen (name
));
754 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
755 doc
: /* Return the interactive form of CMD or nil if none.
756 If CMD is not a command, the return value is nil.
757 Value, if non-nil, is a list \(interactive SPEC). */)
761 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
763 if (NILP (fun
) || EQ (fun
, Qunbound
))
766 /* Use an `interactive-form' property if present, analogous to the
767 function-documentation property. */
769 while (SYMBOLP (fun
))
771 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
775 fun
= Fsymbol_function (fun
);
780 char *spec
= XSUBR (fun
)->intspec
;
782 return list2 (Qinteractive
,
783 (*spec
!= '(') ? build_string (spec
) :
784 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
786 else if (COMPILEDP (fun
))
788 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
789 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
791 else if (CONSP (fun
))
793 Lisp_Object funcar
= XCAR (fun
);
794 if (EQ (funcar
, Qlambda
))
795 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
796 else if (EQ (funcar
, Qautoload
))
800 do_autoload (fun
, cmd
);
802 return Finteractive_form (cmd
);
809 /***********************************************************************
810 Getting and Setting Values of Symbols
811 ***********************************************************************/
813 /* Return the symbol holding SYMBOL's value. Signal
814 `cyclic-variable-indirection' if SYMBOL's chain of variable
815 indirections contains a loop. */
818 indirect_variable (symbol
)
819 struct Lisp_Symbol
*symbol
;
821 struct Lisp_Symbol
*tortoise
, *hare
;
823 hare
= tortoise
= symbol
;
825 while (hare
->indirect_variable
)
827 hare
= XSYMBOL (hare
->value
);
828 if (!hare
->indirect_variable
)
831 hare
= XSYMBOL (hare
->value
);
832 tortoise
= XSYMBOL (tortoise
->value
);
834 if (hare
== tortoise
)
837 XSETSYMBOL (tem
, symbol
);
838 xsignal1 (Qcyclic_variable_indirection
, tem
);
846 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
847 doc
: /* Return the variable at the end of OBJECT's variable chain.
848 If OBJECT is a symbol, follow all variable indirections and return the final
849 variable. If OBJECT is not a symbol, just return it.
850 Signal a cyclic-variable-indirection error if there is a loop in the
851 variable chain of symbols. */)
855 if (SYMBOLP (object
))
856 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
861 /* Given the raw contents of a symbol value cell,
862 return the Lisp value of the symbol.
863 This does not handle buffer-local variables; use
864 swap_in_symval_forwarding for that. */
867 do_symval_forwarding (valcontents
)
868 register Lisp_Object valcontents
;
870 register Lisp_Object val
;
871 if (MISCP (valcontents
))
872 switch (XMISCTYPE (valcontents
))
874 case Lisp_Misc_Intfwd
:
875 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
878 case Lisp_Misc_Boolfwd
:
879 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
881 case Lisp_Misc_Objfwd
:
882 return *XOBJFWD (valcontents
)->objvar
;
884 case Lisp_Misc_Buffer_Objfwd
:
885 return PER_BUFFER_VALUE (current_buffer
,
886 XBUFFER_OBJFWD (valcontents
)->offset
);
888 case Lisp_Misc_Kboard_Objfwd
:
889 /* We used to simply use current_kboard here, but from Lisp
890 code, it's value is often unexpected. It seems nicer to
891 allow constructions like this to work as intuitively expected:
893 (with-selected-frame frame
894 (define-key local-function-map "\eOP" [f1]))
896 On the other hand, this affects the semantics of
897 last-command and real-last-command, and people may rely on
898 that. I took a quick look at the Lisp codebase, and I
899 don't think anything will break. --lorentey */
900 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
901 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
906 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
907 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
908 buffer-independent contents of the value cell: forwarded just one
909 step past the buffer-localness.
911 BUF non-zero means set the value in buffer BUF instead of the
912 current buffer. This only plays a role for per-buffer variables. */
915 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
917 register Lisp_Object valcontents
, newval
;
920 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
923 switch (XMISCTYPE (valcontents
))
925 case Lisp_Misc_Intfwd
:
926 CHECK_NUMBER (newval
);
927 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
928 /* This can never happen since intvar points to an EMACS_INT
929 which is at least large enough to hold a Lisp_Object.
930 if (*XINTFWD (valcontents)->intvar != XINT (newval))
931 error ("Value out of range for variable `%s'",
932 SDATA (SYMBOL_NAME (symbol))); */
935 case Lisp_Misc_Boolfwd
:
936 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
939 case Lisp_Misc_Objfwd
:
940 *XOBJFWD (valcontents
)->objvar
= newval
;
942 /* If this variable is a default for something stored
943 in the buffer itself, such as default-fill-column,
944 find the buffers that don't have local values for it
946 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
947 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
949 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
950 - (char *) &buffer_defaults
);
951 int idx
= PER_BUFFER_IDX (offset
);
958 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
963 buf
= Fcdr (XCAR (tail
));
964 if (!BUFFERP (buf
)) continue;
967 if (! PER_BUFFER_VALUE_P (b
, idx
))
968 PER_BUFFER_VALUE (b
, offset
) = newval
;
973 case Lisp_Misc_Buffer_Objfwd
:
975 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
976 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
978 if (! NILP (type
) && ! NILP (newval
)
979 && XTYPE (newval
) != XINT (type
))
980 buffer_slot_type_mismatch (newval
, XINT (type
));
983 buf
= current_buffer
;
984 PER_BUFFER_VALUE (buf
, offset
) = newval
;
988 case Lisp_Misc_Kboard_Objfwd
:
990 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
991 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
992 *(Lisp_Object
*) p
= newval
;
1003 valcontents
= SYMBOL_VALUE (symbol
);
1004 if (BUFFER_LOCAL_VALUEP (valcontents
))
1005 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1007 SET_SYMBOL_VALUE (symbol
, newval
);
1011 /* Set up SYMBOL to refer to its global binding.
1012 This makes it safe to alter the status of other bindings. */
1015 swap_in_global_binding (symbol
)
1018 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1019 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1020 Lisp_Object cdr
= blv
->cdr
;
1022 /* Unload the previously loaded binding. */
1023 Fsetcdr (XCAR (cdr
),
1024 do_symval_forwarding (blv
->realvalue
));
1026 /* Select the global binding in the symbol. */
1028 store_symval_forwarding (symbol
, blv
->realvalue
, XCDR (cdr
), NULL
);
1030 /* Indicate that the global binding is set up now. */
1033 blv
->found_for_frame
= 0;
1034 blv
->found_for_buffer
= 0;
1037 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1038 VALCONTENTS is the contents of its value cell,
1039 which points to a struct Lisp_Buffer_Local_Value.
1041 Return the value forwarded one step past the buffer-local stage.
1042 This could be another forwarding pointer. */
1045 swap_in_symval_forwarding (symbol
, valcontents
)
1046 Lisp_Object symbol
, valcontents
;
1048 register Lisp_Object tem1
;
1050 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1053 || current_buffer
!= XBUFFER (tem1
)
1054 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1055 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1057 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1058 if (sym
->indirect_variable
)
1060 sym
= indirect_variable (sym
);
1061 XSETSYMBOL (symbol
, sym
);
1064 /* Unload the previously loaded binding. */
1065 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1067 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1068 /* Choose the new binding. */
1069 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1070 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1071 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1074 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1075 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1077 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1079 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1082 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1084 /* Load the new binding. */
1085 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1086 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1087 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1088 store_symval_forwarding (symbol
,
1089 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1092 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1095 /* Find the value of a symbol, returning Qunbound if it's not bound.
1096 This is helpful for code which just wants to get a variable's value
1097 if it has one, without signaling an error.
1098 Note that it must not be possible to quit
1099 within this function. Great care is required for this. */
1102 find_symbol_value (symbol
)
1105 register Lisp_Object valcontents
;
1106 register Lisp_Object val
;
1108 CHECK_SYMBOL (symbol
);
1109 valcontents
= SYMBOL_VALUE (symbol
);
1111 if (BUFFER_LOCAL_VALUEP (valcontents
))
1112 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1114 return do_symval_forwarding (valcontents
);
1117 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1118 doc
: /* Return SYMBOL's value. Error if that is void. */)
1124 val
= find_symbol_value (symbol
);
1125 if (!EQ (val
, Qunbound
))
1128 xsignal1 (Qvoid_variable
, symbol
);
1131 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1132 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1134 register Lisp_Object symbol
, newval
;
1136 return set_internal (symbol
, newval
, current_buffer
, 0);
1139 /* Return 1 if SYMBOL currently has a let-binding
1140 which was made in the buffer that is now current. */
1143 let_shadows_buffer_binding_p (symbol
)
1144 struct Lisp_Symbol
*symbol
;
1146 volatile struct specbinding
*p
;
1148 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1150 && CONSP (p
->symbol
))
1152 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1153 if ((symbol
== let_bound_symbol
1154 || (let_bound_symbol
->indirect_variable
1155 && symbol
== indirect_variable (let_bound_symbol
)))
1156 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1160 return p
>= specpdl
;
1163 /* Store the value NEWVAL into SYMBOL.
1164 If buffer-locality is an issue, BUF specifies which buffer to use.
1165 (0 stands for the current buffer.)
1167 If BINDFLAG is zero, then if this symbol is supposed to become
1168 local in every buffer where it is set, then we make it local.
1169 If BINDFLAG is nonzero, we don't do that. */
1172 set_internal (symbol
, newval
, buf
, bindflag
)
1173 register Lisp_Object symbol
, newval
;
1177 int voide
= EQ (newval
, Qunbound
);
1179 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1182 buf
= current_buffer
;
1184 /* If restoring in a dead buffer, do nothing. */
1185 if (NILP (buf
->name
))
1188 CHECK_SYMBOL (symbol
);
1189 if (SYMBOL_CONSTANT_P (symbol
)
1190 && (NILP (Fkeywordp (symbol
))
1191 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1192 xsignal1 (Qsetting_constant
, symbol
);
1194 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1196 if (BUFFER_OBJFWDP (valcontents
))
1198 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1199 int idx
= PER_BUFFER_IDX (offset
);
1202 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1203 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1205 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1207 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1208 if (XSYMBOL (symbol
)->indirect_variable
)
1209 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1211 /* What binding is loaded right now? */
1212 current_alist_element
1213 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1215 /* If the current buffer is not the buffer whose binding is
1216 loaded, or if there may be frame-local bindings and the frame
1217 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1218 the default binding is loaded, the loaded binding may be the
1220 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1221 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1222 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1223 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1224 /* Also unload a global binding (if the var is local_if_set). */
1225 || (EQ (XCAR (current_alist_element
),
1226 current_alist_element
)))
1228 /* The currently loaded binding is not necessarily valid.
1229 We need to unload it, and choose a new binding. */
1231 /* Write out `realvalue' to the old loaded binding. */
1232 Fsetcdr (current_alist_element
,
1233 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1235 /* Find the new binding. */
1236 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1237 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1238 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1242 /* This buffer still sees the default value. */
1244 /* If the variable is not local_if_set,
1245 or if this is `let' rather than `set',
1246 make CURRENT-ALIST-ELEMENT point to itself,
1247 indicating that we're seeing the default value.
1248 Likewise if the variable has been let-bound
1249 in the current buffer. */
1250 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1251 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1253 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1255 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1256 tem1
= Fassq (symbol
,
1257 XFRAME (selected_frame
)->param_alist
);
1260 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1262 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1264 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1265 and we're not within a let that was made for this buffer,
1266 create a new buffer-local binding for the variable.
1267 That means, give this buffer a new assoc for a local value
1268 and load that binding. */
1271 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1272 buf
->local_var_alist
1273 = Fcons (tem1
, buf
->local_var_alist
);
1277 /* Record which binding is now loaded. */
1278 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1280 /* Set `buffer' and `frame' slots for the binding now loaded. */
1281 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1282 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1284 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1286 /* Store the new value in the cons-cell. */
1287 XSETCDR (XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
), newval
);
1290 /* If storing void (making the symbol void), forward only through
1291 buffer-local indicator, not through Lisp_Objfwd, etc. */
1293 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1295 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1300 /* Access or set a buffer-local symbol's default value. */
1302 /* Return the default value of SYMBOL, but don't check for voidness.
1303 Return Qunbound if it is void. */
1306 default_value (symbol
)
1309 register Lisp_Object valcontents
;
1311 CHECK_SYMBOL (symbol
);
1312 valcontents
= SYMBOL_VALUE (symbol
);
1314 /* For a built-in buffer-local variable, get the default value
1315 rather than letting do_symval_forwarding get the current value. */
1316 if (BUFFER_OBJFWDP (valcontents
))
1318 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1319 if (PER_BUFFER_IDX (offset
) != 0)
1320 return PER_BUFFER_DEFAULT (offset
);
1323 /* Handle user-created local variables. */
1324 if (BUFFER_LOCAL_VALUEP (valcontents
))
1326 /* If var is set up for a buffer that lacks a local value for it,
1327 the current value is nominally the default value.
1328 But the `realvalue' slot may be more up to date, since
1329 ordinary setq stores just that slot. So use that. */
1330 Lisp_Object current_alist_element
, alist_element_car
;
1331 current_alist_element
1332 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1333 alist_element_car
= XCAR (current_alist_element
);
1334 if (EQ (alist_element_car
, current_alist_element
))
1335 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1337 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1339 /* For other variables, get the current value. */
1340 return do_symval_forwarding (valcontents
);
1343 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1344 doc
: /* Return t if SYMBOL has a non-void default value.
1345 This is the value that is seen in buffers that do not have their own values
1346 for this variable. */)
1350 register Lisp_Object value
;
1352 value
= default_value (symbol
);
1353 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1356 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1357 doc
: /* Return SYMBOL's default value.
1358 This is the value that is seen in buffers that do not have their own values
1359 for this variable. The default value is meaningful for variables with
1360 local bindings in certain buffers. */)
1364 register Lisp_Object value
;
1366 value
= default_value (symbol
);
1367 if (!EQ (value
, Qunbound
))
1370 xsignal1 (Qvoid_variable
, symbol
);
1373 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1374 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1375 The default value is seen in buffers that do not have their own values
1376 for this variable. */)
1378 Lisp_Object symbol
, value
;
1380 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1382 CHECK_SYMBOL (symbol
);
1383 valcontents
= SYMBOL_VALUE (symbol
);
1385 /* Handle variables like case-fold-search that have special slots
1386 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1388 if (BUFFER_OBJFWDP (valcontents
))
1390 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1391 int idx
= PER_BUFFER_IDX (offset
);
1393 PER_BUFFER_DEFAULT (offset
) = value
;
1395 /* If this variable is not always local in all buffers,
1396 set it in the buffers that don't nominally have a local value. */
1401 for (b
= all_buffers
; b
; b
= b
->next
)
1402 if (!PER_BUFFER_VALUE_P (b
, idx
))
1403 PER_BUFFER_VALUE (b
, offset
) = value
;
1408 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1409 return Fset (symbol
, value
);
1411 /* Store new value into the DEFAULT-VALUE slot. */
1412 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1414 /* If the default binding is now loaded, set the REALVALUE slot too. */
1415 current_alist_element
1416 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1417 alist_element_buffer
= Fcar (current_alist_element
);
1418 if (EQ (alist_element_buffer
, current_alist_element
))
1419 store_symval_forwarding (symbol
,
1420 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1426 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1427 doc
: /* Set the default value of variable VAR to VALUE.
1428 VAR, the variable name, is literal (not evaluated);
1429 VALUE is an expression: it is evaluated and its value returned.
1430 The default value of a variable is seen in buffers
1431 that do not have their own values for the variable.
1433 More generally, you can use multiple variables and values, as in
1434 (setq-default VAR VALUE VAR VALUE...)
1435 This sets each VAR's default value to the corresponding VALUE.
1436 The VALUE for the Nth VAR can refer to the new default values
1438 usage: (setq-default [VAR VALUE]...) */)
1442 register Lisp_Object args_left
;
1443 register Lisp_Object val
, symbol
;
1444 struct gcpro gcpro1
;
1454 val
= Feval (Fcar (Fcdr (args_left
)));
1455 symbol
= XCAR (args_left
);
1456 Fset_default (symbol
, val
);
1457 args_left
= Fcdr (XCDR (args_left
));
1459 while (!NILP (args_left
));
1465 /* Lisp functions for creating and removing buffer-local variables. */
1467 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1468 1, 1, "vMake Variable Buffer Local: ",
1469 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1470 At any time, the value for the current buffer is in effect,
1471 unless the variable has never been set in this buffer,
1472 in which case the default value is in effect.
1473 Note that binding the variable with `let', or setting it while
1474 a `let'-style binding made in this buffer is in effect,
1475 does not make the variable buffer-local. Return VARIABLE.
1477 In most cases it is better to use `make-local-variable',
1478 which makes a variable local in just one buffer.
1480 The function `default-value' gets the default value and `set-default' sets it. */)
1482 register Lisp_Object variable
;
1484 register Lisp_Object tem
, valcontents
, newval
;
1485 struct Lisp_Symbol
*sym
;
1487 CHECK_SYMBOL (variable
);
1488 sym
= indirect_variable (XSYMBOL (variable
));
1490 valcontents
= sym
->value
;
1491 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1492 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1494 if (BUFFER_OBJFWDP (valcontents
))
1496 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1498 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1499 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1500 newval
= valcontents
;
1504 if (EQ (valcontents
, Qunbound
))
1506 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1508 newval
= allocate_misc ();
1509 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1510 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1511 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1512 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1513 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1514 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1515 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1516 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1517 sym
->value
= newval
;
1519 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1523 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1524 1, 1, "vMake Local Variable: ",
1525 doc
: /* Make VARIABLE have a separate value in the current buffer.
1526 Other buffers will continue to share a common default value.
1527 \(The buffer-local value of VARIABLE starts out as the same value
1528 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1531 If the variable is already arranged to become local when set,
1532 this function causes a local value to exist for this buffer,
1533 just as setting the variable would do.
1535 This function returns VARIABLE, and therefore
1536 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1539 See also `make-variable-buffer-local'.
1541 Do not use `make-local-variable' to make a hook variable buffer-local.
1542 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1544 register Lisp_Object variable
;
1546 register Lisp_Object tem
, valcontents
;
1547 struct Lisp_Symbol
*sym
;
1549 CHECK_SYMBOL (variable
);
1550 sym
= indirect_variable (XSYMBOL (variable
));
1552 valcontents
= sym
->value
;
1553 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1554 || (BUFFER_LOCAL_VALUEP (valcontents
)
1555 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1556 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1558 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1559 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1560 || BUFFER_OBJFWDP (valcontents
))
1562 tem
= Fboundp (variable
);
1564 /* Make sure the symbol has a local value in this particular buffer,
1565 by setting it to the same value it already has. */
1566 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1569 /* Make sure symbol is set up to hold per-buffer values. */
1570 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1573 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1575 newval
= allocate_misc ();
1576 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1577 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1578 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1579 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1580 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1581 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1582 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1583 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1584 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1585 sym
->value
= newval
;
1587 /* Make sure this buffer has its own value of symbol. */
1588 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1589 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1592 /* Swap out any local binding for some other buffer, and make
1593 sure the current value is permanently recorded, if it's the
1595 find_symbol_value (variable
);
1597 current_buffer
->local_var_alist
1598 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (sym
->value
)->cdr
)),
1599 current_buffer
->local_var_alist
);
1601 /* Make sure symbol does not think it is set up for this buffer;
1602 force it to look once again for this buffer's value. */
1604 Lisp_Object
*pvalbuf
;
1606 valcontents
= sym
->value
;
1608 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1609 if (current_buffer
== XBUFFER (*pvalbuf
))
1611 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1615 /* If the symbol forwards into a C variable, then load the binding
1616 for this buffer now. If C code modifies the variable before we
1617 load the binding in, then that new value will clobber the default
1618 binding the next time we unload it. */
1619 valcontents
= XBUFFER_LOCAL_VALUE (sym
->value
)->realvalue
;
1620 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1621 swap_in_symval_forwarding (variable
, sym
->value
);
1626 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1627 1, 1, "vKill Local Variable: ",
1628 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1629 From now on the default value will apply in this buffer. Return VARIABLE. */)
1631 register Lisp_Object variable
;
1633 register Lisp_Object tem
, valcontents
;
1634 struct Lisp_Symbol
*sym
;
1636 CHECK_SYMBOL (variable
);
1637 sym
= indirect_variable (XSYMBOL (variable
));
1639 valcontents
= sym
->value
;
1641 if (BUFFER_OBJFWDP (valcontents
))
1643 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1644 int idx
= PER_BUFFER_IDX (offset
);
1648 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1649 PER_BUFFER_VALUE (current_buffer
, offset
)
1650 = PER_BUFFER_DEFAULT (offset
);
1655 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1658 /* Get rid of this buffer's alist element, if any. */
1659 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1660 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1662 current_buffer
->local_var_alist
1663 = Fdelq (tem
, current_buffer
->local_var_alist
);
1665 /* If the symbol is set up with the current buffer's binding
1666 loaded, recompute its value. We have to do it now, or else
1667 forwarded objects won't work right. */
1669 Lisp_Object
*pvalbuf
, buf
;
1670 valcontents
= sym
->value
;
1671 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1672 XSETBUFFER (buf
, current_buffer
);
1673 if (EQ (buf
, *pvalbuf
))
1676 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1677 find_symbol_value (variable
);
1684 /* Lisp functions for creating and removing buffer-local variables. */
1686 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1687 when/if this is removed. */
1689 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1690 1, 1, "vMake Variable Frame Local: ",
1691 doc
: /* Enable VARIABLE to have frame-local bindings.
1692 This does not create any frame-local bindings for VARIABLE,
1693 it just makes them possible.
1695 A frame-local binding is actually a frame parameter value.
1696 If a frame F has a value for the frame parameter named VARIABLE,
1697 that also acts as a frame-local binding for VARIABLE in F--
1698 provided this function has been called to enable VARIABLE
1699 to have frame-local bindings at all.
1701 The only way to create a frame-local binding for VARIABLE in a frame
1702 is to set the VARIABLE frame parameter of that frame. See
1703 `modify-frame-parameters' for how to set frame parameters.
1705 Note that since Emacs 23.1, variables cannot be both buffer-local and
1706 frame-local any more (buffer-local bindings used to take precedence over
1707 frame-local bindings). */)
1709 register Lisp_Object variable
;
1711 register Lisp_Object tem
, valcontents
, newval
;
1712 struct Lisp_Symbol
*sym
;
1714 CHECK_SYMBOL (variable
);
1715 sym
= indirect_variable (XSYMBOL (variable
));
1717 valcontents
= sym
->value
;
1718 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1719 || BUFFER_OBJFWDP (valcontents
))
1720 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1722 if (BUFFER_LOCAL_VALUEP (valcontents
))
1724 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1725 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1729 if (EQ (valcontents
, Qunbound
))
1731 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1733 newval
= allocate_misc ();
1734 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1735 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1736 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1737 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1738 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1739 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1740 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1741 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1742 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1743 sym
->value
= newval
;
1747 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1749 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1750 BUFFER defaults to the current buffer. */)
1752 register Lisp_Object variable
, buffer
;
1754 Lisp_Object valcontents
;
1755 register struct buffer
*buf
;
1756 struct Lisp_Symbol
*sym
;
1759 buf
= current_buffer
;
1762 CHECK_BUFFER (buffer
);
1763 buf
= XBUFFER (buffer
);
1766 CHECK_SYMBOL (variable
);
1767 sym
= indirect_variable (XSYMBOL (variable
));
1768 XSETSYMBOL (variable
, sym
);
1770 valcontents
= sym
->value
;
1771 if (BUFFER_LOCAL_VALUEP (valcontents
))
1773 Lisp_Object tail
, elt
;
1775 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1778 if (EQ (variable
, XCAR (elt
)))
1782 if (BUFFER_OBJFWDP (valcontents
))
1784 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1785 int idx
= PER_BUFFER_IDX (offset
);
1786 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1792 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1794 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1795 More precisely, this means that setting the variable \(with `set' or`setq'),
1796 while it does not have a `let'-style binding that was made in BUFFER,
1797 will produce a buffer local binding. See Info node
1798 `(elisp)Creating Buffer-Local'.
1799 BUFFER defaults to the current buffer. */)
1801 register Lisp_Object variable
, buffer
;
1803 Lisp_Object valcontents
;
1804 register struct buffer
*buf
;
1805 struct Lisp_Symbol
*sym
;
1808 buf
= current_buffer
;
1811 CHECK_BUFFER (buffer
);
1812 buf
= XBUFFER (buffer
);
1815 CHECK_SYMBOL (variable
);
1816 sym
= indirect_variable (XSYMBOL (variable
));
1817 XSETSYMBOL (variable
, sym
);
1819 valcontents
= sym
->value
;
1821 if (BUFFER_OBJFWDP (valcontents
))
1822 /* All these slots become local if they are set. */
1824 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1826 Lisp_Object tail
, elt
;
1827 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1829 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1832 if (EQ (variable
, XCAR (elt
)))
1839 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1841 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1842 If the current binding is buffer-local, the value is the current buffer.
1843 If the current binding is frame-local, the value is the selected frame.
1844 If the current binding is global (the default), the value is nil. */)
1846 register Lisp_Object variable
;
1848 Lisp_Object valcontents
;
1849 struct Lisp_Symbol
*sym
;
1851 CHECK_SYMBOL (variable
);
1852 sym
= indirect_variable (XSYMBOL (variable
));
1854 /* Make sure the current binding is actually swapped in. */
1855 find_symbol_value (variable
);
1857 valcontents
= sym
->value
;
1859 if (BUFFER_LOCAL_VALUEP (valcontents
)
1860 || BUFFER_OBJFWDP (valcontents
))
1862 /* For a local variable, record both the symbol and which
1863 buffer's or frame's value we are saving. */
1864 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1865 return Fcurrent_buffer ();
1866 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1867 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1868 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1874 /* This code is disabled now that we use the selected frame to return
1875 keyboard-local-values. */
1877 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1879 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1880 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1881 If SYMBOL is not a terminal-local variable, then return its normal
1882 value, like `symbol-value'.
1884 TERMINAL may be a terminal object, a frame, or nil (meaning the
1885 selected frame's terminal device). */)
1888 Lisp_Object terminal
;
1891 struct terminal
*t
= get_terminal (terminal
, 1);
1892 push_kboard (t
->kboard
);
1893 result
= Fsymbol_value (symbol
);
1898 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1899 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1900 If VARIABLE is not a terminal-local variable, then set its normal
1901 binding, like `set'.
1903 TERMINAL may be a terminal object, a frame, or nil (meaning the
1904 selected frame's terminal device). */)
1905 (symbol
, terminal
, value
)
1907 Lisp_Object terminal
;
1911 struct terminal
*t
= get_terminal (terminal
, 1);
1912 push_kboard (d
->kboard
);
1913 result
= Fset (symbol
, value
);
1919 /* Find the function at the end of a chain of symbol function indirections. */
1921 /* If OBJECT is a symbol, find the end of its function chain and
1922 return the value found there. If OBJECT is not a symbol, just
1923 return it. If there is a cycle in the function chain, signal a
1924 cyclic-function-indirection error.
1926 This is like Findirect_function, except that it doesn't signal an
1927 error if the chain ends up unbound. */
1929 indirect_function (object
)
1930 register Lisp_Object object
;
1932 Lisp_Object tortoise
, hare
;
1934 hare
= tortoise
= object
;
1938 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1940 hare
= XSYMBOL (hare
)->function
;
1941 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1943 hare
= XSYMBOL (hare
)->function
;
1945 tortoise
= XSYMBOL (tortoise
)->function
;
1947 if (EQ (hare
, tortoise
))
1948 xsignal1 (Qcyclic_function_indirection
, object
);
1954 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1955 doc
: /* Return the function at the end of OBJECT's function chain.
1956 If OBJECT is not a symbol, just return it. Otherwise, follow all
1957 function indirections to find the final function binding and return it.
1958 If the final symbol in the chain is unbound, signal a void-function error.
1959 Optional arg NOERROR non-nil means to return nil instead of signalling.
1960 Signal a cyclic-function-indirection error if there is a loop in the
1961 function chain of symbols. */)
1963 register Lisp_Object object
;
1964 Lisp_Object noerror
;
1968 /* Optimize for no indirection. */
1970 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1971 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1972 result
= indirect_function (result
);
1973 if (!EQ (result
, Qunbound
))
1977 xsignal1 (Qvoid_function
, object
);
1982 /* Extract and set vector and string elements */
1984 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1985 doc
: /* Return the element of ARRAY at index IDX.
1986 ARRAY may be a vector, a string, a char-table, a bool-vector,
1987 or a byte-code object. IDX starts at 0. */)
1989 register Lisp_Object array
;
1992 register int idxval
;
1995 idxval
= XINT (idx
);
1996 if (STRINGP (array
))
2000 if (idxval
< 0 || idxval
>= SCHARS (array
))
2001 args_out_of_range (array
, idx
);
2002 if (! STRING_MULTIBYTE (array
))
2003 return make_number ((unsigned char) SREF (array
, idxval
));
2004 idxval_byte
= string_char_to_byte (array
, idxval
);
2006 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2007 SBYTES (array
) - idxval_byte
);
2008 return make_number (c
);
2010 else if (BOOL_VECTOR_P (array
))
2014 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2015 args_out_of_range (array
, idx
);
2017 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2018 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2020 else if (CHAR_TABLE_P (array
))
2022 CHECK_CHARACTER (idx
);
2023 return CHAR_TABLE_REF (array
, idxval
);
2028 if (VECTORP (array
))
2029 size
= XVECTOR (array
)->size
;
2030 else if (COMPILEDP (array
))
2031 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2033 wrong_type_argument (Qarrayp
, array
);
2035 if (idxval
< 0 || idxval
>= size
)
2036 args_out_of_range (array
, idx
);
2037 return XVECTOR (array
)->contents
[idxval
];
2041 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2042 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2043 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2044 bool-vector. IDX starts at 0. */)
2045 (array
, idx
, newelt
)
2046 register Lisp_Object array
;
2047 Lisp_Object idx
, newelt
;
2049 register int idxval
;
2052 idxval
= XINT (idx
);
2053 CHECK_ARRAY (array
, Qarrayp
);
2054 CHECK_IMPURE (array
);
2056 if (VECTORP (array
))
2058 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2059 args_out_of_range (array
, idx
);
2060 XVECTOR (array
)->contents
[idxval
] = newelt
;
2062 else if (BOOL_VECTOR_P (array
))
2066 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2067 args_out_of_range (array
, idx
);
2069 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2071 if (! NILP (newelt
))
2072 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2074 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2075 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2077 else if (CHAR_TABLE_P (array
))
2079 CHECK_CHARACTER (idx
);
2080 CHAR_TABLE_SET (array
, idxval
, newelt
);
2082 else if (STRING_MULTIBYTE (array
))
2084 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2085 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2087 if (idxval
< 0 || idxval
>= SCHARS (array
))
2088 args_out_of_range (array
, idx
);
2089 CHECK_CHARACTER (newelt
);
2091 nbytes
= SBYTES (array
);
2093 idxval_byte
= string_char_to_byte (array
, idxval
);
2094 p1
= SDATA (array
) + idxval_byte
;
2095 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2096 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2097 if (prev_bytes
!= new_bytes
)
2099 /* We must relocate the string data. */
2100 int nchars
= SCHARS (array
);
2104 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2105 bcopy (SDATA (array
), str
, nbytes
);
2106 allocate_string_data (XSTRING (array
), nchars
,
2107 nbytes
+ new_bytes
- prev_bytes
);
2108 bcopy (str
, SDATA (array
), idxval_byte
);
2109 p1
= SDATA (array
) + idxval_byte
;
2110 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2111 nbytes
- (idxval_byte
+ prev_bytes
));
2113 clear_string_char_byte_cache ();
2120 if (idxval
< 0 || idxval
>= SCHARS (array
))
2121 args_out_of_range (array
, idx
);
2122 CHECK_NUMBER (newelt
);
2124 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2128 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2129 if (SREF (array
, i
) >= 0x80)
2130 args_out_of_range (array
, newelt
);
2131 /* ARRAY is an ASCII string. Convert it to a multibyte
2132 string, and try `aset' again. */
2133 STRING_SET_MULTIBYTE (array
);
2134 return Faset (array
, idx
, newelt
);
2136 SSET (array
, idxval
, XINT (newelt
));
2142 /* Arithmetic functions */
2144 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2147 arithcompare (num1
, num2
, comparison
)
2148 Lisp_Object num1
, num2
;
2149 enum comparison comparison
;
2151 double f1
= 0, f2
= 0;
2154 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2155 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2157 if (FLOATP (num1
) || FLOATP (num2
))
2160 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2161 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2167 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2172 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2177 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2182 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2187 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2192 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2201 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2202 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2204 register Lisp_Object num1
, num2
;
2206 return arithcompare (num1
, num2
, equal
);
2209 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2210 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2212 register Lisp_Object num1
, num2
;
2214 return arithcompare (num1
, num2
, less
);
2217 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2218 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2220 register Lisp_Object num1
, num2
;
2222 return arithcompare (num1
, num2
, grtr
);
2225 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2226 doc
: /* Return t if first arg is less than or equal to second arg.
2227 Both must be numbers or markers. */)
2229 register Lisp_Object num1
, num2
;
2231 return arithcompare (num1
, num2
, less_or_equal
);
2234 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2235 doc
: /* Return t if first arg is greater than or equal to second arg.
2236 Both must be numbers or markers. */)
2238 register Lisp_Object num1
, num2
;
2240 return arithcompare (num1
, num2
, grtr_or_equal
);
2243 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2244 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2246 register Lisp_Object num1
, num2
;
2248 return arithcompare (num1
, num2
, notequal
);
2251 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2252 doc
: /* Return t if NUMBER is zero. */)
2254 register Lisp_Object number
;
2256 CHECK_NUMBER_OR_FLOAT (number
);
2258 if (FLOATP (number
))
2260 if (XFLOAT_DATA (number
) == 0.0)
2270 /* Convert between long values and pairs of Lisp integers.
2271 Note that long_to_cons returns a single Lisp integer
2272 when the value fits in one. */
2278 unsigned long top
= i
>> 16;
2279 unsigned int bot
= i
& 0xFFFF;
2281 return make_number (bot
);
2282 if (top
== (unsigned long)-1 >> 16)
2283 return Fcons (make_number (-1), make_number (bot
));
2284 return Fcons (make_number (top
), make_number (bot
));
2291 Lisp_Object top
, bot
;
2298 return ((XINT (top
) << 16) | XINT (bot
));
2301 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2302 doc
: /* Return the decimal representation of NUMBER as a string.
2303 Uses a minus sign if negative.
2304 NUMBER may be an integer or a floating point number. */)
2308 char buffer
[VALBITS
];
2310 CHECK_NUMBER_OR_FLOAT (number
);
2312 if (FLOATP (number
))
2314 char pigbuf
[350]; /* see comments in float_to_string */
2316 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2317 return build_string (pigbuf
);
2320 if (sizeof (int) == sizeof (EMACS_INT
))
2321 sprintf (buffer
, "%d", (int) XINT (number
));
2322 else if (sizeof (long) == sizeof (EMACS_INT
))
2323 sprintf (buffer
, "%ld", (long) XINT (number
));
2326 return build_string (buffer
);
2330 digit_to_number (character
, base
)
2331 int character
, base
;
2335 if (character
>= '0' && character
<= '9')
2336 digit
= character
- '0';
2337 else if (character
>= 'a' && character
<= 'z')
2338 digit
= character
- 'a' + 10;
2339 else if (character
>= 'A' && character
<= 'Z')
2340 digit
= character
- 'A' + 10;
2350 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2351 doc
: /* Parse STRING as a decimal number and return the number.
2352 This parses both integers and floating point numbers.
2353 It ignores leading spaces and tabs.
2355 If BASE, interpret STRING as a number in that base. If BASE isn't
2356 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2357 If the base used is not 10, floating point is not recognized. */)
2359 register Lisp_Object string
, base
;
2361 register unsigned char *p
;
2366 CHECK_STRING (string
);
2372 CHECK_NUMBER (base
);
2374 if (b
< 2 || b
> 16)
2375 xsignal1 (Qargs_out_of_range
, base
);
2378 /* Skip any whitespace at the front of the number. Some versions of
2379 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2381 while (*p
== ' ' || *p
== '\t')
2392 if (isfloat_string (p
) && b
== 10)
2393 val
= make_float (sign
* atof (p
));
2400 int digit
= digit_to_number (*p
++, b
);
2406 val
= make_fixnum_or_float (sign
* v
);
2426 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2427 int, Lisp_Object
*));
2428 extern Lisp_Object
fmod_float ();
2431 arith_driver (code
, nargs
, args
)
2434 register Lisp_Object
*args
;
2436 register Lisp_Object val
;
2437 register int argnum
;
2438 register EMACS_INT accum
= 0;
2439 register EMACS_INT next
;
2441 switch (SWITCH_ENUM_CAST (code
))
2459 for (argnum
= 0; argnum
< nargs
; argnum
++)
2461 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2463 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2466 return float_arith_driver ((double) accum
, argnum
, code
,
2469 next
= XINT (args
[argnum
]);
2470 switch (SWITCH_ENUM_CAST (code
))
2476 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2487 xsignal0 (Qarith_error
);
2501 if (!argnum
|| next
> accum
)
2505 if (!argnum
|| next
< accum
)
2511 XSETINT (val
, accum
);
2516 #define isnan(x) ((x) != (x))
2519 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2521 register int argnum
;
2524 register Lisp_Object
*args
;
2526 register Lisp_Object val
;
2529 for (; argnum
< nargs
; argnum
++)
2531 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2532 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2536 next
= XFLOAT_DATA (val
);
2540 args
[argnum
] = val
; /* runs into a compiler bug. */
2541 next
= XINT (args
[argnum
]);
2543 switch (SWITCH_ENUM_CAST (code
))
2549 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2559 if (! IEEE_FLOATING_POINT
&& next
== 0)
2560 xsignal0 (Qarith_error
);
2567 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2569 if (!argnum
|| isnan (next
) || next
> accum
)
2573 if (!argnum
|| isnan (next
) || next
< accum
)
2579 return make_float (accum
);
2583 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2584 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2585 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2590 return arith_driver (Aadd
, nargs
, args
);
2593 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2594 doc
: /* Negate number or subtract numbers or markers and return the result.
2595 With one arg, negates it. With more than one arg,
2596 subtracts all but the first from the first.
2597 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2602 return arith_driver (Asub
, nargs
, args
);
2605 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2606 doc
: /* Return product of any number of arguments, which are numbers or markers.
2607 usage: (* &rest NUMBERS-OR-MARKERS) */)
2612 return arith_driver (Amult
, nargs
, args
);
2615 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2616 doc
: /* Return first argument divided by all the remaining arguments.
2617 The arguments must be numbers or markers.
2618 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2624 for (argnum
= 2; argnum
< nargs
; argnum
++)
2625 if (FLOATP (args
[argnum
]))
2626 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2627 return arith_driver (Adiv
, nargs
, args
);
2630 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2631 doc
: /* Return remainder of X divided by Y.
2632 Both must be integers or markers. */)
2634 register Lisp_Object x
, y
;
2638 CHECK_NUMBER_COERCE_MARKER (x
);
2639 CHECK_NUMBER_COERCE_MARKER (y
);
2641 if (XFASTINT (y
) == 0)
2642 xsignal0 (Qarith_error
);
2644 XSETINT (val
, XINT (x
) % XINT (y
));
2658 /* If the magnitude of the result exceeds that of the divisor, or
2659 the sign of the result does not agree with that of the dividend,
2660 iterate with the reduced value. This does not yield a
2661 particularly accurate result, but at least it will be in the
2662 range promised by fmod. */
2664 r
-= f2
* floor (r
/ f2
);
2665 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2669 #endif /* ! HAVE_FMOD */
2671 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2672 doc
: /* Return X modulo Y.
2673 The result falls between zero (inclusive) and Y (exclusive).
2674 Both X and Y must be numbers or markers. */)
2676 register Lisp_Object x
, y
;
2681 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2682 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2684 if (FLOATP (x
) || FLOATP (y
))
2685 return fmod_float (x
, y
);
2691 xsignal0 (Qarith_error
);
2695 /* If the "remainder" comes out with the wrong sign, fix it. */
2696 if (i2
< 0 ? i1
> 0 : i1
< 0)
2703 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2704 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2705 The value is always a number; markers are converted to numbers.
2706 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2711 return arith_driver (Amax
, nargs
, args
);
2714 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2715 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2716 The value is always a number; markers are converted to numbers.
2717 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2722 return arith_driver (Amin
, nargs
, args
);
2725 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2726 doc
: /* Return bitwise-and of all the arguments.
2727 Arguments may be integers, or markers converted to integers.
2728 usage: (logand &rest INTS-OR-MARKERS) */)
2733 return arith_driver (Alogand
, nargs
, args
);
2736 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2737 doc
: /* Return bitwise-or of all the arguments.
2738 Arguments may be integers, or markers converted to integers.
2739 usage: (logior &rest INTS-OR-MARKERS) */)
2744 return arith_driver (Alogior
, nargs
, args
);
2747 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2748 doc
: /* Return bitwise-exclusive-or of all the arguments.
2749 Arguments may be integers, or markers converted to integers.
2750 usage: (logxor &rest INTS-OR-MARKERS) */)
2755 return arith_driver (Alogxor
, nargs
, args
);
2758 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2759 doc
: /* Return VALUE with its bits shifted left by COUNT.
2760 If COUNT is negative, shifting is actually to the right.
2761 In this case, the sign bit is duplicated. */)
2763 register Lisp_Object value
, count
;
2765 register Lisp_Object val
;
2767 CHECK_NUMBER (value
);
2768 CHECK_NUMBER (count
);
2770 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2772 else if (XINT (count
) > 0)
2773 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2774 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2775 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2777 XSETINT (val
, XINT (value
) >> -XINT (count
));
2781 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2782 doc
: /* Return VALUE with its bits shifted left by COUNT.
2783 If COUNT is negative, shifting is actually to the right.
2784 In this case, zeros are shifted in on the left. */)
2786 register Lisp_Object value
, count
;
2788 register Lisp_Object val
;
2790 CHECK_NUMBER (value
);
2791 CHECK_NUMBER (count
);
2793 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2795 else if (XINT (count
) > 0)
2796 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2797 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2800 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2804 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2805 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2806 Markers are converted to integers. */)
2808 register Lisp_Object number
;
2810 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2812 if (FLOATP (number
))
2813 return (make_float (1.0 + XFLOAT_DATA (number
)));
2815 XSETINT (number
, XINT (number
) + 1);
2819 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2820 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2821 Markers are converted to integers. */)
2823 register Lisp_Object number
;
2825 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2827 if (FLOATP (number
))
2828 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2830 XSETINT (number
, XINT (number
) - 1);
2834 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2835 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2837 register Lisp_Object number
;
2839 CHECK_NUMBER (number
);
2840 XSETINT (number
, ~XINT (number
));
2844 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2845 doc
: /* Return the byteorder for the machine.
2846 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2847 lowercase l) for small endian machines. */)
2850 unsigned i
= 0x04030201;
2851 int order
= *(char *)&i
== 1 ? 108 : 66;
2853 return make_number (order
);
2861 Lisp_Object error_tail
, arith_tail
;
2863 Qquote
= intern ("quote");
2864 Qlambda
= intern ("lambda");
2865 Qsubr
= intern ("subr");
2866 Qerror_conditions
= intern ("error-conditions");
2867 Qerror_message
= intern ("error-message");
2868 Qtop_level
= intern ("top-level");
2870 Qerror
= intern ("error");
2871 Qquit
= intern ("quit");
2872 Qwrong_type_argument
= intern ("wrong-type-argument");
2873 Qargs_out_of_range
= intern ("args-out-of-range");
2874 Qvoid_function
= intern ("void-function");
2875 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2876 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2877 Qvoid_variable
= intern ("void-variable");
2878 Qsetting_constant
= intern ("setting-constant");
2879 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2881 Qinvalid_function
= intern ("invalid-function");
2882 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2883 Qno_catch
= intern ("no-catch");
2884 Qend_of_file
= intern ("end-of-file");
2885 Qarith_error
= intern ("arith-error");
2886 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2887 Qend_of_buffer
= intern ("end-of-buffer");
2888 Qbuffer_read_only
= intern ("buffer-read-only");
2889 Qtext_read_only
= intern ("text-read-only");
2890 Qmark_inactive
= intern ("mark-inactive");
2892 Qlistp
= intern ("listp");
2893 Qconsp
= intern ("consp");
2894 Qsymbolp
= intern ("symbolp");
2895 Qkeywordp
= intern ("keywordp");
2896 Qintegerp
= intern ("integerp");
2897 Qnatnump
= intern ("natnump");
2898 Qwholenump
= intern ("wholenump");
2899 Qstringp
= intern ("stringp");
2900 Qarrayp
= intern ("arrayp");
2901 Qsequencep
= intern ("sequencep");
2902 Qbufferp
= intern ("bufferp");
2903 Qvectorp
= intern ("vectorp");
2904 Qchar_or_string_p
= intern ("char-or-string-p");
2905 Qmarkerp
= intern ("markerp");
2906 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2907 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2908 Qboundp
= intern ("boundp");
2909 Qfboundp
= intern ("fboundp");
2911 Qfloatp
= intern ("floatp");
2912 Qnumberp
= intern ("numberp");
2913 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2915 Qchar_table_p
= intern ("char-table-p");
2916 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2918 Qsubrp
= intern ("subrp");
2919 Qunevalled
= intern ("unevalled");
2920 Qmany
= intern ("many");
2922 Qcdr
= intern ("cdr");
2924 /* Handle automatic advice activation */
2925 Qad_advice_info
= intern ("ad-advice-info");
2926 Qad_activate_internal
= intern ("ad-activate-internal");
2928 error_tail
= Fcons (Qerror
, Qnil
);
2930 /* ERROR is used as a signaler for random errors for which nothing else is right */
2932 Fput (Qerror
, Qerror_conditions
,
2934 Fput (Qerror
, Qerror_message
,
2935 build_string ("error"));
2937 Fput (Qquit
, Qerror_conditions
,
2938 Fcons (Qquit
, Qnil
));
2939 Fput (Qquit
, Qerror_message
,
2940 build_string ("Quit"));
2942 Fput (Qwrong_type_argument
, Qerror_conditions
,
2943 Fcons (Qwrong_type_argument
, error_tail
));
2944 Fput (Qwrong_type_argument
, Qerror_message
,
2945 build_string ("Wrong type argument"));
2947 Fput (Qargs_out_of_range
, Qerror_conditions
,
2948 Fcons (Qargs_out_of_range
, error_tail
));
2949 Fput (Qargs_out_of_range
, Qerror_message
,
2950 build_string ("Args out of range"));
2952 Fput (Qvoid_function
, Qerror_conditions
,
2953 Fcons (Qvoid_function
, error_tail
));
2954 Fput (Qvoid_function
, Qerror_message
,
2955 build_string ("Symbol's function definition is void"));
2957 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2958 Fcons (Qcyclic_function_indirection
, error_tail
));
2959 Fput (Qcyclic_function_indirection
, Qerror_message
,
2960 build_string ("Symbol's chain of function indirections contains a loop"));
2962 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2963 Fcons (Qcyclic_variable_indirection
, error_tail
));
2964 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2965 build_string ("Symbol's chain of variable indirections contains a loop"));
2967 Qcircular_list
= intern ("circular-list");
2968 staticpro (&Qcircular_list
);
2969 Fput (Qcircular_list
, Qerror_conditions
,
2970 Fcons (Qcircular_list
, error_tail
));
2971 Fput (Qcircular_list
, Qerror_message
,
2972 build_string ("List contains a loop"));
2974 Fput (Qvoid_variable
, Qerror_conditions
,
2975 Fcons (Qvoid_variable
, error_tail
));
2976 Fput (Qvoid_variable
, Qerror_message
,
2977 build_string ("Symbol's value as variable is void"));
2979 Fput (Qsetting_constant
, Qerror_conditions
,
2980 Fcons (Qsetting_constant
, error_tail
));
2981 Fput (Qsetting_constant
, Qerror_message
,
2982 build_string ("Attempt to set a constant symbol"));
2984 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2985 Fcons (Qinvalid_read_syntax
, error_tail
));
2986 Fput (Qinvalid_read_syntax
, Qerror_message
,
2987 build_string ("Invalid read syntax"));
2989 Fput (Qinvalid_function
, Qerror_conditions
,
2990 Fcons (Qinvalid_function
, error_tail
));
2991 Fput (Qinvalid_function
, Qerror_message
,
2992 build_string ("Invalid function"));
2994 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2995 Fcons (Qwrong_number_of_arguments
, error_tail
));
2996 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2997 build_string ("Wrong number of arguments"));
2999 Fput (Qno_catch
, Qerror_conditions
,
3000 Fcons (Qno_catch
, error_tail
));
3001 Fput (Qno_catch
, Qerror_message
,
3002 build_string ("No catch for tag"));
3004 Fput (Qend_of_file
, Qerror_conditions
,
3005 Fcons (Qend_of_file
, error_tail
));
3006 Fput (Qend_of_file
, Qerror_message
,
3007 build_string ("End of file during parsing"));
3009 arith_tail
= Fcons (Qarith_error
, error_tail
);
3010 Fput (Qarith_error
, Qerror_conditions
,
3012 Fput (Qarith_error
, Qerror_message
,
3013 build_string ("Arithmetic error"));
3015 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3016 Fcons (Qbeginning_of_buffer
, error_tail
));
3017 Fput (Qbeginning_of_buffer
, Qerror_message
,
3018 build_string ("Beginning of buffer"));
3020 Fput (Qend_of_buffer
, Qerror_conditions
,
3021 Fcons (Qend_of_buffer
, error_tail
));
3022 Fput (Qend_of_buffer
, Qerror_message
,
3023 build_string ("End of buffer"));
3025 Fput (Qbuffer_read_only
, Qerror_conditions
,
3026 Fcons (Qbuffer_read_only
, error_tail
));
3027 Fput (Qbuffer_read_only
, Qerror_message
,
3028 build_string ("Buffer is read-only"));
3030 Fput (Qtext_read_only
, Qerror_conditions
,
3031 Fcons (Qtext_read_only
, error_tail
));
3032 Fput (Qtext_read_only
, Qerror_message
,
3033 build_string ("Text is read-only"));
3035 Qrange_error
= intern ("range-error");
3036 Qdomain_error
= intern ("domain-error");
3037 Qsingularity_error
= intern ("singularity-error");
3038 Qoverflow_error
= intern ("overflow-error");
3039 Qunderflow_error
= intern ("underflow-error");
3041 Fput (Qdomain_error
, Qerror_conditions
,
3042 Fcons (Qdomain_error
, arith_tail
));
3043 Fput (Qdomain_error
, Qerror_message
,
3044 build_string ("Arithmetic domain error"));
3046 Fput (Qrange_error
, Qerror_conditions
,
3047 Fcons (Qrange_error
, arith_tail
));
3048 Fput (Qrange_error
, Qerror_message
,
3049 build_string ("Arithmetic range error"));
3051 Fput (Qsingularity_error
, Qerror_conditions
,
3052 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3053 Fput (Qsingularity_error
, Qerror_message
,
3054 build_string ("Arithmetic singularity error"));
3056 Fput (Qoverflow_error
, Qerror_conditions
,
3057 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3058 Fput (Qoverflow_error
, Qerror_message
,
3059 build_string ("Arithmetic overflow error"));
3061 Fput (Qunderflow_error
, Qerror_conditions
,
3062 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3063 Fput (Qunderflow_error
, Qerror_message
,
3064 build_string ("Arithmetic underflow error"));
3066 staticpro (&Qrange_error
);
3067 staticpro (&Qdomain_error
);
3068 staticpro (&Qsingularity_error
);
3069 staticpro (&Qoverflow_error
);
3070 staticpro (&Qunderflow_error
);
3074 staticpro (&Qquote
);
3075 staticpro (&Qlambda
);
3077 staticpro (&Qunbound
);
3078 staticpro (&Qerror_conditions
);
3079 staticpro (&Qerror_message
);
3080 staticpro (&Qtop_level
);
3082 staticpro (&Qerror
);
3084 staticpro (&Qwrong_type_argument
);
3085 staticpro (&Qargs_out_of_range
);
3086 staticpro (&Qvoid_function
);
3087 staticpro (&Qcyclic_function_indirection
);
3088 staticpro (&Qcyclic_variable_indirection
);
3089 staticpro (&Qvoid_variable
);
3090 staticpro (&Qsetting_constant
);
3091 staticpro (&Qinvalid_read_syntax
);
3092 staticpro (&Qwrong_number_of_arguments
);
3093 staticpro (&Qinvalid_function
);
3094 staticpro (&Qno_catch
);
3095 staticpro (&Qend_of_file
);
3096 staticpro (&Qarith_error
);
3097 staticpro (&Qbeginning_of_buffer
);
3098 staticpro (&Qend_of_buffer
);
3099 staticpro (&Qbuffer_read_only
);
3100 staticpro (&Qtext_read_only
);
3101 staticpro (&Qmark_inactive
);
3103 staticpro (&Qlistp
);
3104 staticpro (&Qconsp
);
3105 staticpro (&Qsymbolp
);
3106 staticpro (&Qkeywordp
);
3107 staticpro (&Qintegerp
);
3108 staticpro (&Qnatnump
);
3109 staticpro (&Qwholenump
);
3110 staticpro (&Qstringp
);
3111 staticpro (&Qarrayp
);
3112 staticpro (&Qsequencep
);
3113 staticpro (&Qbufferp
);
3114 staticpro (&Qvectorp
);
3115 staticpro (&Qchar_or_string_p
);
3116 staticpro (&Qmarkerp
);
3117 staticpro (&Qbuffer_or_string_p
);
3118 staticpro (&Qinteger_or_marker_p
);
3119 staticpro (&Qfloatp
);
3120 staticpro (&Qnumberp
);
3121 staticpro (&Qnumber_or_marker_p
);
3122 staticpro (&Qchar_table_p
);
3123 staticpro (&Qvector_or_char_table_p
);
3124 staticpro (&Qsubrp
);
3126 staticpro (&Qunevalled
);
3128 staticpro (&Qboundp
);
3129 staticpro (&Qfboundp
);
3131 staticpro (&Qad_advice_info
);
3132 staticpro (&Qad_activate_internal
);
3134 /* Types that type-of returns. */
3135 Qinteger
= intern ("integer");
3136 Qsymbol
= intern ("symbol");
3137 Qstring
= intern ("string");
3138 Qcons
= intern ("cons");
3139 Qmarker
= intern ("marker");
3140 Qoverlay
= intern ("overlay");
3141 Qfloat
= intern ("float");
3142 Qwindow_configuration
= intern ("window-configuration");
3143 Qprocess
= intern ("process");
3144 Qwindow
= intern ("window");
3145 /* Qsubr = intern ("subr"); */
3146 Qcompiled_function
= intern ("compiled-function");
3147 Qbuffer
= intern ("buffer");
3148 Qframe
= intern ("frame");
3149 Qvector
= intern ("vector");
3150 Qchar_table
= intern ("char-table");
3151 Qbool_vector
= intern ("bool-vector");
3152 Qhash_table
= intern ("hash-table");
3154 DEFSYM (Qfont_spec
, "font-spec");
3155 DEFSYM (Qfont_entity
, "font-entity");
3156 DEFSYM (Qfont_object
, "font-object");
3158 DEFSYM (Qinteractive_form
, "interactive-form");
3160 staticpro (&Qinteger
);
3161 staticpro (&Qsymbol
);
3162 staticpro (&Qstring
);
3164 staticpro (&Qmarker
);
3165 staticpro (&Qoverlay
);
3166 staticpro (&Qfloat
);
3167 staticpro (&Qwindow_configuration
);
3168 staticpro (&Qprocess
);
3169 staticpro (&Qwindow
);
3170 /* staticpro (&Qsubr); */
3171 staticpro (&Qcompiled_function
);
3172 staticpro (&Qbuffer
);
3173 staticpro (&Qframe
);
3174 staticpro (&Qvector
);
3175 staticpro (&Qchar_table
);
3176 staticpro (&Qbool_vector
);
3177 staticpro (&Qhash_table
);
3179 defsubr (&Sindirect_variable
);
3180 defsubr (&Sinteractive_form
);
3183 defsubr (&Stype_of
);
3188 defsubr (&Sintegerp
);
3189 defsubr (&Sinteger_or_marker_p
);
3190 defsubr (&Snumberp
);
3191 defsubr (&Snumber_or_marker_p
);
3193 defsubr (&Snatnump
);
3194 defsubr (&Ssymbolp
);
3195 defsubr (&Skeywordp
);
3196 defsubr (&Sstringp
);
3197 defsubr (&Smultibyte_string_p
);
3198 defsubr (&Svectorp
);
3199 defsubr (&Schar_table_p
);
3200 defsubr (&Svector_or_char_table_p
);
3201 defsubr (&Sbool_vector_p
);
3203 defsubr (&Ssequencep
);
3204 defsubr (&Sbufferp
);
3205 defsubr (&Smarkerp
);
3207 defsubr (&Sbyte_code_function_p
);
3208 defsubr (&Schar_or_string_p
);
3211 defsubr (&Scar_safe
);
3212 defsubr (&Scdr_safe
);
3215 defsubr (&Ssymbol_function
);
3216 defsubr (&Sindirect_function
);
3217 defsubr (&Ssymbol_plist
);
3218 defsubr (&Ssymbol_name
);
3219 defsubr (&Smakunbound
);
3220 defsubr (&Sfmakunbound
);
3222 defsubr (&Sfboundp
);
3224 defsubr (&Sdefalias
);
3225 defsubr (&Ssetplist
);
3226 defsubr (&Ssymbol_value
);
3228 defsubr (&Sdefault_boundp
);
3229 defsubr (&Sdefault_value
);
3230 defsubr (&Sset_default
);
3231 defsubr (&Ssetq_default
);
3232 defsubr (&Smake_variable_buffer_local
);
3233 defsubr (&Smake_local_variable
);
3234 defsubr (&Skill_local_variable
);
3235 defsubr (&Smake_variable_frame_local
);
3236 defsubr (&Slocal_variable_p
);
3237 defsubr (&Slocal_variable_if_set_p
);
3238 defsubr (&Svariable_binding_locus
);
3239 #if 0 /* XXX Remove this. --lorentey */
3240 defsubr (&Sterminal_local_value
);
3241 defsubr (&Sset_terminal_local_value
);
3245 defsubr (&Snumber_to_string
);
3246 defsubr (&Sstring_to_number
);
3247 defsubr (&Seqlsign
);
3270 defsubr (&Sbyteorder
);
3271 defsubr (&Ssubr_arity
);
3272 defsubr (&Ssubr_name
);
3274 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3276 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3277 doc
: /* The largest value that is representable in a Lisp integer. */);
3278 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3279 XSYMBOL (intern ("most-positive-fixnum"))->constant
= 1;
3281 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3282 doc
: /* The smallest value that is representable in a Lisp integer. */);
3283 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3284 XSYMBOL (intern ("most-negative-fixnum"))->constant
= 1;
3291 #if defined(USG) && !defined(POSIX_SIGNALS)
3292 /* USG systems forget handlers when they are used;
3293 must reestablish each time */
3294 signal (signo
, arith_error
);
3296 sigsetmask (SIGEMPTYMASK
);
3298 SIGNAL_THREAD_CHECK (signo
);
3299 xsignal0 (Qarith_error
);
3305 /* Don't do this if just dumping out.
3306 We don't want to call `signal' in this case
3307 so that we don't have trouble with dumping
3308 signal-delivering routines in an inconsistent state. */
3312 #endif /* CANNOT_DUMP */
3313 signal (SIGFPE
, arith_error
);
3316 signal (SIGEMT
, arith_error
);
3320 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3321 (do not change this comment) */