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 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 2, or (at your option)
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; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
28 #include "character.h"
32 #include "syssignal.h"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
69 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
70 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
71 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
72 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
73 Lisp_Object Qtext_read_only
;
75 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
76 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
77 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
78 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
79 Lisp_Object Qboundp
, Qfboundp
;
80 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
83 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
85 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
86 Lisp_Object Qoverflow_error
, Qunderflow_error
;
89 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
92 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
93 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
95 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
96 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
97 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
99 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
101 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
105 circular_list_error (list
)
108 Fsignal (Qcircular_list
, list
);
113 wrong_type_argument (predicate
, value
)
114 register Lisp_Object predicate
, value
;
116 register Lisp_Object tem
;
119 /* If VALUE is not even a valid Lisp object, abort here
120 where we can get a backtrace showing where it came from. */
121 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
124 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
125 tem
= call1 (predicate
, value
);
134 error ("Attempt to modify read-only object");
138 args_out_of_range (a1
, a2
)
142 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
146 args_out_of_range_3 (a1
, a2
, a3
)
147 Lisp_Object a1
, a2
, a3
;
150 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
153 /* On some machines, XINT needs a temporary location.
154 Here it is, in case it is needed. */
156 int sign_extend_temp
;
158 /* On a few machines, XINT can only be done by calling this. */
161 sign_extend_lisp_int (num
)
164 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
165 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
167 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
170 /* Data type predicates */
172 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
173 doc
: /* Return t if the two args are the same Lisp object. */)
175 Lisp_Object obj1
, obj2
;
182 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
183 doc
: /* Return t if OBJECT is nil. */)
192 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
193 doc
: /* Return a symbol representing the type of OBJECT.
194 The symbol returned names the object's basic type;
195 for example, (type-of 1) returns `integer'. */)
199 switch (XGCTYPE (object
))
214 switch (XMISCTYPE (object
))
216 case Lisp_Misc_Marker
:
218 case Lisp_Misc_Overlay
:
220 case Lisp_Misc_Float
:
225 case Lisp_Vectorlike
:
226 if (GC_WINDOW_CONFIGURATIONP (object
))
227 return Qwindow_configuration
;
228 if (GC_PROCESSP (object
))
230 if (GC_WINDOWP (object
))
232 if (GC_SUBRP (object
))
234 if (GC_COMPILEDP (object
))
235 return Qcompiled_function
;
236 if (GC_BUFFERP (object
))
238 if (GC_CHAR_TABLE_P (object
))
240 if (GC_BOOL_VECTOR_P (object
))
242 if (GC_FRAMEP (object
))
244 if (GC_HASH_TABLE_P (object
))
256 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
257 doc
: /* Return t if OBJECT is a cons cell. */)
266 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
267 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
276 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
277 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
278 Otherwise, return nil. */)
282 if (CONSP (object
) || NILP (object
))
287 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
288 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
292 if (CONSP (object
) || NILP (object
))
297 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
298 doc
: /* Return t if OBJECT is a symbol. */)
302 if (SYMBOLP (object
))
307 /* Define this in C to avoid unnecessarily consing up the symbol
309 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
310 doc
: /* Return t if OBJECT is a keyword.
311 This means that it is a symbol with a print name beginning with `:'
312 interned in the initial obarray. */)
317 && SREF (SYMBOL_NAME (object
), 0) == ':'
318 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
323 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
324 doc
: /* Return t if OBJECT is a vector. */)
328 if (VECTORP (object
))
333 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is a string. */)
338 if (STRINGP (object
))
343 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
345 doc
: /* Return t if OBJECT is a multibyte string. */)
349 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
354 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
355 doc
: /* Return t if OBJECT is a char-table. */)
359 if (CHAR_TABLE_P (object
))
364 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
365 Svector_or_char_table_p
, 1, 1, 0,
366 doc
: /* Return t if OBJECT is a char-table or vector. */)
370 if (VECTORP (object
) || CHAR_TABLE_P (object
))
375 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
376 doc
: /* Return t if OBJECT is a bool-vector. */)
380 if (BOOL_VECTOR_P (object
))
385 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
386 doc
: /* Return t if OBJECT is an array (string or vector). */)
390 if (VECTORP (object
) || STRINGP (object
)
391 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
396 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is a sequence (list or array). */)
399 register Lisp_Object object
;
401 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
402 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
407 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is an editor buffer. */)
412 if (BUFFERP (object
))
417 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
422 if (MARKERP (object
))
427 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
428 doc
: /* Return t if OBJECT is a built-in function. */)
437 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
439 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
443 if (COMPILEDP (object
))
448 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
451 register Lisp_Object object
;
453 if (CHARACTERP (object
) || STRINGP (object
))
458 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer. */)
463 if (INTEGERP (object
))
468 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
471 register Lisp_Object object
;
473 if (MARKERP (object
) || INTEGERP (object
))
478 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
479 doc
: /* Return t if OBJECT is a nonnegative integer. */)
483 if (NATNUMP (object
))
488 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
489 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
493 if (NUMBERP (object
))
499 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
500 Snumber_or_marker_p
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a number or a marker. */)
505 if (NUMBERP (object
) || MARKERP (object
))
510 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
511 doc
: /* Return t if OBJECT is a floating point number. */)
521 /* Extract and set components of lists */
523 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
524 doc
: /* Return the car of LIST. If arg is nil, return nil.
525 Error if arg is not nil and not a cons cell. See also `car-safe'.
527 See Info node `(elisp)Cons Cells' for a discussion of related basic
528 Lisp concepts such as car, cdr, cons cell and list. */)
530 register Lisp_Object list
;
536 else if (EQ (list
, Qnil
))
539 list
= wrong_type_argument (Qlistp
, list
);
543 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
544 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
549 return XCAR (object
);
554 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
555 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
556 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
558 See Info node `(elisp)Cons Cells' for a discussion of related basic
559 Lisp concepts such as cdr, car, cons cell and list. */)
561 register Lisp_Object list
;
567 else if (EQ (list
, Qnil
))
570 list
= wrong_type_argument (Qlistp
, list
);
574 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
575 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
580 return XCDR (object
);
585 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
586 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
588 register Lisp_Object cell
, newcar
;
591 cell
= wrong_type_argument (Qconsp
, cell
);
594 XSETCAR (cell
, newcar
);
598 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
599 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
601 register Lisp_Object cell
, newcdr
;
604 cell
= wrong_type_argument (Qconsp
, cell
);
607 XSETCDR (cell
, newcdr
);
611 /* Extract and set components of symbols */
613 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
614 doc
: /* Return t if SYMBOL's value is not void. */)
616 register Lisp_Object symbol
;
618 Lisp_Object valcontents
;
619 CHECK_SYMBOL (symbol
);
621 valcontents
= SYMBOL_VALUE (symbol
);
623 if (BUFFER_LOCAL_VALUEP (valcontents
)
624 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
625 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
627 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
630 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
631 doc
: /* Return t if SYMBOL's function definition is not void. */)
633 register Lisp_Object symbol
;
635 CHECK_SYMBOL (symbol
);
636 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
639 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
640 doc
: /* Make SYMBOL's value be void.
643 register Lisp_Object symbol
;
645 CHECK_SYMBOL (symbol
);
646 if (XSYMBOL (symbol
)->constant
)
647 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
648 Fset (symbol
, Qunbound
);
652 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
653 doc
: /* Make SYMBOL's function definition be void.
656 register Lisp_Object symbol
;
658 CHECK_SYMBOL (symbol
);
659 if (NILP (symbol
) || EQ (symbol
, Qt
))
660 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
661 XSYMBOL (symbol
)->function
= Qunbound
;
665 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
666 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
668 register Lisp_Object symbol
;
670 CHECK_SYMBOL (symbol
);
671 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
672 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
673 return XSYMBOL (symbol
)->function
;
676 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
677 doc
: /* Return SYMBOL's property list. */)
679 register Lisp_Object symbol
;
681 CHECK_SYMBOL (symbol
);
682 return XSYMBOL (symbol
)->plist
;
685 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
686 doc
: /* Return SYMBOL's name, a string. */)
688 register Lisp_Object symbol
;
690 register Lisp_Object name
;
692 CHECK_SYMBOL (symbol
);
693 name
= SYMBOL_NAME (symbol
);
697 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
698 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
700 register Lisp_Object symbol
, definition
;
702 CHECK_SYMBOL (symbol
);
703 if (NILP (symbol
) || EQ (symbol
, Qt
))
704 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
705 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
706 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
708 XSYMBOL (symbol
)->function
= definition
;
709 /* Handle automatic advice activation */
710 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
712 call2 (Qad_activate_internal
, symbol
, Qnil
);
713 definition
= XSYMBOL (symbol
)->function
;
718 extern Lisp_Object Qfunction_documentation
;
720 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
721 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
722 Associates the function with the current load file, if any.
723 The optional third argument DOCSTRING specifies the documentation string
724 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
725 determined by DEFINITION. */)
726 (symbol
, definition
, docstring
)
727 register Lisp_Object symbol
, definition
, docstring
;
729 CHECK_SYMBOL (symbol
);
730 if (CONSP (XSYMBOL (symbol
)->function
)
731 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
732 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
733 definition
= Ffset (symbol
, definition
);
734 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
735 if (!NILP (docstring
))
736 Fput (symbol
, Qfunction_documentation
, docstring
);
740 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
741 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
743 register Lisp_Object symbol
, newplist
;
745 CHECK_SYMBOL (symbol
);
746 XSYMBOL (symbol
)->plist
= newplist
;
750 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
751 doc
: /* Return minimum and maximum number of args allowed for SUBR.
752 SUBR must be a built-in function.
753 The returned value is a pair (MIN . MAX). MIN is the minimum number
754 of args. MAX is the maximum number or the symbol `many', for a
755 function with `&rest' args, or `unevalled' for a special form. */)
759 short minargs
, maxargs
;
761 wrong_type_argument (Qsubrp
, subr
);
762 minargs
= XSUBR (subr
)->min_args
;
763 maxargs
= XSUBR (subr
)->max_args
;
765 return Fcons (make_number (minargs
), Qmany
);
766 else if (maxargs
== UNEVALLED
)
767 return Fcons (make_number (minargs
), Qunevalled
);
769 return Fcons (make_number (minargs
), make_number (maxargs
));
772 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
773 doc
: /* Return name of subroutine SUBR.
774 SUBR must be a built-in function. */)
780 wrong_type_argument (Qsubrp
, subr
);
781 name
= XSUBR (subr
)->symbol_name
;
782 return make_string (name
, strlen (name
));
785 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
786 doc
: /* Return the interactive form of CMD or nil if none.
787 If CMD is not a command, the return value is nil.
788 Value, if non-nil, is a list \(interactive SPEC). */)
792 Lisp_Object fun
= indirect_function (cmd
);
796 if (XSUBR (fun
)->prompt
)
797 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
799 else if (COMPILEDP (fun
))
801 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
802 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
804 else if (CONSP (fun
))
806 Lisp_Object funcar
= XCAR (fun
);
807 if (EQ (funcar
, Qlambda
))
808 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
809 else if (EQ (funcar
, Qautoload
))
813 do_autoload (fun
, cmd
);
815 return Finteractive_form (cmd
);
822 /***********************************************************************
823 Getting and Setting Values of Symbols
824 ***********************************************************************/
826 /* Return the symbol holding SYMBOL's value. Signal
827 `cyclic-variable-indirection' if SYMBOL's chain of variable
828 indirections contains a loop. */
831 indirect_variable (symbol
)
834 Lisp_Object tortoise
, hare
;
836 hare
= tortoise
= symbol
;
838 while (XSYMBOL (hare
)->indirect_variable
)
840 hare
= XSYMBOL (hare
)->value
;
841 if (!XSYMBOL (hare
)->indirect_variable
)
844 hare
= XSYMBOL (hare
)->value
;
845 tortoise
= XSYMBOL (tortoise
)->value
;
847 if (EQ (hare
, tortoise
))
848 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
855 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
856 doc
: /* Return the variable at the end of OBJECT's variable chain.
857 If OBJECT is a symbol, follow all variable indirections and return the final
858 variable. If OBJECT is not a symbol, just return it.
859 Signal a cyclic-variable-indirection error if there is a loop in the
860 variable chain of symbols. */)
864 if (SYMBOLP (object
))
865 object
= indirect_variable (object
);
870 /* Given the raw contents of a symbol value cell,
871 return the Lisp value of the symbol.
872 This does not handle buffer-local variables; use
873 swap_in_symval_forwarding for that. */
876 do_symval_forwarding (valcontents
)
877 register Lisp_Object valcontents
;
879 register Lisp_Object val
;
881 if (MISCP (valcontents
))
882 switch (XMISCTYPE (valcontents
))
884 case Lisp_Misc_Intfwd
:
885 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
888 case Lisp_Misc_Boolfwd
:
889 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
891 case Lisp_Misc_Objfwd
:
892 return *XOBJFWD (valcontents
)->objvar
;
894 case Lisp_Misc_Buffer_Objfwd
:
895 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
896 return PER_BUFFER_VALUE (current_buffer
, offset
);
898 case Lisp_Misc_Kboard_Objfwd
:
899 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
900 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
905 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
906 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
907 buffer-independent contents of the value cell: forwarded just one
908 step past the buffer-localness.
910 BUF non-zero means set the value in buffer BUF instead of the
911 current buffer. This only plays a role for per-buffer variables. */
914 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
916 register Lisp_Object valcontents
, newval
;
919 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
922 switch (XMISCTYPE (valcontents
))
924 case Lisp_Misc_Intfwd
:
925 CHECK_NUMBER (newval
);
926 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
927 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
928 error ("Value out of range for variable `%s'",
929 SDATA (SYMBOL_NAME (symbol
)));
932 case Lisp_Misc_Boolfwd
:
933 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
936 case Lisp_Misc_Objfwd
:
937 *XOBJFWD (valcontents
)->objvar
= newval
;
939 /* If this variable is a default for something stored
940 in the buffer itself, such as default-fill-column,
941 find the buffers that don't have local values for it
943 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
944 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
946 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
947 - (char *) &buffer_defaults
);
948 int idx
= PER_BUFFER_IDX (offset
);
955 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
960 buf
= Fcdr (XCAR (tail
));
961 if (!BUFFERP (buf
)) continue;
964 if (! PER_BUFFER_VALUE_P (b
, idx
))
965 PER_BUFFER_VALUE (b
, offset
) = newval
;
970 case Lisp_Misc_Buffer_Objfwd
:
972 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
975 type
= PER_BUFFER_TYPE (offset
);
976 if (! NILP (type
) && ! NILP (newval
)
977 && XTYPE (newval
) != XINT (type
))
978 buffer_slot_type_mismatch (offset
);
981 buf
= current_buffer
;
982 PER_BUFFER_VALUE (buf
, offset
) = newval
;
986 case Lisp_Misc_Kboard_Objfwd
:
988 char *base
= (char *) current_kboard
;
989 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
990 *(Lisp_Object
*) p
= newval
;
1001 valcontents
= SYMBOL_VALUE (symbol
);
1002 if (BUFFER_LOCAL_VALUEP (valcontents
)
1003 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1004 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1006 SET_SYMBOL_VALUE (symbol
, newval
);
1010 /* Set up SYMBOL to refer to its global binding.
1011 This makes it safe to alter the status of other bindings. */
1014 swap_in_global_binding (symbol
)
1017 Lisp_Object valcontents
, cdr
;
1019 valcontents
= SYMBOL_VALUE (symbol
);
1020 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1021 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1023 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1025 /* Unload the previously loaded binding. */
1026 Fsetcdr (XCAR (cdr
),
1027 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1029 /* Select the global binding in the symbol. */
1031 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1033 /* Indicate that the global binding is set up now. */
1034 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1035 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1036 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1037 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1040 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1041 VALCONTENTS is the contents of its value cell,
1042 which points to a struct Lisp_Buffer_Local_Value.
1044 Return the value forwarded one step past the buffer-local stage.
1045 This could be another forwarding pointer. */
1048 swap_in_symval_forwarding (symbol
, valcontents
)
1049 Lisp_Object symbol
, valcontents
;
1051 register Lisp_Object tem1
;
1053 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1056 || current_buffer
!= XBUFFER (tem1
)
1057 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1058 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1060 if (XSYMBOL (symbol
)->indirect_variable
)
1061 symbol
= indirect_variable (symbol
);
1063 /* Unload the previously loaded binding. */
1064 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1066 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1067 /* Choose the new binding. */
1068 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1069 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1070 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1073 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1074 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1076 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1078 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1081 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1083 /* Load the new binding. */
1084 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1085 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1086 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1087 store_symval_forwarding (symbol
,
1088 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1091 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1094 /* Find the value of a symbol, returning Qunbound if it's not bound.
1095 This is helpful for code which just wants to get a variable's value
1096 if it has one, without signaling an error.
1097 Note that it must not be possible to quit
1098 within this function. Great care is required for this. */
1101 find_symbol_value (symbol
)
1104 register Lisp_Object valcontents
;
1105 register Lisp_Object val
;
1107 CHECK_SYMBOL (symbol
);
1108 valcontents
= SYMBOL_VALUE (symbol
);
1110 if (BUFFER_LOCAL_VALUEP (valcontents
)
1111 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1112 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1114 if (MISCP (valcontents
))
1116 switch (XMISCTYPE (valcontents
))
1118 case Lisp_Misc_Intfwd
:
1119 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1122 case Lisp_Misc_Boolfwd
:
1123 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1125 case Lisp_Misc_Objfwd
:
1126 return *XOBJFWD (valcontents
)->objvar
;
1128 case Lisp_Misc_Buffer_Objfwd
:
1129 return PER_BUFFER_VALUE (current_buffer
,
1130 XBUFFER_OBJFWD (valcontents
)->offset
);
1132 case Lisp_Misc_Kboard_Objfwd
:
1133 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1134 + (char *)current_kboard
);
1141 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1142 doc
: /* Return SYMBOL's value. Error if that is void. */)
1148 val
= find_symbol_value (symbol
);
1149 if (EQ (val
, Qunbound
))
1150 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1155 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1156 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1158 register Lisp_Object symbol
, newval
;
1160 return set_internal (symbol
, newval
, current_buffer
, 0);
1163 /* Return 1 if SYMBOL currently has a let-binding
1164 which was made in the buffer that is now current. */
1167 let_shadows_buffer_binding_p (symbol
)
1170 volatile struct specbinding
*p
;
1172 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1174 && CONSP (p
->symbol
))
1176 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1177 if ((EQ (symbol
, let_bound_symbol
)
1178 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1179 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1180 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1184 return p
>= specpdl
;
1187 /* Store the value NEWVAL into SYMBOL.
1188 If buffer-locality is an issue, BUF specifies which buffer to use.
1189 (0 stands for the current buffer.)
1191 If BINDFLAG is zero, then if this symbol is supposed to become
1192 local in every buffer where it is set, then we make it local.
1193 If BINDFLAG is nonzero, we don't do that. */
1196 set_internal (symbol
, newval
, buf
, bindflag
)
1197 register Lisp_Object symbol
, newval
;
1201 int voide
= EQ (newval
, Qunbound
);
1203 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1206 buf
= current_buffer
;
1208 /* If restoring in a dead buffer, do nothing. */
1209 if (NILP (buf
->name
))
1212 CHECK_SYMBOL (symbol
);
1213 if (SYMBOL_CONSTANT_P (symbol
)
1214 && (NILP (Fkeywordp (symbol
))
1215 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1216 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1218 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1220 if (BUFFER_OBJFWDP (valcontents
))
1222 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1223 int idx
= PER_BUFFER_IDX (offset
);
1226 && !let_shadows_buffer_binding_p (symbol
))
1227 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1229 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1230 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1232 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1233 if (XSYMBOL (symbol
)->indirect_variable
)
1234 symbol
= indirect_variable (symbol
);
1236 /* What binding is loaded right now? */
1237 current_alist_element
1238 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1240 /* If the current buffer is not the buffer whose binding is
1241 loaded, or if there may be frame-local bindings and the frame
1242 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1243 the default binding is loaded, the loaded binding may be the
1245 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1246 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1247 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1248 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1249 || (BUFFER_LOCAL_VALUEP (valcontents
)
1250 && EQ (XCAR (current_alist_element
),
1251 current_alist_element
)))
1253 /* The currently loaded binding is not necessarily valid.
1254 We need to unload it, and choose a new binding. */
1256 /* Write out `realvalue' to the old loaded binding. */
1257 Fsetcdr (current_alist_element
,
1258 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1260 /* Find the new binding. */
1261 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1262 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1263 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1267 /* This buffer still sees the default value. */
1269 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1270 or if this is `let' rather than `set',
1271 make CURRENT-ALIST-ELEMENT point to itself,
1272 indicating that we're seeing the default value.
1273 Likewise if the variable has been let-bound
1274 in the current buffer. */
1275 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1276 || let_shadows_buffer_binding_p (symbol
))
1278 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1280 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1281 tem1
= Fassq (symbol
,
1282 XFRAME (selected_frame
)->param_alist
);
1285 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1287 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1289 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1290 and we're not within a let that was made for this buffer,
1291 create a new buffer-local binding for the variable.
1292 That means, give this buffer a new assoc for a local value
1293 and load that binding. */
1296 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1297 buf
->local_var_alist
1298 = Fcons (tem1
, buf
->local_var_alist
);
1302 /* Record which binding is now loaded. */
1303 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1306 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1307 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1308 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1310 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1313 /* If storing void (making the symbol void), forward only through
1314 buffer-local indicator, not through Lisp_Objfwd, etc. */
1316 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1318 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1320 /* If we just set a variable whose current binding is frame-local,
1321 store the new value in the frame parameter too. */
1323 if (BUFFER_LOCAL_VALUEP (valcontents
)
1324 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1326 /* What binding is loaded right now? */
1327 current_alist_element
1328 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1330 /* If the current buffer is not the buffer whose binding is
1331 loaded, or if there may be frame-local bindings and the frame
1332 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1333 the default binding is loaded, the loaded binding may be the
1335 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1336 XSETCDR (current_alist_element
, newval
);
1342 /* Access or set a buffer-local symbol's default value. */
1344 /* Return the default value of SYMBOL, but don't check for voidness.
1345 Return Qunbound if it is void. */
1348 default_value (symbol
)
1351 register Lisp_Object valcontents
;
1353 CHECK_SYMBOL (symbol
);
1354 valcontents
= SYMBOL_VALUE (symbol
);
1356 /* For a built-in buffer-local variable, get the default value
1357 rather than letting do_symval_forwarding get the current value. */
1358 if (BUFFER_OBJFWDP (valcontents
))
1360 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1361 if (PER_BUFFER_IDX (offset
) != 0)
1362 return PER_BUFFER_DEFAULT (offset
);
1365 /* Handle user-created local variables. */
1366 if (BUFFER_LOCAL_VALUEP (valcontents
)
1367 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1369 /* If var is set up for a buffer that lacks a local value for it,
1370 the current value is nominally the default value.
1371 But the `realvalue' slot may be more up to date, since
1372 ordinary setq stores just that slot. So use that. */
1373 Lisp_Object current_alist_element
, alist_element_car
;
1374 current_alist_element
1375 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1376 alist_element_car
= XCAR (current_alist_element
);
1377 if (EQ (alist_element_car
, current_alist_element
))
1378 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1380 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1382 /* For other variables, get the current value. */
1383 return do_symval_forwarding (valcontents
);
1386 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1387 doc
: /* Return t if SYMBOL has a non-void default value.
1388 This is the value that is seen in buffers that do not have their own values
1389 for this variable. */)
1393 register Lisp_Object value
;
1395 value
= default_value (symbol
);
1396 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1399 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1400 doc
: /* Return SYMBOL's default value.
1401 This is the value that is seen in buffers that do not have their own values
1402 for this variable. The default value is meaningful for variables with
1403 local bindings in certain buffers. */)
1407 register Lisp_Object value
;
1409 value
= default_value (symbol
);
1410 if (EQ (value
, Qunbound
))
1411 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1415 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1416 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1417 The default value is seen in buffers that do not have their own values
1418 for this variable. */)
1420 Lisp_Object symbol
, value
;
1422 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1424 CHECK_SYMBOL (symbol
);
1425 valcontents
= SYMBOL_VALUE (symbol
);
1427 /* Handle variables like case-fold-search that have special slots
1428 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1430 if (BUFFER_OBJFWDP (valcontents
))
1432 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1433 int idx
= PER_BUFFER_IDX (offset
);
1435 PER_BUFFER_DEFAULT (offset
) = value
;
1437 /* If this variable is not always local in all buffers,
1438 set it in the buffers that don't nominally have a local value. */
1443 for (b
= all_buffers
; b
; b
= b
->next
)
1444 if (!PER_BUFFER_VALUE_P (b
, idx
))
1445 PER_BUFFER_VALUE (b
, offset
) = value
;
1450 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1451 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1452 return Fset (symbol
, value
);
1454 /* Store new value into the DEFAULT-VALUE slot. */
1455 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1457 /* If the default binding is now loaded, set the REALVALUE slot too. */
1458 current_alist_element
1459 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1460 alist_element_buffer
= Fcar (current_alist_element
);
1461 if (EQ (alist_element_buffer
, current_alist_element
))
1462 store_symval_forwarding (symbol
,
1463 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1469 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1470 doc
: /* Set the default value of variable VAR to VALUE.
1471 VAR, the variable name, is literal (not evaluated);
1472 VALUE is an expression: it is evaluated and its value returned.
1473 The default value of a variable is seen in buffers
1474 that do not have their own values for the variable.
1476 More generally, you can use multiple variables and values, as in
1477 (setq-default VAR VALUE VAR VALUE...)
1478 This sets each VAR's default value to the corresponding VALUE.
1479 The VALUE for the Nth VAR can refer to the new default values
1481 usage: (setq-default [VAR VALUE...]) */)
1485 register Lisp_Object args_left
;
1486 register Lisp_Object val
, symbol
;
1487 struct gcpro gcpro1
;
1497 val
= Feval (Fcar (Fcdr (args_left
)));
1498 symbol
= XCAR (args_left
);
1499 Fset_default (symbol
, val
);
1500 args_left
= Fcdr (XCDR (args_left
));
1502 while (!NILP (args_left
));
1508 /* Lisp functions for creating and removing buffer-local variables. */
1510 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1511 1, 1, "vMake Variable Buffer Local: ",
1512 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1513 At any time, the value for the current buffer is in effect,
1514 unless the variable has never been set in this buffer,
1515 in which case the default value is in effect.
1516 Note that binding the variable with `let', or setting it while
1517 a `let'-style binding made in this buffer is in effect,
1518 does not make the variable buffer-local. Return VARIABLE.
1520 In most cases it is better to use `make-local-variable',
1521 which makes a variable local in just one buffer.
1523 The function `default-value' gets the default value and `set-default' sets it. */)
1525 register Lisp_Object variable
;
1527 register Lisp_Object tem
, valcontents
, newval
;
1529 CHECK_SYMBOL (variable
);
1530 variable
= indirect_variable (variable
);
1532 valcontents
= SYMBOL_VALUE (variable
);
1533 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1534 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1536 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1538 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1540 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1543 if (EQ (valcontents
, Qunbound
))
1544 SET_SYMBOL_VALUE (variable
, Qnil
);
1545 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1547 newval
= allocate_misc ();
1548 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1549 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1550 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1551 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1552 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1553 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1554 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1555 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1556 SET_SYMBOL_VALUE (variable
, newval
);
1560 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1561 1, 1, "vMake Local Variable: ",
1562 doc
: /* Make VARIABLE have a separate value in the current buffer.
1563 Other buffers will continue to share a common default value.
1564 \(The buffer-local value of VARIABLE starts out as the same value
1565 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1568 If the variable is already arranged to become local when set,
1569 this function causes a local value to exist for this buffer,
1570 just as setting the variable would do.
1572 This function returns VARIABLE, and therefore
1573 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1576 See also `make-variable-buffer-local'.
1578 Do not use `make-local-variable' to make a hook variable buffer-local.
1579 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1581 register Lisp_Object variable
;
1583 register Lisp_Object tem
, valcontents
;
1585 CHECK_SYMBOL (variable
);
1586 variable
= indirect_variable (variable
);
1588 valcontents
= SYMBOL_VALUE (variable
);
1589 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1590 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1592 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1594 tem
= Fboundp (variable
);
1596 /* Make sure the symbol has a local value in this particular buffer,
1597 by setting it to the same value it already has. */
1598 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1601 /* Make sure symbol is set up to hold per-buffer values. */
1602 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1605 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1607 newval
= allocate_misc ();
1608 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1609 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1610 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1611 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1612 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1613 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1614 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1615 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1616 SET_SYMBOL_VALUE (variable
, newval
);;
1618 /* Make sure this buffer has its own value of symbol. */
1619 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1622 /* Swap out any local binding for some other buffer, and make
1623 sure the current value is permanently recorded, if it's the
1625 find_symbol_value (variable
);
1627 current_buffer
->local_var_alist
1628 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1629 current_buffer
->local_var_alist
);
1631 /* Make sure symbol does not think it is set up for this buffer;
1632 force it to look once again for this buffer's value. */
1634 Lisp_Object
*pvalbuf
;
1636 valcontents
= SYMBOL_VALUE (variable
);
1638 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1639 if (current_buffer
== XBUFFER (*pvalbuf
))
1641 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1645 /* If the symbol forwards into a C variable, then load the binding
1646 for this buffer now. If C code modifies the variable before we
1647 load the binding in, then that new value will clobber the default
1648 binding the next time we unload it. */
1649 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1650 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1651 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1656 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1657 1, 1, "vKill Local Variable: ",
1658 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1659 From now on the default value will apply in this buffer. Return VARIABLE. */)
1661 register Lisp_Object variable
;
1663 register Lisp_Object tem
, valcontents
;
1665 CHECK_SYMBOL (variable
);
1666 variable
= indirect_variable (variable
);
1668 valcontents
= SYMBOL_VALUE (variable
);
1670 if (BUFFER_OBJFWDP (valcontents
))
1672 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1673 int idx
= PER_BUFFER_IDX (offset
);
1677 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1678 PER_BUFFER_VALUE (current_buffer
, offset
)
1679 = PER_BUFFER_DEFAULT (offset
);
1684 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1685 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1688 /* Get rid of this buffer's alist element, if any. */
1690 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1692 current_buffer
->local_var_alist
1693 = Fdelq (tem
, current_buffer
->local_var_alist
);
1695 /* If the symbol is set up with the current buffer's binding
1696 loaded, recompute its value. We have to do it now, or else
1697 forwarded objects won't work right. */
1699 Lisp_Object
*pvalbuf
, buf
;
1700 valcontents
= SYMBOL_VALUE (variable
);
1701 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1702 XSETBUFFER (buf
, current_buffer
);
1703 if (EQ (buf
, *pvalbuf
))
1706 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1707 find_symbol_value (variable
);
1714 /* Lisp functions for creating and removing buffer-local variables. */
1716 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1717 1, 1, "vMake Variable Frame Local: ",
1718 doc
: /* Enable VARIABLE to have frame-local bindings.
1719 This does not create any frame-local bindings for VARIABLE,
1720 it just makes them possible.
1722 A frame-local binding is actually a frame parameter value.
1723 If a frame F has a value for the frame parameter named VARIABLE,
1724 that also acts as a frame-local binding for VARIABLE in F--
1725 provided this function has been called to enable VARIABLE
1726 to have frame-local bindings at all.
1728 The only way to create a frame-local binding for VARIABLE in a frame
1729 is to set the VARIABLE frame parameter of that frame. See
1730 `modify-frame-parameters' for how to set frame parameters.
1732 Buffer-local bindings take precedence over frame-local bindings. */)
1734 register Lisp_Object variable
;
1736 register Lisp_Object tem
, valcontents
, newval
;
1738 CHECK_SYMBOL (variable
);
1739 variable
= indirect_variable (variable
);
1741 valcontents
= SYMBOL_VALUE (variable
);
1742 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1743 || BUFFER_OBJFWDP (valcontents
))
1744 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1746 if (BUFFER_LOCAL_VALUEP (valcontents
)
1747 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1749 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1753 if (EQ (valcontents
, Qunbound
))
1754 SET_SYMBOL_VALUE (variable
, Qnil
);
1755 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1757 newval
= allocate_misc ();
1758 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1759 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1760 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1761 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1762 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1763 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1764 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1765 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1766 SET_SYMBOL_VALUE (variable
, newval
);
1770 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1772 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1773 BUFFER defaults to the current buffer. */)
1775 register Lisp_Object variable
, buffer
;
1777 Lisp_Object valcontents
;
1778 register struct buffer
*buf
;
1781 buf
= current_buffer
;
1784 CHECK_BUFFER (buffer
);
1785 buf
= XBUFFER (buffer
);
1788 CHECK_SYMBOL (variable
);
1789 variable
= indirect_variable (variable
);
1791 valcontents
= SYMBOL_VALUE (variable
);
1792 if (BUFFER_LOCAL_VALUEP (valcontents
)
1793 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1795 Lisp_Object tail
, elt
;
1797 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1800 if (EQ (variable
, XCAR (elt
)))
1804 if (BUFFER_OBJFWDP (valcontents
))
1806 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1807 int idx
= PER_BUFFER_IDX (offset
);
1808 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1814 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1816 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1817 More precisely, this means that setting the variable \(with `set' or`setq'),
1818 while it does not have a `let'-style binding that was made in BUFFER,
1819 will produce a buffer local binding. See Info node
1820 `(elisp)Creating Buffer-Local'.
1821 BUFFER defaults to the current buffer. */)
1823 register Lisp_Object variable
, buffer
;
1825 Lisp_Object valcontents
;
1826 register struct buffer
*buf
;
1829 buf
= current_buffer
;
1832 CHECK_BUFFER (buffer
);
1833 buf
= XBUFFER (buffer
);
1836 CHECK_SYMBOL (variable
);
1837 variable
= indirect_variable (variable
);
1839 valcontents
= SYMBOL_VALUE (variable
);
1841 /* This means that make-variable-buffer-local was done. */
1842 if (BUFFER_LOCAL_VALUEP (valcontents
))
1844 /* All these slots become local if they are set. */
1845 if (BUFFER_OBJFWDP (valcontents
))
1847 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1849 Lisp_Object tail
, elt
;
1850 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1853 if (EQ (variable
, XCAR (elt
)))
1860 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1862 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1863 If the current binding is buffer-local, the value is the current buffer.
1864 If the current binding is frame-local, the value is the selected frame.
1865 If the current binding is global (the default), the value is nil. */)
1867 register Lisp_Object variable
;
1869 Lisp_Object valcontents
;
1871 CHECK_SYMBOL (variable
);
1872 variable
= indirect_variable (variable
);
1874 /* Make sure the current binding is actually swapped in. */
1875 find_symbol_value (variable
);
1877 valcontents
= XSYMBOL (variable
)->value
;
1879 if (BUFFER_LOCAL_VALUEP (valcontents
)
1880 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1881 || BUFFER_OBJFWDP (valcontents
))
1883 /* For a local variable, record both the symbol and which
1884 buffer's or frame's value we are saving. */
1885 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1886 return Fcurrent_buffer ();
1887 else if (!BUFFER_OBJFWDP (valcontents
)
1888 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1889 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1895 /* Find the function at the end of a chain of symbol function indirections. */
1897 /* If OBJECT is a symbol, find the end of its function chain and
1898 return the value found there. If OBJECT is not a symbol, just
1899 return it. If there is a cycle in the function chain, signal a
1900 cyclic-function-indirection error.
1902 This is like Findirect_function, except that it doesn't signal an
1903 error if the chain ends up unbound. */
1905 indirect_function (object
)
1906 register Lisp_Object object
;
1908 Lisp_Object tortoise
, hare
;
1910 hare
= tortoise
= object
;
1914 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1916 hare
= XSYMBOL (hare
)->function
;
1917 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1919 hare
= XSYMBOL (hare
)->function
;
1921 tortoise
= XSYMBOL (tortoise
)->function
;
1923 if (EQ (hare
, tortoise
))
1924 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1930 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1931 doc
: /* Return the function at the end of OBJECT's function chain.
1932 If OBJECT is not a symbol, just return it. Otherwise, follow all
1933 function indirections to find the final function binding and return it.
1934 If the final symbol in the chain is unbound, signal a void-function error.
1935 Optional arg NOERROR non-nil means to return nil instead of signalling.
1936 Signal a cyclic-function-indirection error if there is a loop in the
1937 function chain of symbols. */)
1939 register Lisp_Object object
;
1940 Lisp_Object noerror
;
1944 result
= indirect_function (object
);
1946 if (EQ (result
, Qunbound
))
1947 return (NILP (noerror
)
1948 ? Fsignal (Qvoid_function
, Fcons (object
, Qnil
))
1953 /* Extract and set vector and string elements */
1955 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1956 doc
: /* Return the element of ARRAY at index IDX.
1957 ARRAY may be a vector, a string, a char-table, a bool-vector,
1958 or a byte-code object. IDX starts at 0. */)
1960 register Lisp_Object array
;
1963 register int idxval
;
1966 idxval
= XINT (idx
);
1967 if (STRINGP (array
))
1971 if (idxval
< 0 || idxval
>= SCHARS (array
))
1972 args_out_of_range (array
, idx
);
1973 if (! STRING_MULTIBYTE (array
))
1974 return make_number ((unsigned char) SREF (array
, idxval
));
1975 idxval_byte
= string_char_to_byte (array
, idxval
);
1977 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1978 SBYTES (array
) - idxval_byte
);
1979 return make_number (c
);
1981 else if (BOOL_VECTOR_P (array
))
1985 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1986 args_out_of_range (array
, idx
);
1988 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1989 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1991 else if (CHAR_TABLE_P (array
))
1993 CHECK_CHARACTER (idx
);
1994 return CHAR_TABLE_REF (array
, idxval
);
1999 if (VECTORP (array
))
2000 size
= XVECTOR (array
)->size
;
2001 else if (COMPILEDP (array
))
2002 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2004 wrong_type_argument (Qarrayp
, array
);
2006 if (idxval
< 0 || idxval
>= size
)
2007 args_out_of_range (array
, idx
);
2008 return XVECTOR (array
)->contents
[idxval
];
2012 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2013 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2014 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2015 bool-vector. IDX starts at 0. */)
2016 (array
, idx
, newelt
)
2017 register Lisp_Object array
;
2018 Lisp_Object idx
, newelt
;
2020 register int idxval
;
2023 idxval
= XINT (idx
);
2024 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2025 && ! CHAR_TABLE_P (array
))
2026 array
= wrong_type_argument (Qarrayp
, array
);
2027 CHECK_IMPURE (array
);
2029 if (VECTORP (array
))
2031 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2032 args_out_of_range (array
, idx
);
2033 XVECTOR (array
)->contents
[idxval
] = newelt
;
2035 else if (BOOL_VECTOR_P (array
))
2039 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2040 args_out_of_range (array
, idx
);
2042 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2044 if (! NILP (newelt
))
2045 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2047 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2048 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2050 else if (CHAR_TABLE_P (array
))
2052 CHECK_CHARACTER (idx
);
2053 CHAR_TABLE_SET (array
, idxval
, newelt
);
2055 else if (STRING_MULTIBYTE (array
))
2057 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2058 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2060 if (idxval
< 0 || idxval
>= SCHARS (array
))
2061 args_out_of_range (array
, idx
);
2062 CHECK_CHARACTER (newelt
);
2064 nbytes
= SBYTES (array
);
2066 idxval_byte
= string_char_to_byte (array
, idxval
);
2067 p1
= SDATA (array
) + idxval_byte
;
2068 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2069 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2070 if (prev_bytes
!= new_bytes
)
2072 /* We must relocate the string data. */
2073 int nchars
= SCHARS (array
);
2077 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2078 bcopy (SDATA (array
), str
, nbytes
);
2079 allocate_string_data (XSTRING (array
), nchars
,
2080 nbytes
+ new_bytes
- prev_bytes
);
2081 bcopy (str
, SDATA (array
), idxval_byte
);
2082 p1
= SDATA (array
) + idxval_byte
;
2083 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2084 nbytes
- (idxval_byte
+ prev_bytes
));
2086 clear_string_char_byte_cache ();
2093 if (idxval
< 0 || idxval
>= SCHARS (array
))
2094 args_out_of_range (array
, idx
);
2095 CHECK_NUMBER (newelt
);
2097 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2098 args_out_of_range (array
, newelt
);
2099 SSET (array
, idxval
, XINT (newelt
));
2105 /* Arithmetic functions */
2107 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2110 arithcompare (num1
, num2
, comparison
)
2111 Lisp_Object num1
, num2
;
2112 enum comparison comparison
;
2114 double f1
= 0, f2
= 0;
2117 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2118 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2120 if (FLOATP (num1
) || FLOATP (num2
))
2123 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2124 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2130 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2135 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2140 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2145 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2150 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2155 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2164 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2165 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2167 register Lisp_Object num1
, num2
;
2169 return arithcompare (num1
, num2
, equal
);
2172 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2173 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2175 register Lisp_Object num1
, num2
;
2177 return arithcompare (num1
, num2
, less
);
2180 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2181 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2183 register Lisp_Object num1
, num2
;
2185 return arithcompare (num1
, num2
, grtr
);
2188 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2189 doc
: /* Return t if first arg is less than or equal to second arg.
2190 Both must be numbers or markers. */)
2192 register Lisp_Object num1
, num2
;
2194 return arithcompare (num1
, num2
, less_or_equal
);
2197 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2198 doc
: /* Return t if first arg is greater than or equal to second arg.
2199 Both must be numbers or markers. */)
2201 register Lisp_Object num1
, num2
;
2203 return arithcompare (num1
, num2
, grtr_or_equal
);
2206 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2207 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2209 register Lisp_Object num1
, num2
;
2211 return arithcompare (num1
, num2
, notequal
);
2214 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2215 doc
: /* Return t if NUMBER is zero. */)
2217 register Lisp_Object number
;
2219 CHECK_NUMBER_OR_FLOAT (number
);
2221 if (FLOATP (number
))
2223 if (XFLOAT_DATA (number
) == 0.0)
2233 /* Convert between long values and pairs of Lisp integers. */
2239 unsigned long top
= i
>> 16;
2240 unsigned int bot
= i
& 0xFFFF;
2242 return make_number (bot
);
2243 if (top
== (unsigned long)-1 >> 16)
2244 return Fcons (make_number (-1), make_number (bot
));
2245 return Fcons (make_number (top
), make_number (bot
));
2252 Lisp_Object top
, bot
;
2259 return ((XINT (top
) << 16) | XINT (bot
));
2262 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2263 doc
: /* Return the decimal representation of NUMBER as a string.
2264 Uses a minus sign if negative.
2265 NUMBER may be an integer or a floating point number. */)
2269 char buffer
[VALBITS
];
2271 CHECK_NUMBER_OR_FLOAT (number
);
2273 if (FLOATP (number
))
2275 char pigbuf
[350]; /* see comments in float_to_string */
2277 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2278 return build_string (pigbuf
);
2281 if (sizeof (int) == sizeof (EMACS_INT
))
2282 sprintf (buffer
, "%d", XINT (number
));
2283 else if (sizeof (long) == sizeof (EMACS_INT
))
2284 sprintf (buffer
, "%ld", (long) XINT (number
));
2287 return build_string (buffer
);
2291 digit_to_number (character
, base
)
2292 int character
, base
;
2296 if (character
>= '0' && character
<= '9')
2297 digit
= character
- '0';
2298 else if (character
>= 'a' && character
<= 'z')
2299 digit
= character
- 'a' + 10;
2300 else if (character
>= 'A' && character
<= 'Z')
2301 digit
= character
- 'A' + 10;
2311 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2312 doc
: /* Parse STRING as a decimal number and return the number.
2313 This parses both integers and floating point numbers.
2314 It ignores leading spaces and tabs.
2316 If BASE, interpret STRING as a number in that base. If BASE isn't
2317 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2318 If the base used is not 10, floating point is not recognized. */)
2320 register Lisp_Object string
, base
;
2322 register unsigned char *p
;
2327 CHECK_STRING (string
);
2333 CHECK_NUMBER (base
);
2335 if (b
< 2 || b
> 16)
2336 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2339 /* Skip any whitespace at the front of the number. Some versions of
2340 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2342 while (*p
== ' ' || *p
== '\t')
2353 if (isfloat_string (p
) && b
== 10)
2354 val
= make_float (sign
* atof (p
));
2361 int digit
= digit_to_number (*p
++, b
);
2367 val
= make_fixnum_or_float (sign
* v
);
2387 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2388 int, Lisp_Object
*));
2389 extern Lisp_Object
fmod_float ();
2392 arith_driver (code
, nargs
, args
)
2395 register Lisp_Object
*args
;
2397 register Lisp_Object val
;
2398 register int argnum
;
2399 register EMACS_INT accum
= 0;
2400 register EMACS_INT next
;
2402 switch (SWITCH_ENUM_CAST (code
))
2420 for (argnum
= 0; argnum
< nargs
; argnum
++)
2422 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2424 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2427 return float_arith_driver ((double) accum
, argnum
, code
,
2430 next
= XINT (args
[argnum
]);
2431 switch (SWITCH_ENUM_CAST (code
))
2437 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2448 Fsignal (Qarith_error
, Qnil
);
2462 if (!argnum
|| next
> accum
)
2466 if (!argnum
|| next
< accum
)
2472 XSETINT (val
, accum
);
2477 #define isnan(x) ((x) != (x))
2480 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2482 register int argnum
;
2485 register Lisp_Object
*args
;
2487 register Lisp_Object val
;
2490 for (; argnum
< nargs
; argnum
++)
2492 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2493 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2497 next
= XFLOAT_DATA (val
);
2501 args
[argnum
] = val
; /* runs into a compiler bug. */
2502 next
= XINT (args
[argnum
]);
2504 switch (SWITCH_ENUM_CAST (code
))
2510 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2520 if (! IEEE_FLOATING_POINT
&& next
== 0)
2521 Fsignal (Qarith_error
, Qnil
);
2528 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2530 if (!argnum
|| isnan (next
) || next
> accum
)
2534 if (!argnum
|| isnan (next
) || next
< accum
)
2540 return make_float (accum
);
2544 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2545 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2546 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2551 return arith_driver (Aadd
, nargs
, args
);
2554 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2555 doc
: /* Negate number or subtract numbers or markers and return the result.
2556 With one arg, negates it. With more than one arg,
2557 subtracts all but the first from the first.
2558 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2563 return arith_driver (Asub
, nargs
, args
);
2566 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2567 doc
: /* Return product of any number of arguments, which are numbers or markers.
2568 usage: (* &rest NUMBERS-OR-MARKERS) */)
2573 return arith_driver (Amult
, nargs
, args
);
2576 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2577 doc
: /* Return first argument divided by all the remaining arguments.
2578 The arguments must be numbers or markers.
2579 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2585 for (argnum
= 2; argnum
< nargs
; argnum
++)
2586 if (FLOATP (args
[argnum
]))
2587 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2588 return arith_driver (Adiv
, nargs
, args
);
2591 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2592 doc
: /* Return remainder of X divided by Y.
2593 Both must be integers or markers. */)
2595 register Lisp_Object x
, y
;
2599 CHECK_NUMBER_COERCE_MARKER (x
);
2600 CHECK_NUMBER_COERCE_MARKER (y
);
2602 if (XFASTINT (y
) == 0)
2603 Fsignal (Qarith_error
, Qnil
);
2605 XSETINT (val
, XINT (x
) % XINT (y
));
2619 /* If the magnitude of the result exceeds that of the divisor, or
2620 the sign of the result does not agree with that of the dividend,
2621 iterate with the reduced value. This does not yield a
2622 particularly accurate result, but at least it will be in the
2623 range promised by fmod. */
2625 r
-= f2
* floor (r
/ f2
);
2626 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2630 #endif /* ! HAVE_FMOD */
2632 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2633 doc
: /* Return X modulo Y.
2634 The result falls between zero (inclusive) and Y (exclusive).
2635 Both X and Y must be numbers or markers. */)
2637 register Lisp_Object x
, y
;
2642 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2643 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2645 if (FLOATP (x
) || FLOATP (y
))
2646 return fmod_float (x
, y
);
2652 Fsignal (Qarith_error
, Qnil
);
2656 /* If the "remainder" comes out with the wrong sign, fix it. */
2657 if (i2
< 0 ? i1
> 0 : i1
< 0)
2664 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2665 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2666 The value is always a number; markers are converted to numbers.
2667 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2672 return arith_driver (Amax
, nargs
, args
);
2675 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2676 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2677 The value is always a number; markers are converted to numbers.
2678 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2683 return arith_driver (Amin
, nargs
, args
);
2686 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2687 doc
: /* Return bitwise-and of all the arguments.
2688 Arguments may be integers, or markers converted to integers.
2689 usage: (logand &rest INTS-OR-MARKERS) */)
2694 return arith_driver (Alogand
, nargs
, args
);
2697 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2698 doc
: /* Return bitwise-or of all the arguments.
2699 Arguments may be integers, or markers converted to integers.
2700 usage: (logior &rest INTS-OR-MARKERS) */)
2705 return arith_driver (Alogior
, nargs
, args
);
2708 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2709 doc
: /* Return bitwise-exclusive-or of all the arguments.
2710 Arguments may be integers, or markers converted to integers.
2711 usage: (logxor &rest INTS-OR-MARKERS) */)
2716 return arith_driver (Alogxor
, nargs
, args
);
2719 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2720 doc
: /* Return VALUE with its bits shifted left by COUNT.
2721 If COUNT is negative, shifting is actually to the right.
2722 In this case, the sign bit is duplicated. */)
2724 register Lisp_Object value
, count
;
2726 register Lisp_Object val
;
2728 CHECK_NUMBER (value
);
2729 CHECK_NUMBER (count
);
2731 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2733 else if (XINT (count
) > 0)
2734 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2735 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2736 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2738 XSETINT (val
, XINT (value
) >> -XINT (count
));
2742 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2743 doc
: /* Return VALUE with its bits shifted left by COUNT.
2744 If COUNT is negative, shifting is actually to the right.
2745 In this case, zeros are shifted in on the left. */)
2747 register Lisp_Object value
, count
;
2749 register Lisp_Object val
;
2751 CHECK_NUMBER (value
);
2752 CHECK_NUMBER (count
);
2754 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2756 else if (XINT (count
) > 0)
2757 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2758 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2761 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2765 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2766 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2767 Markers are converted to integers. */)
2769 register Lisp_Object number
;
2771 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2773 if (FLOATP (number
))
2774 return (make_float (1.0 + XFLOAT_DATA (number
)));
2776 XSETINT (number
, XINT (number
) + 1);
2780 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2781 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2782 Markers are converted to integers. */)
2784 register Lisp_Object number
;
2786 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2788 if (FLOATP (number
))
2789 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2791 XSETINT (number
, XINT (number
) - 1);
2795 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2796 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2798 register Lisp_Object number
;
2800 CHECK_NUMBER (number
);
2801 XSETINT (number
, ~XINT (number
));
2805 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2806 doc
: /* Return the byteorder for the machine.
2807 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2808 lowercase l) for small endian machines. */)
2811 unsigned i
= 0x04030201;
2812 int order
= *(char *)&i
== 1 ? 108 : 66;
2814 return make_number (order
);
2822 Lisp_Object error_tail
, arith_tail
;
2824 Qquote
= intern ("quote");
2825 Qlambda
= intern ("lambda");
2826 Qsubr
= intern ("subr");
2827 Qerror_conditions
= intern ("error-conditions");
2828 Qerror_message
= intern ("error-message");
2829 Qtop_level
= intern ("top-level");
2831 Qerror
= intern ("error");
2832 Qquit
= intern ("quit");
2833 Qwrong_type_argument
= intern ("wrong-type-argument");
2834 Qargs_out_of_range
= intern ("args-out-of-range");
2835 Qvoid_function
= intern ("void-function");
2836 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2837 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2838 Qvoid_variable
= intern ("void-variable");
2839 Qsetting_constant
= intern ("setting-constant");
2840 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2842 Qinvalid_function
= intern ("invalid-function");
2843 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2844 Qno_catch
= intern ("no-catch");
2845 Qend_of_file
= intern ("end-of-file");
2846 Qarith_error
= intern ("arith-error");
2847 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2848 Qend_of_buffer
= intern ("end-of-buffer");
2849 Qbuffer_read_only
= intern ("buffer-read-only");
2850 Qtext_read_only
= intern ("text-read-only");
2851 Qmark_inactive
= intern ("mark-inactive");
2853 Qlistp
= intern ("listp");
2854 Qconsp
= intern ("consp");
2855 Qsymbolp
= intern ("symbolp");
2856 Qkeywordp
= intern ("keywordp");
2857 Qintegerp
= intern ("integerp");
2858 Qnatnump
= intern ("natnump");
2859 Qwholenump
= intern ("wholenump");
2860 Qstringp
= intern ("stringp");
2861 Qarrayp
= intern ("arrayp");
2862 Qsequencep
= intern ("sequencep");
2863 Qbufferp
= intern ("bufferp");
2864 Qvectorp
= intern ("vectorp");
2865 Qchar_or_string_p
= intern ("char-or-string-p");
2866 Qmarkerp
= intern ("markerp");
2867 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2868 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2869 Qboundp
= intern ("boundp");
2870 Qfboundp
= intern ("fboundp");
2872 Qfloatp
= intern ("floatp");
2873 Qnumberp
= intern ("numberp");
2874 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2876 Qchar_table_p
= intern ("char-table-p");
2877 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2879 Qsubrp
= intern ("subrp");
2880 Qunevalled
= intern ("unevalled");
2881 Qmany
= intern ("many");
2883 Qcdr
= intern ("cdr");
2885 /* Handle automatic advice activation */
2886 Qad_advice_info
= intern ("ad-advice-info");
2887 Qad_activate_internal
= intern ("ad-activate-internal");
2889 error_tail
= Fcons (Qerror
, Qnil
);
2891 /* ERROR is used as a signaler for random errors for which nothing else is right */
2893 Fput (Qerror
, Qerror_conditions
,
2895 Fput (Qerror
, Qerror_message
,
2896 build_string ("error"));
2898 Fput (Qquit
, Qerror_conditions
,
2899 Fcons (Qquit
, Qnil
));
2900 Fput (Qquit
, Qerror_message
,
2901 build_string ("Quit"));
2903 Fput (Qwrong_type_argument
, Qerror_conditions
,
2904 Fcons (Qwrong_type_argument
, error_tail
));
2905 Fput (Qwrong_type_argument
, Qerror_message
,
2906 build_string ("Wrong type argument"));
2908 Fput (Qargs_out_of_range
, Qerror_conditions
,
2909 Fcons (Qargs_out_of_range
, error_tail
));
2910 Fput (Qargs_out_of_range
, Qerror_message
,
2911 build_string ("Args out of range"));
2913 Fput (Qvoid_function
, Qerror_conditions
,
2914 Fcons (Qvoid_function
, error_tail
));
2915 Fput (Qvoid_function
, Qerror_message
,
2916 build_string ("Symbol's function definition is void"));
2918 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2919 Fcons (Qcyclic_function_indirection
, error_tail
));
2920 Fput (Qcyclic_function_indirection
, Qerror_message
,
2921 build_string ("Symbol's chain of function indirections contains a loop"));
2923 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2924 Fcons (Qcyclic_variable_indirection
, error_tail
));
2925 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2926 build_string ("Symbol's chain of variable indirections contains a loop"));
2928 Qcircular_list
= intern ("circular-list");
2929 staticpro (&Qcircular_list
);
2930 Fput (Qcircular_list
, Qerror_conditions
,
2931 Fcons (Qcircular_list
, error_tail
));
2932 Fput (Qcircular_list
, Qerror_message
,
2933 build_string ("List contains a loop"));
2935 Fput (Qvoid_variable
, Qerror_conditions
,
2936 Fcons (Qvoid_variable
, error_tail
));
2937 Fput (Qvoid_variable
, Qerror_message
,
2938 build_string ("Symbol's value as variable is void"));
2940 Fput (Qsetting_constant
, Qerror_conditions
,
2941 Fcons (Qsetting_constant
, error_tail
));
2942 Fput (Qsetting_constant
, Qerror_message
,
2943 build_string ("Attempt to set a constant symbol"));
2945 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2946 Fcons (Qinvalid_read_syntax
, error_tail
));
2947 Fput (Qinvalid_read_syntax
, Qerror_message
,
2948 build_string ("Invalid read syntax"));
2950 Fput (Qinvalid_function
, Qerror_conditions
,
2951 Fcons (Qinvalid_function
, error_tail
));
2952 Fput (Qinvalid_function
, Qerror_message
,
2953 build_string ("Invalid function"));
2955 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2956 Fcons (Qwrong_number_of_arguments
, error_tail
));
2957 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2958 build_string ("Wrong number of arguments"));
2960 Fput (Qno_catch
, Qerror_conditions
,
2961 Fcons (Qno_catch
, error_tail
));
2962 Fput (Qno_catch
, Qerror_message
,
2963 build_string ("No catch for tag"));
2965 Fput (Qend_of_file
, Qerror_conditions
,
2966 Fcons (Qend_of_file
, error_tail
));
2967 Fput (Qend_of_file
, Qerror_message
,
2968 build_string ("End of file during parsing"));
2970 arith_tail
= Fcons (Qarith_error
, error_tail
);
2971 Fput (Qarith_error
, Qerror_conditions
,
2973 Fput (Qarith_error
, Qerror_message
,
2974 build_string ("Arithmetic error"));
2976 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2977 Fcons (Qbeginning_of_buffer
, error_tail
));
2978 Fput (Qbeginning_of_buffer
, Qerror_message
,
2979 build_string ("Beginning of buffer"));
2981 Fput (Qend_of_buffer
, Qerror_conditions
,
2982 Fcons (Qend_of_buffer
, error_tail
));
2983 Fput (Qend_of_buffer
, Qerror_message
,
2984 build_string ("End of buffer"));
2986 Fput (Qbuffer_read_only
, Qerror_conditions
,
2987 Fcons (Qbuffer_read_only
, error_tail
));
2988 Fput (Qbuffer_read_only
, Qerror_message
,
2989 build_string ("Buffer is read-only"));
2991 Fput (Qtext_read_only
, Qerror_conditions
,
2992 Fcons (Qtext_read_only
, error_tail
));
2993 Fput (Qtext_read_only
, Qerror_message
,
2994 build_string ("Text is read-only"));
2996 Qrange_error
= intern ("range-error");
2997 Qdomain_error
= intern ("domain-error");
2998 Qsingularity_error
= intern ("singularity-error");
2999 Qoverflow_error
= intern ("overflow-error");
3000 Qunderflow_error
= intern ("underflow-error");
3002 Fput (Qdomain_error
, Qerror_conditions
,
3003 Fcons (Qdomain_error
, arith_tail
));
3004 Fput (Qdomain_error
, Qerror_message
,
3005 build_string ("Arithmetic domain error"));
3007 Fput (Qrange_error
, Qerror_conditions
,
3008 Fcons (Qrange_error
, arith_tail
));
3009 Fput (Qrange_error
, Qerror_message
,
3010 build_string ("Arithmetic range error"));
3012 Fput (Qsingularity_error
, Qerror_conditions
,
3013 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3014 Fput (Qsingularity_error
, Qerror_message
,
3015 build_string ("Arithmetic singularity error"));
3017 Fput (Qoverflow_error
, Qerror_conditions
,
3018 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3019 Fput (Qoverflow_error
, Qerror_message
,
3020 build_string ("Arithmetic overflow error"));
3022 Fput (Qunderflow_error
, Qerror_conditions
,
3023 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3024 Fput (Qunderflow_error
, Qerror_message
,
3025 build_string ("Arithmetic underflow error"));
3027 staticpro (&Qrange_error
);
3028 staticpro (&Qdomain_error
);
3029 staticpro (&Qsingularity_error
);
3030 staticpro (&Qoverflow_error
);
3031 staticpro (&Qunderflow_error
);
3035 staticpro (&Qquote
);
3036 staticpro (&Qlambda
);
3038 staticpro (&Qunbound
);
3039 staticpro (&Qerror_conditions
);
3040 staticpro (&Qerror_message
);
3041 staticpro (&Qtop_level
);
3043 staticpro (&Qerror
);
3045 staticpro (&Qwrong_type_argument
);
3046 staticpro (&Qargs_out_of_range
);
3047 staticpro (&Qvoid_function
);
3048 staticpro (&Qcyclic_function_indirection
);
3049 staticpro (&Qcyclic_variable_indirection
);
3050 staticpro (&Qvoid_variable
);
3051 staticpro (&Qsetting_constant
);
3052 staticpro (&Qinvalid_read_syntax
);
3053 staticpro (&Qwrong_number_of_arguments
);
3054 staticpro (&Qinvalid_function
);
3055 staticpro (&Qno_catch
);
3056 staticpro (&Qend_of_file
);
3057 staticpro (&Qarith_error
);
3058 staticpro (&Qbeginning_of_buffer
);
3059 staticpro (&Qend_of_buffer
);
3060 staticpro (&Qbuffer_read_only
);
3061 staticpro (&Qtext_read_only
);
3062 staticpro (&Qmark_inactive
);
3064 staticpro (&Qlistp
);
3065 staticpro (&Qconsp
);
3066 staticpro (&Qsymbolp
);
3067 staticpro (&Qkeywordp
);
3068 staticpro (&Qintegerp
);
3069 staticpro (&Qnatnump
);
3070 staticpro (&Qwholenump
);
3071 staticpro (&Qstringp
);
3072 staticpro (&Qarrayp
);
3073 staticpro (&Qsequencep
);
3074 staticpro (&Qbufferp
);
3075 staticpro (&Qvectorp
);
3076 staticpro (&Qchar_or_string_p
);
3077 staticpro (&Qmarkerp
);
3078 staticpro (&Qbuffer_or_string_p
);
3079 staticpro (&Qinteger_or_marker_p
);
3080 staticpro (&Qfloatp
);
3081 staticpro (&Qnumberp
);
3082 staticpro (&Qnumber_or_marker_p
);
3083 staticpro (&Qchar_table_p
);
3084 staticpro (&Qvector_or_char_table_p
);
3085 staticpro (&Qsubrp
);
3087 staticpro (&Qunevalled
);
3089 staticpro (&Qboundp
);
3090 staticpro (&Qfboundp
);
3092 staticpro (&Qad_advice_info
);
3093 staticpro (&Qad_activate_internal
);
3095 /* Types that type-of returns. */
3096 Qinteger
= intern ("integer");
3097 Qsymbol
= intern ("symbol");
3098 Qstring
= intern ("string");
3099 Qcons
= intern ("cons");
3100 Qmarker
= intern ("marker");
3101 Qoverlay
= intern ("overlay");
3102 Qfloat
= intern ("float");
3103 Qwindow_configuration
= intern ("window-configuration");
3104 Qprocess
= intern ("process");
3105 Qwindow
= intern ("window");
3106 /* Qsubr = intern ("subr"); */
3107 Qcompiled_function
= intern ("compiled-function");
3108 Qbuffer
= intern ("buffer");
3109 Qframe
= intern ("frame");
3110 Qvector
= intern ("vector");
3111 Qchar_table
= intern ("char-table");
3112 Qbool_vector
= intern ("bool-vector");
3113 Qhash_table
= intern ("hash-table");
3115 staticpro (&Qinteger
);
3116 staticpro (&Qsymbol
);
3117 staticpro (&Qstring
);
3119 staticpro (&Qmarker
);
3120 staticpro (&Qoverlay
);
3121 staticpro (&Qfloat
);
3122 staticpro (&Qwindow_configuration
);
3123 staticpro (&Qprocess
);
3124 staticpro (&Qwindow
);
3125 /* staticpro (&Qsubr); */
3126 staticpro (&Qcompiled_function
);
3127 staticpro (&Qbuffer
);
3128 staticpro (&Qframe
);
3129 staticpro (&Qvector
);
3130 staticpro (&Qchar_table
);
3131 staticpro (&Qbool_vector
);
3132 staticpro (&Qhash_table
);
3134 defsubr (&Sindirect_variable
);
3135 defsubr (&Sinteractive_form
);
3138 defsubr (&Stype_of
);
3143 defsubr (&Sintegerp
);
3144 defsubr (&Sinteger_or_marker_p
);
3145 defsubr (&Snumberp
);
3146 defsubr (&Snumber_or_marker_p
);
3148 defsubr (&Snatnump
);
3149 defsubr (&Ssymbolp
);
3150 defsubr (&Skeywordp
);
3151 defsubr (&Sstringp
);
3152 defsubr (&Smultibyte_string_p
);
3153 defsubr (&Svectorp
);
3154 defsubr (&Schar_table_p
);
3155 defsubr (&Svector_or_char_table_p
);
3156 defsubr (&Sbool_vector_p
);
3158 defsubr (&Ssequencep
);
3159 defsubr (&Sbufferp
);
3160 defsubr (&Smarkerp
);
3162 defsubr (&Sbyte_code_function_p
);
3163 defsubr (&Schar_or_string_p
);
3166 defsubr (&Scar_safe
);
3167 defsubr (&Scdr_safe
);
3170 defsubr (&Ssymbol_function
);
3171 defsubr (&Sindirect_function
);
3172 defsubr (&Ssymbol_plist
);
3173 defsubr (&Ssymbol_name
);
3174 defsubr (&Smakunbound
);
3175 defsubr (&Sfmakunbound
);
3177 defsubr (&Sfboundp
);
3179 defsubr (&Sdefalias
);
3180 defsubr (&Ssetplist
);
3181 defsubr (&Ssymbol_value
);
3183 defsubr (&Sdefault_boundp
);
3184 defsubr (&Sdefault_value
);
3185 defsubr (&Sset_default
);
3186 defsubr (&Ssetq_default
);
3187 defsubr (&Smake_variable_buffer_local
);
3188 defsubr (&Smake_local_variable
);
3189 defsubr (&Skill_local_variable
);
3190 defsubr (&Smake_variable_frame_local
);
3191 defsubr (&Slocal_variable_p
);
3192 defsubr (&Slocal_variable_if_set_p
);
3193 defsubr (&Svariable_binding_locus
);
3196 defsubr (&Snumber_to_string
);
3197 defsubr (&Sstring_to_number
);
3198 defsubr (&Seqlsign
);
3221 defsubr (&Sbyteorder
);
3222 defsubr (&Ssubr_arity
);
3223 defsubr (&Ssubr_name
);
3225 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3227 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3228 doc
: /* The largest value that is representable in a Lisp integer. */);
3229 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3231 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3232 doc
: /* The smallest value that is representable in a Lisp integer. */);
3233 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3240 #if defined(USG) && !defined(POSIX_SIGNALS)
3241 /* USG systems forget handlers when they are used;
3242 must reestablish each time */
3243 signal (signo
, arith_error
);
3246 /* VMS systems are like USG. */
3247 signal (signo
, arith_error
);
3251 #else /* not BSD4_1 */
3252 sigsetmask (SIGEMPTYMASK
);
3253 #endif /* not BSD4_1 */
3255 SIGNAL_THREAD_CHECK (signo
);
3256 Fsignal (Qarith_error
, Qnil
);
3262 /* Don't do this if just dumping out.
3263 We don't want to call `signal' in this case
3264 so that we don't have trouble with dumping
3265 signal-delivering routines in an inconsistent state. */
3269 #endif /* CANNOT_DUMP */
3270 signal (SIGFPE
, arith_error
);
3273 signal (SIGEMT
, arith_error
);
3277 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3278 (do not change this comment) */