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 || ASCII_CHAR_P (XINT (newelt
))
2098 || CHAR_BYTE8_P (XINT (newelt
)))
2099 SSET (array
, idxval
, XINT (newelt
));
2102 /* We must relocate the string data while converting it to
2104 int idxval_byte
, prev_bytes
, new_bytes
;
2105 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2106 unsigned char *origstr
= SDATA (array
), *str
;
2110 nchars
= SCHARS (array
);
2111 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2112 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2114 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2115 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2116 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2118 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2119 allocate_string_data (XSTRING (array
), nchars
,
2120 nbytes
+ new_bytes
- prev_bytes
);
2121 bcopy (str
, SDATA (array
), idxval_byte
);
2122 p1
= SDATA (array
) + idxval_byte
;
2125 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2126 nbytes
- (idxval_byte
+ prev_bytes
));
2128 clear_string_char_byte_cache ();
2135 /* Arithmetic functions */
2137 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2140 arithcompare (num1
, num2
, comparison
)
2141 Lisp_Object num1
, num2
;
2142 enum comparison comparison
;
2144 double f1
= 0, f2
= 0;
2147 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2148 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2150 if (FLOATP (num1
) || FLOATP (num2
))
2153 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2154 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2160 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2165 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2170 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2175 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2180 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2185 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2194 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2195 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2197 register Lisp_Object num1
, num2
;
2199 return arithcompare (num1
, num2
, equal
);
2202 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2203 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2205 register Lisp_Object num1
, num2
;
2207 return arithcompare (num1
, num2
, less
);
2210 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2211 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2213 register Lisp_Object num1
, num2
;
2215 return arithcompare (num1
, num2
, grtr
);
2218 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2219 doc
: /* Return t if first arg is less than or equal to second arg.
2220 Both must be numbers or markers. */)
2222 register Lisp_Object num1
, num2
;
2224 return arithcompare (num1
, num2
, less_or_equal
);
2227 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2228 doc
: /* Return t if first arg is greater than or equal to second arg.
2229 Both must be numbers or markers. */)
2231 register Lisp_Object num1
, num2
;
2233 return arithcompare (num1
, num2
, grtr_or_equal
);
2236 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2237 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2239 register Lisp_Object num1
, num2
;
2241 return arithcompare (num1
, num2
, notequal
);
2244 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2245 doc
: /* Return t if NUMBER is zero. */)
2247 register Lisp_Object number
;
2249 CHECK_NUMBER_OR_FLOAT (number
);
2251 if (FLOATP (number
))
2253 if (XFLOAT_DATA (number
) == 0.0)
2263 /* Convert between long values and pairs of Lisp integers. */
2269 unsigned long top
= i
>> 16;
2270 unsigned int bot
= i
& 0xFFFF;
2272 return make_number (bot
);
2273 if (top
== (unsigned long)-1 >> 16)
2274 return Fcons (make_number (-1), make_number (bot
));
2275 return Fcons (make_number (top
), make_number (bot
));
2282 Lisp_Object top
, bot
;
2289 return ((XINT (top
) << 16) | XINT (bot
));
2292 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2293 doc
: /* Return the decimal representation of NUMBER as a string.
2294 Uses a minus sign if negative.
2295 NUMBER may be an integer or a floating point number. */)
2299 char buffer
[VALBITS
];
2301 CHECK_NUMBER_OR_FLOAT (number
);
2303 if (FLOATP (number
))
2305 char pigbuf
[350]; /* see comments in float_to_string */
2307 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2308 return build_string (pigbuf
);
2311 if (sizeof (int) == sizeof (EMACS_INT
))
2312 sprintf (buffer
, "%d", XINT (number
));
2313 else if (sizeof (long) == sizeof (EMACS_INT
))
2314 sprintf (buffer
, "%ld", (long) XINT (number
));
2317 return build_string (buffer
);
2321 digit_to_number (character
, base
)
2322 int character
, base
;
2326 if (character
>= '0' && character
<= '9')
2327 digit
= character
- '0';
2328 else if (character
>= 'a' && character
<= 'z')
2329 digit
= character
- 'a' + 10;
2330 else if (character
>= 'A' && character
<= 'Z')
2331 digit
= character
- 'A' + 10;
2341 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2342 doc
: /* Parse STRING as a decimal number and return the number.
2343 This parses both integers and floating point numbers.
2344 It ignores leading spaces and tabs.
2346 If BASE, interpret STRING as a number in that base. If BASE isn't
2347 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2348 If the base used is not 10, floating point is not recognized. */)
2350 register Lisp_Object string
, base
;
2352 register unsigned char *p
;
2357 CHECK_STRING (string
);
2363 CHECK_NUMBER (base
);
2365 if (b
< 2 || b
> 16)
2366 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2369 /* Skip any whitespace at the front of the number. Some versions of
2370 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2372 while (*p
== ' ' || *p
== '\t')
2383 if (isfloat_string (p
) && b
== 10)
2384 val
= make_float (sign
* atof (p
));
2391 int digit
= digit_to_number (*p
++, b
);
2397 val
= make_fixnum_or_float (sign
* v
);
2417 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2418 int, Lisp_Object
*));
2419 extern Lisp_Object
fmod_float ();
2422 arith_driver (code
, nargs
, args
)
2425 register Lisp_Object
*args
;
2427 register Lisp_Object val
;
2428 register int argnum
;
2429 register EMACS_INT accum
= 0;
2430 register EMACS_INT next
;
2432 switch (SWITCH_ENUM_CAST (code
))
2450 for (argnum
= 0; argnum
< nargs
; argnum
++)
2452 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2454 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2457 return float_arith_driver ((double) accum
, argnum
, code
,
2460 next
= XINT (args
[argnum
]);
2461 switch (SWITCH_ENUM_CAST (code
))
2467 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2478 Fsignal (Qarith_error
, Qnil
);
2492 if (!argnum
|| next
> accum
)
2496 if (!argnum
|| next
< accum
)
2502 XSETINT (val
, accum
);
2507 #define isnan(x) ((x) != (x))
2510 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2512 register int argnum
;
2515 register Lisp_Object
*args
;
2517 register Lisp_Object val
;
2520 for (; argnum
< nargs
; argnum
++)
2522 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2523 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2527 next
= XFLOAT_DATA (val
);
2531 args
[argnum
] = val
; /* runs into a compiler bug. */
2532 next
= XINT (args
[argnum
]);
2534 switch (SWITCH_ENUM_CAST (code
))
2540 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2550 if (! IEEE_FLOATING_POINT
&& next
== 0)
2551 Fsignal (Qarith_error
, Qnil
);
2558 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2560 if (!argnum
|| isnan (next
) || next
> accum
)
2564 if (!argnum
|| isnan (next
) || next
< accum
)
2570 return make_float (accum
);
2574 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2575 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2576 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2581 return arith_driver (Aadd
, nargs
, args
);
2584 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2585 doc
: /* Negate number or subtract numbers or markers and return the result.
2586 With one arg, negates it. With more than one arg,
2587 subtracts all but the first from the first.
2588 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2593 return arith_driver (Asub
, nargs
, args
);
2596 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2597 doc
: /* Return product of any number of arguments, which are numbers or markers.
2598 usage: (* &rest NUMBERS-OR-MARKERS) */)
2603 return arith_driver (Amult
, nargs
, args
);
2606 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2607 doc
: /* Return first argument divided by all the remaining arguments.
2608 The arguments must be numbers or markers.
2609 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2615 for (argnum
= 2; argnum
< nargs
; argnum
++)
2616 if (FLOATP (args
[argnum
]))
2617 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2618 return arith_driver (Adiv
, nargs
, args
);
2621 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2622 doc
: /* Return remainder of X divided by Y.
2623 Both must be integers or markers. */)
2625 register Lisp_Object x
, y
;
2629 CHECK_NUMBER_COERCE_MARKER (x
);
2630 CHECK_NUMBER_COERCE_MARKER (y
);
2632 if (XFASTINT (y
) == 0)
2633 Fsignal (Qarith_error
, Qnil
);
2635 XSETINT (val
, XINT (x
) % XINT (y
));
2649 /* If the magnitude of the result exceeds that of the divisor, or
2650 the sign of the result does not agree with that of the dividend,
2651 iterate with the reduced value. This does not yield a
2652 particularly accurate result, but at least it will be in the
2653 range promised by fmod. */
2655 r
-= f2
* floor (r
/ f2
);
2656 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2660 #endif /* ! HAVE_FMOD */
2662 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2663 doc
: /* Return X modulo Y.
2664 The result falls between zero (inclusive) and Y (exclusive).
2665 Both X and Y must be numbers or markers. */)
2667 register Lisp_Object x
, y
;
2672 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2673 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2675 if (FLOATP (x
) || FLOATP (y
))
2676 return fmod_float (x
, y
);
2682 Fsignal (Qarith_error
, Qnil
);
2686 /* If the "remainder" comes out with the wrong sign, fix it. */
2687 if (i2
< 0 ? i1
> 0 : i1
< 0)
2694 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2695 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2696 The value is always a number; markers are converted to numbers.
2697 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2702 return arith_driver (Amax
, nargs
, args
);
2705 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2706 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2707 The value is always a number; markers are converted to numbers.
2708 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2713 return arith_driver (Amin
, nargs
, args
);
2716 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2717 doc
: /* Return bitwise-and of all the arguments.
2718 Arguments may be integers, or markers converted to integers.
2719 usage: (logand &rest INTS-OR-MARKERS) */)
2724 return arith_driver (Alogand
, nargs
, args
);
2727 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2728 doc
: /* Return bitwise-or of all the arguments.
2729 Arguments may be integers, or markers converted to integers.
2730 usage: (logior &rest INTS-OR-MARKERS) */)
2735 return arith_driver (Alogior
, nargs
, args
);
2738 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2739 doc
: /* Return bitwise-exclusive-or of all the arguments.
2740 Arguments may be integers, or markers converted to integers.
2741 usage: (logxor &rest INTS-OR-MARKERS) */)
2746 return arith_driver (Alogxor
, nargs
, args
);
2749 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2750 doc
: /* Return VALUE with its bits shifted left by COUNT.
2751 If COUNT is negative, shifting is actually to the right.
2752 In this case, the sign bit is duplicated. */)
2754 register Lisp_Object value
, count
;
2756 register Lisp_Object val
;
2758 CHECK_NUMBER (value
);
2759 CHECK_NUMBER (count
);
2761 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2763 else if (XINT (count
) > 0)
2764 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2765 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2766 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2768 XSETINT (val
, XINT (value
) >> -XINT (count
));
2772 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2773 doc
: /* Return VALUE with its bits shifted left by COUNT.
2774 If COUNT is negative, shifting is actually to the right.
2775 In this case, zeros are shifted in on the left. */)
2777 register Lisp_Object value
, count
;
2779 register Lisp_Object val
;
2781 CHECK_NUMBER (value
);
2782 CHECK_NUMBER (count
);
2784 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2786 else if (XINT (count
) > 0)
2787 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2788 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2791 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2795 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2796 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2797 Markers are converted to integers. */)
2799 register Lisp_Object number
;
2801 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2803 if (FLOATP (number
))
2804 return (make_float (1.0 + XFLOAT_DATA (number
)));
2806 XSETINT (number
, XINT (number
) + 1);
2810 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2811 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2812 Markers are converted to integers. */)
2814 register Lisp_Object number
;
2816 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2818 if (FLOATP (number
))
2819 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2821 XSETINT (number
, XINT (number
) - 1);
2825 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2826 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2828 register Lisp_Object number
;
2830 CHECK_NUMBER (number
);
2831 XSETINT (number
, ~XINT (number
));
2835 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2836 doc
: /* Return the byteorder for the machine.
2837 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2838 lowercase l) for small endian machines. */)
2841 unsigned i
= 0x04030201;
2842 int order
= *(char *)&i
== 1 ? 108 : 66;
2844 return make_number (order
);
2852 Lisp_Object error_tail
, arith_tail
;
2854 Qquote
= intern ("quote");
2855 Qlambda
= intern ("lambda");
2856 Qsubr
= intern ("subr");
2857 Qerror_conditions
= intern ("error-conditions");
2858 Qerror_message
= intern ("error-message");
2859 Qtop_level
= intern ("top-level");
2861 Qerror
= intern ("error");
2862 Qquit
= intern ("quit");
2863 Qwrong_type_argument
= intern ("wrong-type-argument");
2864 Qargs_out_of_range
= intern ("args-out-of-range");
2865 Qvoid_function
= intern ("void-function");
2866 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2867 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2868 Qvoid_variable
= intern ("void-variable");
2869 Qsetting_constant
= intern ("setting-constant");
2870 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2872 Qinvalid_function
= intern ("invalid-function");
2873 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2874 Qno_catch
= intern ("no-catch");
2875 Qend_of_file
= intern ("end-of-file");
2876 Qarith_error
= intern ("arith-error");
2877 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2878 Qend_of_buffer
= intern ("end-of-buffer");
2879 Qbuffer_read_only
= intern ("buffer-read-only");
2880 Qtext_read_only
= intern ("text-read-only");
2881 Qmark_inactive
= intern ("mark-inactive");
2883 Qlistp
= intern ("listp");
2884 Qconsp
= intern ("consp");
2885 Qsymbolp
= intern ("symbolp");
2886 Qkeywordp
= intern ("keywordp");
2887 Qintegerp
= intern ("integerp");
2888 Qnatnump
= intern ("natnump");
2889 Qwholenump
= intern ("wholenump");
2890 Qstringp
= intern ("stringp");
2891 Qarrayp
= intern ("arrayp");
2892 Qsequencep
= intern ("sequencep");
2893 Qbufferp
= intern ("bufferp");
2894 Qvectorp
= intern ("vectorp");
2895 Qchar_or_string_p
= intern ("char-or-string-p");
2896 Qmarkerp
= intern ("markerp");
2897 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2898 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2899 Qboundp
= intern ("boundp");
2900 Qfboundp
= intern ("fboundp");
2902 Qfloatp
= intern ("floatp");
2903 Qnumberp
= intern ("numberp");
2904 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2906 Qchar_table_p
= intern ("char-table-p");
2907 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2909 Qsubrp
= intern ("subrp");
2910 Qunevalled
= intern ("unevalled");
2911 Qmany
= intern ("many");
2913 Qcdr
= intern ("cdr");
2915 /* Handle automatic advice activation */
2916 Qad_advice_info
= intern ("ad-advice-info");
2917 Qad_activate_internal
= intern ("ad-activate-internal");
2919 error_tail
= Fcons (Qerror
, Qnil
);
2921 /* ERROR is used as a signaler for random errors for which nothing else is right */
2923 Fput (Qerror
, Qerror_conditions
,
2925 Fput (Qerror
, Qerror_message
,
2926 build_string ("error"));
2928 Fput (Qquit
, Qerror_conditions
,
2929 Fcons (Qquit
, Qnil
));
2930 Fput (Qquit
, Qerror_message
,
2931 build_string ("Quit"));
2933 Fput (Qwrong_type_argument
, Qerror_conditions
,
2934 Fcons (Qwrong_type_argument
, error_tail
));
2935 Fput (Qwrong_type_argument
, Qerror_message
,
2936 build_string ("Wrong type argument"));
2938 Fput (Qargs_out_of_range
, Qerror_conditions
,
2939 Fcons (Qargs_out_of_range
, error_tail
));
2940 Fput (Qargs_out_of_range
, Qerror_message
,
2941 build_string ("Args out of range"));
2943 Fput (Qvoid_function
, Qerror_conditions
,
2944 Fcons (Qvoid_function
, error_tail
));
2945 Fput (Qvoid_function
, Qerror_message
,
2946 build_string ("Symbol's function definition is void"));
2948 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2949 Fcons (Qcyclic_function_indirection
, error_tail
));
2950 Fput (Qcyclic_function_indirection
, Qerror_message
,
2951 build_string ("Symbol's chain of function indirections contains a loop"));
2953 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2954 Fcons (Qcyclic_variable_indirection
, error_tail
));
2955 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2956 build_string ("Symbol's chain of variable indirections contains a loop"));
2958 Qcircular_list
= intern ("circular-list");
2959 staticpro (&Qcircular_list
);
2960 Fput (Qcircular_list
, Qerror_conditions
,
2961 Fcons (Qcircular_list
, error_tail
));
2962 Fput (Qcircular_list
, Qerror_message
,
2963 build_string ("List contains a loop"));
2965 Fput (Qvoid_variable
, Qerror_conditions
,
2966 Fcons (Qvoid_variable
, error_tail
));
2967 Fput (Qvoid_variable
, Qerror_message
,
2968 build_string ("Symbol's value as variable is void"));
2970 Fput (Qsetting_constant
, Qerror_conditions
,
2971 Fcons (Qsetting_constant
, error_tail
));
2972 Fput (Qsetting_constant
, Qerror_message
,
2973 build_string ("Attempt to set a constant symbol"));
2975 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2976 Fcons (Qinvalid_read_syntax
, error_tail
));
2977 Fput (Qinvalid_read_syntax
, Qerror_message
,
2978 build_string ("Invalid read syntax"));
2980 Fput (Qinvalid_function
, Qerror_conditions
,
2981 Fcons (Qinvalid_function
, error_tail
));
2982 Fput (Qinvalid_function
, Qerror_message
,
2983 build_string ("Invalid function"));
2985 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2986 Fcons (Qwrong_number_of_arguments
, error_tail
));
2987 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2988 build_string ("Wrong number of arguments"));
2990 Fput (Qno_catch
, Qerror_conditions
,
2991 Fcons (Qno_catch
, error_tail
));
2992 Fput (Qno_catch
, Qerror_message
,
2993 build_string ("No catch for tag"));
2995 Fput (Qend_of_file
, Qerror_conditions
,
2996 Fcons (Qend_of_file
, error_tail
));
2997 Fput (Qend_of_file
, Qerror_message
,
2998 build_string ("End of file during parsing"));
3000 arith_tail
= Fcons (Qarith_error
, error_tail
);
3001 Fput (Qarith_error
, Qerror_conditions
,
3003 Fput (Qarith_error
, Qerror_message
,
3004 build_string ("Arithmetic error"));
3006 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3007 Fcons (Qbeginning_of_buffer
, error_tail
));
3008 Fput (Qbeginning_of_buffer
, Qerror_message
,
3009 build_string ("Beginning of buffer"));
3011 Fput (Qend_of_buffer
, Qerror_conditions
,
3012 Fcons (Qend_of_buffer
, error_tail
));
3013 Fput (Qend_of_buffer
, Qerror_message
,
3014 build_string ("End of buffer"));
3016 Fput (Qbuffer_read_only
, Qerror_conditions
,
3017 Fcons (Qbuffer_read_only
, error_tail
));
3018 Fput (Qbuffer_read_only
, Qerror_message
,
3019 build_string ("Buffer is read-only"));
3021 Fput (Qtext_read_only
, Qerror_conditions
,
3022 Fcons (Qtext_read_only
, error_tail
));
3023 Fput (Qtext_read_only
, Qerror_message
,
3024 build_string ("Text is read-only"));
3026 Qrange_error
= intern ("range-error");
3027 Qdomain_error
= intern ("domain-error");
3028 Qsingularity_error
= intern ("singularity-error");
3029 Qoverflow_error
= intern ("overflow-error");
3030 Qunderflow_error
= intern ("underflow-error");
3032 Fput (Qdomain_error
, Qerror_conditions
,
3033 Fcons (Qdomain_error
, arith_tail
));
3034 Fput (Qdomain_error
, Qerror_message
,
3035 build_string ("Arithmetic domain error"));
3037 Fput (Qrange_error
, Qerror_conditions
,
3038 Fcons (Qrange_error
, arith_tail
));
3039 Fput (Qrange_error
, Qerror_message
,
3040 build_string ("Arithmetic range error"));
3042 Fput (Qsingularity_error
, Qerror_conditions
,
3043 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3044 Fput (Qsingularity_error
, Qerror_message
,
3045 build_string ("Arithmetic singularity error"));
3047 Fput (Qoverflow_error
, Qerror_conditions
,
3048 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3049 Fput (Qoverflow_error
, Qerror_message
,
3050 build_string ("Arithmetic overflow error"));
3052 Fput (Qunderflow_error
, Qerror_conditions
,
3053 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3054 Fput (Qunderflow_error
, Qerror_message
,
3055 build_string ("Arithmetic underflow error"));
3057 staticpro (&Qrange_error
);
3058 staticpro (&Qdomain_error
);
3059 staticpro (&Qsingularity_error
);
3060 staticpro (&Qoverflow_error
);
3061 staticpro (&Qunderflow_error
);
3065 staticpro (&Qquote
);
3066 staticpro (&Qlambda
);
3068 staticpro (&Qunbound
);
3069 staticpro (&Qerror_conditions
);
3070 staticpro (&Qerror_message
);
3071 staticpro (&Qtop_level
);
3073 staticpro (&Qerror
);
3075 staticpro (&Qwrong_type_argument
);
3076 staticpro (&Qargs_out_of_range
);
3077 staticpro (&Qvoid_function
);
3078 staticpro (&Qcyclic_function_indirection
);
3079 staticpro (&Qcyclic_variable_indirection
);
3080 staticpro (&Qvoid_variable
);
3081 staticpro (&Qsetting_constant
);
3082 staticpro (&Qinvalid_read_syntax
);
3083 staticpro (&Qwrong_number_of_arguments
);
3084 staticpro (&Qinvalid_function
);
3085 staticpro (&Qno_catch
);
3086 staticpro (&Qend_of_file
);
3087 staticpro (&Qarith_error
);
3088 staticpro (&Qbeginning_of_buffer
);
3089 staticpro (&Qend_of_buffer
);
3090 staticpro (&Qbuffer_read_only
);
3091 staticpro (&Qtext_read_only
);
3092 staticpro (&Qmark_inactive
);
3094 staticpro (&Qlistp
);
3095 staticpro (&Qconsp
);
3096 staticpro (&Qsymbolp
);
3097 staticpro (&Qkeywordp
);
3098 staticpro (&Qintegerp
);
3099 staticpro (&Qnatnump
);
3100 staticpro (&Qwholenump
);
3101 staticpro (&Qstringp
);
3102 staticpro (&Qarrayp
);
3103 staticpro (&Qsequencep
);
3104 staticpro (&Qbufferp
);
3105 staticpro (&Qvectorp
);
3106 staticpro (&Qchar_or_string_p
);
3107 staticpro (&Qmarkerp
);
3108 staticpro (&Qbuffer_or_string_p
);
3109 staticpro (&Qinteger_or_marker_p
);
3110 staticpro (&Qfloatp
);
3111 staticpro (&Qnumberp
);
3112 staticpro (&Qnumber_or_marker_p
);
3113 staticpro (&Qchar_table_p
);
3114 staticpro (&Qvector_or_char_table_p
);
3115 staticpro (&Qsubrp
);
3117 staticpro (&Qunevalled
);
3119 staticpro (&Qboundp
);
3120 staticpro (&Qfboundp
);
3122 staticpro (&Qad_advice_info
);
3123 staticpro (&Qad_activate_internal
);
3125 /* Types that type-of returns. */
3126 Qinteger
= intern ("integer");
3127 Qsymbol
= intern ("symbol");
3128 Qstring
= intern ("string");
3129 Qcons
= intern ("cons");
3130 Qmarker
= intern ("marker");
3131 Qoverlay
= intern ("overlay");
3132 Qfloat
= intern ("float");
3133 Qwindow_configuration
= intern ("window-configuration");
3134 Qprocess
= intern ("process");
3135 Qwindow
= intern ("window");
3136 /* Qsubr = intern ("subr"); */
3137 Qcompiled_function
= intern ("compiled-function");
3138 Qbuffer
= intern ("buffer");
3139 Qframe
= intern ("frame");
3140 Qvector
= intern ("vector");
3141 Qchar_table
= intern ("char-table");
3142 Qbool_vector
= intern ("bool-vector");
3143 Qhash_table
= intern ("hash-table");
3145 staticpro (&Qinteger
);
3146 staticpro (&Qsymbol
);
3147 staticpro (&Qstring
);
3149 staticpro (&Qmarker
);
3150 staticpro (&Qoverlay
);
3151 staticpro (&Qfloat
);
3152 staticpro (&Qwindow_configuration
);
3153 staticpro (&Qprocess
);
3154 staticpro (&Qwindow
);
3155 /* staticpro (&Qsubr); */
3156 staticpro (&Qcompiled_function
);
3157 staticpro (&Qbuffer
);
3158 staticpro (&Qframe
);
3159 staticpro (&Qvector
);
3160 staticpro (&Qchar_table
);
3161 staticpro (&Qbool_vector
);
3162 staticpro (&Qhash_table
);
3164 defsubr (&Sindirect_variable
);
3165 defsubr (&Sinteractive_form
);
3168 defsubr (&Stype_of
);
3173 defsubr (&Sintegerp
);
3174 defsubr (&Sinteger_or_marker_p
);
3175 defsubr (&Snumberp
);
3176 defsubr (&Snumber_or_marker_p
);
3178 defsubr (&Snatnump
);
3179 defsubr (&Ssymbolp
);
3180 defsubr (&Skeywordp
);
3181 defsubr (&Sstringp
);
3182 defsubr (&Smultibyte_string_p
);
3183 defsubr (&Svectorp
);
3184 defsubr (&Schar_table_p
);
3185 defsubr (&Svector_or_char_table_p
);
3186 defsubr (&Sbool_vector_p
);
3188 defsubr (&Ssequencep
);
3189 defsubr (&Sbufferp
);
3190 defsubr (&Smarkerp
);
3192 defsubr (&Sbyte_code_function_p
);
3193 defsubr (&Schar_or_string_p
);
3196 defsubr (&Scar_safe
);
3197 defsubr (&Scdr_safe
);
3200 defsubr (&Ssymbol_function
);
3201 defsubr (&Sindirect_function
);
3202 defsubr (&Ssymbol_plist
);
3203 defsubr (&Ssymbol_name
);
3204 defsubr (&Smakunbound
);
3205 defsubr (&Sfmakunbound
);
3207 defsubr (&Sfboundp
);
3209 defsubr (&Sdefalias
);
3210 defsubr (&Ssetplist
);
3211 defsubr (&Ssymbol_value
);
3213 defsubr (&Sdefault_boundp
);
3214 defsubr (&Sdefault_value
);
3215 defsubr (&Sset_default
);
3216 defsubr (&Ssetq_default
);
3217 defsubr (&Smake_variable_buffer_local
);
3218 defsubr (&Smake_local_variable
);
3219 defsubr (&Skill_local_variable
);
3220 defsubr (&Smake_variable_frame_local
);
3221 defsubr (&Slocal_variable_p
);
3222 defsubr (&Slocal_variable_if_set_p
);
3223 defsubr (&Svariable_binding_locus
);
3226 defsubr (&Snumber_to_string
);
3227 defsubr (&Sstring_to_number
);
3228 defsubr (&Seqlsign
);
3251 defsubr (&Sbyteorder
);
3252 defsubr (&Ssubr_arity
);
3253 defsubr (&Ssubr_name
);
3255 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3257 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3258 doc
: /* The largest value that is representable in a Lisp integer. */);
3259 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3261 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3262 doc
: /* The smallest value that is representable in a Lisp integer. */);
3263 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3270 #if defined(USG) && !defined(POSIX_SIGNALS)
3271 /* USG systems forget handlers when they are used;
3272 must reestablish each time */
3273 signal (signo
, arith_error
);
3276 /* VMS systems are like USG. */
3277 signal (signo
, arith_error
);
3281 #else /* not BSD4_1 */
3282 sigsetmask (SIGEMPTYMASK
);
3283 #endif /* not BSD4_1 */
3285 SIGNAL_THREAD_CHECK (signo
);
3286 Fsignal (Qarith_error
, Qnil
);
3292 /* Don't do this if just dumping out.
3293 We don't want to call `signal' in this case
3294 so that we don't have trouble with dumping
3295 signal-delivering routines in an inconsistent state. */
3299 #endif /* CANNOT_DUMP */
3300 signal (SIGFPE
, arith_error
);
3303 signal (SIGEMT
, arith_error
);
3307 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3308 (do not change this comment) */