1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, 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"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
49 /* Work around a problem that happens because math.h on hpux 7
50 defines two static variables--which, in Emacs, are not really static,
51 because `static' is defined as nothing. The problem is that they are
52 here, in floatfns.c, and in lread.c.
53 These macros prevent the name conflict. */
54 #if defined (HPUX) && !defined (HPUX8)
55 #define _MAXLDBL data_c_maxldbl
56 #define _NMAXLDBL data_c_nmaxldbl
62 extern double atof ();
65 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
66 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
67 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
68 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
69 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
70 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
71 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
72 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
73 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
74 Lisp_Object Qtext_read_only
;
76 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
77 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
78 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
79 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
80 Lisp_Object Qboundp
, Qfboundp
;
81 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
84 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
86 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
87 Lisp_Object Qoverflow_error
, Qunderflow_error
;
90 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
93 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
94 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
96 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
97 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
98 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
100 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
102 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
106 circular_list_error (list
)
109 xsignal (Qcircular_list
, list
);
114 wrong_type_argument (predicate
, value
)
115 register Lisp_Object predicate
, value
;
117 /* If VALUE is not even a valid Lisp object, abort here
118 where we can get a backtrace showing where it came from. */
119 if ((unsigned int) XTYPE (value
) >= Lisp_Type_Limit
)
122 xsignal2 (Qwrong_type_argument
, predicate
, value
);
128 error ("Attempt to modify read-only object");
132 args_out_of_range (a1
, a2
)
135 xsignal2 (Qargs_out_of_range
, a1
, a2
);
139 args_out_of_range_3 (a1
, a2
, a3
)
140 Lisp_Object a1
, a2
, a3
;
142 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
145 /* On some machines, XINT needs a temporary location.
146 Here it is, in case it is needed. */
148 int sign_extend_temp
;
150 /* On a few machines, XINT can only be done by calling this. */
153 sign_extend_lisp_int (num
)
156 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
157 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
159 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
162 /* Data type predicates */
164 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
165 doc
: /* Return t if the two args are the same Lisp object. */)
167 Lisp_Object obj1
, obj2
;
174 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
175 doc
: /* Return t if OBJECT is nil. */)
184 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
185 doc
: /* Return a symbol representing the type of OBJECT.
186 The symbol returned names the object's basic type;
187 for example, (type-of 1) returns `integer'. */)
191 switch (XTYPE (object
))
206 switch (XMISCTYPE (object
))
208 case Lisp_Misc_Marker
:
210 case Lisp_Misc_Overlay
:
212 case Lisp_Misc_Float
:
217 case Lisp_Vectorlike
:
218 if (WINDOW_CONFIGURATIONP (object
))
219 return Qwindow_configuration
;
220 if (PROCESSP (object
))
222 if (WINDOWP (object
))
226 if (COMPILEDP (object
))
227 return Qcompiled_function
;
228 if (BUFFERP (object
))
230 if (CHAR_TABLE_P (object
))
232 if (BOOL_VECTOR_P (object
))
236 if (HASH_TABLE_P (object
))
248 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
249 doc
: /* Return t if OBJECT is a cons cell. */)
258 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
259 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
268 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
269 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
270 Otherwise, return nil. */)
274 if (CONSP (object
) || NILP (object
))
279 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
290 doc
: /* Return t if OBJECT is a symbol. */)
294 if (SYMBOLP (object
))
299 /* Define this in C to avoid unnecessarily consing up the symbol
301 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
302 doc
: /* Return t if OBJECT is a keyword.
303 This means that it is a symbol with a print name beginning with `:'
304 interned in the initial obarray. */)
309 && SREF (SYMBOL_NAME (object
), 0) == ':'
310 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
315 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is a vector. */)
320 if (VECTORP (object
))
325 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
326 doc
: /* Return t if OBJECT is a string. */)
330 if (STRINGP (object
))
335 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
337 doc
: /* Return t if OBJECT is a multibyte string. */)
341 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
346 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
347 doc
: /* Return t if OBJECT is a char-table. */)
351 if (CHAR_TABLE_P (object
))
356 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
357 Svector_or_char_table_p
, 1, 1, 0,
358 doc
: /* Return t if OBJECT is a char-table or vector. */)
362 if (VECTORP (object
) || CHAR_TABLE_P (object
))
367 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a bool-vector. */)
372 if (BOOL_VECTOR_P (object
))
377 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
388 doc
: /* Return t if OBJECT is a sequence (list or array). */)
390 register Lisp_Object object
;
392 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
397 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is an editor buffer. */)
402 if (BUFFERP (object
))
407 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
412 if (MARKERP (object
))
417 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a built-in function. */)
427 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
429 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
433 if (COMPILEDP (object
))
438 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
439 doc
: /* Return t if OBJECT is a character or a string. */)
441 register Lisp_Object object
;
443 if (CHARACTERP (object
) || STRINGP (object
))
448 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is an integer. */)
453 if (INTEGERP (object
))
458 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
461 register Lisp_Object object
;
463 if (MARKERP (object
) || INTEGERP (object
))
468 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is a nonnegative integer. */)
473 if (NATNUMP (object
))
478 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
479 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
483 if (NUMBERP (object
))
489 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
490 Snumber_or_marker_p
, 1, 1, 0,
491 doc
: /* Return t if OBJECT is a number or a marker. */)
495 if (NUMBERP (object
) || MARKERP (object
))
500 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a floating point number. */)
511 /* Extract and set components of lists */
513 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
514 doc
: /* Return the car of LIST. If arg is nil, return nil.
515 Error if arg is not nil and not a cons cell. See also `car-safe'.
517 See Info node `(elisp)Cons Cells' for a discussion of related basic
518 Lisp concepts such as car, cdr, cons cell and list. */)
520 register Lisp_Object list
;
525 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
526 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
530 return CAR_SAFE (object
);
533 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
534 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
535 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
537 See Info node `(elisp)Cons Cells' for a discussion of related basic
538 Lisp concepts such as cdr, car, cons cell and list. */)
540 register Lisp_Object list
;
545 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
546 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
550 return CDR_SAFE (object
);
553 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
554 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
556 register Lisp_Object cell
, newcar
;
560 XSETCAR (cell
, newcar
);
564 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
565 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
567 register Lisp_Object cell
, newcdr
;
571 XSETCDR (cell
, newcdr
);
575 /* Extract and set components of symbols */
577 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
578 doc
: /* Return t if SYMBOL's value is not void. */)
580 register Lisp_Object symbol
;
582 Lisp_Object valcontents
;
583 CHECK_SYMBOL (symbol
);
585 valcontents
= SYMBOL_VALUE (symbol
);
587 if (BUFFER_LOCAL_VALUEP (valcontents
))
588 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
590 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
593 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
594 doc
: /* Return t if SYMBOL's function definition is not void. */)
596 register Lisp_Object symbol
;
598 CHECK_SYMBOL (symbol
);
599 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
602 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
603 doc
: /* Make SYMBOL's value be void.
606 register Lisp_Object symbol
;
608 CHECK_SYMBOL (symbol
);
609 if (SYMBOL_CONSTANT_P (symbol
))
610 xsignal1 (Qsetting_constant
, symbol
);
611 Fset (symbol
, Qunbound
);
615 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
616 doc
: /* Make SYMBOL's function definition be void.
619 register Lisp_Object symbol
;
621 CHECK_SYMBOL (symbol
);
622 if (NILP (symbol
) || EQ (symbol
, Qt
))
623 xsignal1 (Qsetting_constant
, symbol
);
624 XSYMBOL (symbol
)->function
= Qunbound
;
628 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
629 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
);
634 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
635 return XSYMBOL (symbol
)->function
;
636 xsignal1 (Qvoid_function
, symbol
);
639 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
640 doc
: /* Return SYMBOL's property list. */)
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
);
645 return XSYMBOL (symbol
)->plist
;
648 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
649 doc
: /* Return SYMBOL's name, a string. */)
651 register Lisp_Object symbol
;
653 register Lisp_Object name
;
655 CHECK_SYMBOL (symbol
);
656 name
= SYMBOL_NAME (symbol
);
660 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
661 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
663 register Lisp_Object symbol
, definition
;
665 register Lisp_Object function
;
667 CHECK_SYMBOL (symbol
);
668 if (NILP (symbol
) || EQ (symbol
, Qt
))
669 xsignal1 (Qsetting_constant
, symbol
);
671 function
= XSYMBOL (symbol
)->function
;
673 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
674 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
676 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
677 Fput (symbol
, Qautoload
, XCDR (function
));
679 XSYMBOL (symbol
)->function
= definition
;
680 /* Handle automatic advice activation */
681 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
683 call2 (Qad_activate_internal
, symbol
, Qnil
);
684 definition
= XSYMBOL (symbol
)->function
;
689 extern Lisp_Object Qfunction_documentation
;
691 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
692 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
693 Associates the function with the current load file, if any.
694 The optional third argument DOCSTRING specifies the documentation string
695 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
696 determined by DEFINITION. */)
697 (symbol
, definition
, docstring
)
698 register Lisp_Object symbol
, definition
, docstring
;
700 CHECK_SYMBOL (symbol
);
701 if (CONSP (XSYMBOL (symbol
)->function
)
702 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
703 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
704 definition
= Ffset (symbol
, definition
);
705 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
706 if (!NILP (docstring
))
707 Fput (symbol
, Qfunction_documentation
, docstring
);
711 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
712 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
714 register Lisp_Object symbol
, newplist
;
716 CHECK_SYMBOL (symbol
);
717 XSYMBOL (symbol
)->plist
= newplist
;
721 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
722 doc
: /* Return minimum and maximum number of args allowed for SUBR.
723 SUBR must be a built-in function.
724 The returned value is a pair (MIN . MAX). MIN is the minimum number
725 of args. MAX is the maximum number or the symbol `many', for a
726 function with `&rest' args, or `unevalled' for a special form. */)
730 short minargs
, maxargs
;
732 minargs
= XSUBR (subr
)->min_args
;
733 maxargs
= XSUBR (subr
)->max_args
;
735 return Fcons (make_number (minargs
), Qmany
);
736 else if (maxargs
== UNEVALLED
)
737 return Fcons (make_number (minargs
), Qunevalled
);
739 return Fcons (make_number (minargs
), make_number (maxargs
));
742 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
743 doc
: /* Return name of subroutine SUBR.
744 SUBR must be a built-in function. */)
750 name
= XSUBR (subr
)->symbol_name
;
751 return make_string (name
, strlen (name
));
754 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
755 doc
: /* Return the interactive form of CMD or nil if none.
756 If CMD is not a command, the return value is nil.
757 Value, if non-nil, is a list \(interactive SPEC). */)
761 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
763 if (NILP (fun
) || EQ (fun
, Qunbound
))
766 /* Use an `interactive-form' property if present, analogous to the
767 function-documentation property. */
769 while (SYMBOLP (fun
))
771 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
775 fun
= Fsymbol_function (fun
);
780 char *spec
= XSUBR (fun
)->intspec
;
782 return list2 (Qinteractive
,
783 (*spec
!= '(') ? build_string (spec
) :
784 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
786 else if (COMPILEDP (fun
))
788 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
789 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
791 else if (CONSP (fun
))
793 Lisp_Object funcar
= XCAR (fun
);
794 if (EQ (funcar
, Qlambda
))
795 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
796 else if (EQ (funcar
, Qautoload
))
800 do_autoload (fun
, cmd
);
802 return Finteractive_form (cmd
);
809 /***********************************************************************
810 Getting and Setting Values of Symbols
811 ***********************************************************************/
813 /* Return the symbol holding SYMBOL's value. Signal
814 `cyclic-variable-indirection' if SYMBOL's chain of variable
815 indirections contains a loop. */
818 indirect_variable (symbol
)
821 Lisp_Object tortoise
, hare
;
823 hare
= tortoise
= symbol
;
825 while (XSYMBOL (hare
)->indirect_variable
)
827 hare
= XSYMBOL (hare
)->value
;
828 if (!XSYMBOL (hare
)->indirect_variable
)
831 hare
= XSYMBOL (hare
)->value
;
832 tortoise
= XSYMBOL (tortoise
)->value
;
834 if (EQ (hare
, tortoise
))
835 xsignal1 (Qcyclic_variable_indirection
, symbol
);
842 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
843 doc
: /* Return the variable at the end of OBJECT's variable chain.
844 If OBJECT is a symbol, follow all variable indirections and return the final
845 variable. If OBJECT is not a symbol, just return it.
846 Signal a cyclic-variable-indirection error if there is a loop in the
847 variable chain of symbols. */)
851 if (SYMBOLP (object
))
852 object
= indirect_variable (object
);
857 /* Given the raw contents of a symbol value cell,
858 return the Lisp value of the symbol.
859 This does not handle buffer-local variables; use
860 swap_in_symval_forwarding for that. */
863 do_symval_forwarding (valcontents
)
864 register Lisp_Object valcontents
;
866 register Lisp_Object val
;
868 if (MISCP (valcontents
))
869 switch (XMISCTYPE (valcontents
))
871 case Lisp_Misc_Intfwd
:
872 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
875 case Lisp_Misc_Boolfwd
:
876 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
878 case Lisp_Misc_Objfwd
:
879 return *XOBJFWD (valcontents
)->objvar
;
881 case Lisp_Misc_Buffer_Objfwd
:
882 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
883 return PER_BUFFER_VALUE (current_buffer
, offset
);
885 case Lisp_Misc_Kboard_Objfwd
:
886 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
887 /* We used to simply use current_kboard here, but from Lisp
888 code, it's value is often unexpected. It seems nicer to
889 allow constructions like this to work as intuitively expected:
891 (with-selected-frame frame
892 (define-key local-function-map "\eOP" [f1]))
894 On the other hand, this affects the semantics of
895 last-command and real-last-command, and people may rely on
896 that. I took a quick look at the Lisp codebase, and I
897 don't think anything will break. --lorentey */
898 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
903 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
904 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
905 buffer-independent contents of the value cell: forwarded just one
906 step past the buffer-localness.
908 BUF non-zero means set the value in buffer BUF instead of the
909 current buffer. This only plays a role for per-buffer variables. */
912 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
914 register Lisp_Object valcontents
, newval
;
917 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
920 switch (XMISCTYPE (valcontents
))
922 case Lisp_Misc_Intfwd
:
923 CHECK_NUMBER (newval
);
924 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
925 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
926 error ("Value out of range for variable `%s'",
927 SDATA (SYMBOL_NAME (symbol
)));
930 case Lisp_Misc_Boolfwd
:
931 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
934 case Lisp_Misc_Objfwd
:
935 *XOBJFWD (valcontents
)->objvar
= newval
;
937 /* If this variable is a default for something stored
938 in the buffer itself, such as default-fill-column,
939 find the buffers that don't have local values for it
941 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
942 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
944 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
945 - (char *) &buffer_defaults
);
946 int idx
= PER_BUFFER_IDX (offset
);
953 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
958 buf
= Fcdr (XCAR (tail
));
959 if (!BUFFERP (buf
)) continue;
962 if (! PER_BUFFER_VALUE_P (b
, idx
))
963 PER_BUFFER_VALUE (b
, offset
) = newval
;
968 case Lisp_Misc_Buffer_Objfwd
:
970 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
973 type
= PER_BUFFER_TYPE (offset
);
974 if (! NILP (type
) && ! NILP (newval
)
975 && XTYPE (newval
) != XINT (type
))
976 buffer_slot_type_mismatch (offset
);
979 buf
= current_buffer
;
980 PER_BUFFER_VALUE (buf
, offset
) = newval
;
984 case Lisp_Misc_Kboard_Objfwd
:
986 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
987 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
988 *(Lisp_Object
*) p
= newval
;
999 valcontents
= SYMBOL_VALUE (symbol
);
1000 if (BUFFER_LOCAL_VALUEP (valcontents
))
1001 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1003 SET_SYMBOL_VALUE (symbol
, newval
);
1007 /* Set up SYMBOL to refer to its global binding.
1008 This makes it safe to alter the status of other bindings. */
1011 swap_in_global_binding (symbol
)
1014 Lisp_Object valcontents
, cdr
;
1016 valcontents
= SYMBOL_VALUE (symbol
);
1017 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1019 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1021 /* Unload the previously loaded binding. */
1022 Fsetcdr (XCAR (cdr
),
1023 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1025 /* Select the global binding in the symbol. */
1027 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1029 /* Indicate that the global binding is set up now. */
1030 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1031 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1032 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1033 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1036 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1037 VALCONTENTS is the contents of its value cell,
1038 which points to a struct Lisp_Buffer_Local_Value.
1040 Return the value forwarded one step past the buffer-local stage.
1041 This could be another forwarding pointer. */
1044 swap_in_symval_forwarding (symbol
, valcontents
)
1045 Lisp_Object symbol
, valcontents
;
1047 register Lisp_Object tem1
;
1049 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1052 || current_buffer
!= XBUFFER (tem1
)
1053 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1054 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1056 if (XSYMBOL (symbol
)->indirect_variable
)
1057 symbol
= indirect_variable (symbol
);
1059 /* Unload the previously loaded binding. */
1060 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1062 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1063 /* Choose the new binding. */
1064 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1065 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1066 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1069 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1070 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1072 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1074 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1077 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1079 /* Load the new binding. */
1080 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1081 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1082 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1083 store_symval_forwarding (symbol
,
1084 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1087 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1090 /* Find the value of a symbol, returning Qunbound if it's not bound.
1091 This is helpful for code which just wants to get a variable's value
1092 if it has one, without signaling an error.
1093 Note that it must not be possible to quit
1094 within this function. Great care is required for this. */
1097 find_symbol_value (symbol
)
1100 register Lisp_Object valcontents
;
1101 register Lisp_Object val
;
1103 CHECK_SYMBOL (symbol
);
1104 valcontents
= SYMBOL_VALUE (symbol
);
1106 if (BUFFER_LOCAL_VALUEP (valcontents
))
1107 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1109 if (MISCP (valcontents
))
1111 switch (XMISCTYPE (valcontents
))
1113 case Lisp_Misc_Intfwd
:
1114 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1117 case Lisp_Misc_Boolfwd
:
1118 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1120 case Lisp_Misc_Objfwd
:
1121 return *XOBJFWD (valcontents
)->objvar
;
1123 case Lisp_Misc_Buffer_Objfwd
:
1124 return PER_BUFFER_VALUE (current_buffer
,
1125 XBUFFER_OBJFWD (valcontents
)->offset
);
1127 case Lisp_Misc_Kboard_Objfwd
:
1128 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1129 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1136 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1137 doc
: /* Return SYMBOL's value. Error if that is void. */)
1143 val
= find_symbol_value (symbol
);
1144 if (!EQ (val
, Qunbound
))
1147 xsignal1 (Qvoid_variable
, symbol
);
1150 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1151 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1153 register Lisp_Object symbol
, newval
;
1155 return set_internal (symbol
, newval
, current_buffer
, 0);
1158 /* Return 1 if SYMBOL currently has a let-binding
1159 which was made in the buffer that is now current. */
1162 let_shadows_buffer_binding_p (symbol
)
1165 volatile struct specbinding
*p
;
1167 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1169 && CONSP (p
->symbol
))
1171 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1172 if ((EQ (symbol
, let_bound_symbol
)
1173 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1174 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1175 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1179 return p
>= specpdl
;
1182 /* Store the value NEWVAL into SYMBOL.
1183 If buffer-locality is an issue, BUF specifies which buffer to use.
1184 (0 stands for the current buffer.)
1186 If BINDFLAG is zero, then if this symbol is supposed to become
1187 local in every buffer where it is set, then we make it local.
1188 If BINDFLAG is nonzero, we don't do that. */
1191 set_internal (symbol
, newval
, buf
, bindflag
)
1192 register Lisp_Object symbol
, newval
;
1196 int voide
= EQ (newval
, Qunbound
);
1198 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1201 buf
= current_buffer
;
1203 /* If restoring in a dead buffer, do nothing. */
1204 if (NILP (buf
->name
))
1207 CHECK_SYMBOL (symbol
);
1208 if (SYMBOL_CONSTANT_P (symbol
)
1209 && (NILP (Fkeywordp (symbol
))
1210 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1211 xsignal1 (Qsetting_constant
, symbol
);
1213 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1215 if (BUFFER_OBJFWDP (valcontents
))
1217 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1218 int idx
= PER_BUFFER_IDX (offset
);
1221 && !let_shadows_buffer_binding_p (symbol
))
1222 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1224 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1226 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1227 if (XSYMBOL (symbol
)->indirect_variable
)
1228 symbol
= indirect_variable (symbol
);
1230 /* What binding is loaded right now? */
1231 current_alist_element
1232 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1234 /* If the current buffer is not the buffer whose binding is
1235 loaded, or if there may be frame-local bindings and the frame
1236 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1237 the default binding is loaded, the loaded binding may be the
1239 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1240 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1241 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1242 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1243 || (BUFFER_LOCAL_VALUEP (valcontents
)
1244 && EQ (XCAR (current_alist_element
),
1245 current_alist_element
)))
1247 /* The currently loaded binding is not necessarily valid.
1248 We need to unload it, and choose a new binding. */
1250 /* Write out `realvalue' to the old loaded binding. */
1251 Fsetcdr (current_alist_element
,
1252 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1254 /* Find the new binding. */
1255 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1256 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1257 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1261 /* This buffer still sees the default value. */
1263 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1264 or if this is `let' rather than `set',
1265 make CURRENT-ALIST-ELEMENT point to itself,
1266 indicating that we're seeing the default value.
1267 Likewise if the variable has been let-bound
1268 in the current buffer. */
1269 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1270 || let_shadows_buffer_binding_p (symbol
))
1272 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1274 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1275 tem1
= Fassq (symbol
,
1276 XFRAME (selected_frame
)->param_alist
);
1279 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1281 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1283 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1284 and we're not within a let that was made for this buffer,
1285 create a new buffer-local binding for the variable.
1286 That means, give this buffer a new assoc for a local value
1287 and load that binding. */
1290 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1291 buf
->local_var_alist
1292 = Fcons (tem1
, buf
->local_var_alist
);
1296 /* Record which binding is now loaded. */
1297 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1299 /* Set `buffer' and `frame' slots for the binding now loaded. */
1300 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1301 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1303 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1306 /* If storing void (making the symbol void), forward only through
1307 buffer-local indicator, not through Lisp_Objfwd, etc. */
1309 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1311 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1313 /* If we just set a variable whose current binding is frame-local,
1314 store the new value in the frame parameter too. */
1316 if (BUFFER_LOCAL_VALUEP (valcontents
))
1318 /* What binding is loaded right now? */
1319 current_alist_element
1320 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1322 /* If the current buffer is not the buffer whose binding is
1323 loaded, or if there may be frame-local bindings and the frame
1324 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1325 the default binding is loaded, the loaded binding may be the
1327 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1328 XSETCDR (current_alist_element
, newval
);
1334 /* Access or set a buffer-local symbol's default value. */
1336 /* Return the default value of SYMBOL, but don't check for voidness.
1337 Return Qunbound if it is void. */
1340 default_value (symbol
)
1343 register Lisp_Object valcontents
;
1345 CHECK_SYMBOL (symbol
);
1346 valcontents
= SYMBOL_VALUE (symbol
);
1348 /* For a built-in buffer-local variable, get the default value
1349 rather than letting do_symval_forwarding get the current value. */
1350 if (BUFFER_OBJFWDP (valcontents
))
1352 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1353 if (PER_BUFFER_IDX (offset
) != 0)
1354 return PER_BUFFER_DEFAULT (offset
);
1357 /* Handle user-created local variables. */
1358 if (BUFFER_LOCAL_VALUEP (valcontents
))
1360 /* If var is set up for a buffer that lacks a local value for it,
1361 the current value is nominally the default value.
1362 But the `realvalue' slot may be more up to date, since
1363 ordinary setq stores just that slot. So use that. */
1364 Lisp_Object current_alist_element
, alist_element_car
;
1365 current_alist_element
1366 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1367 alist_element_car
= XCAR (current_alist_element
);
1368 if (EQ (alist_element_car
, current_alist_element
))
1369 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1371 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1373 /* For other variables, get the current value. */
1374 return do_symval_forwarding (valcontents
);
1377 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1378 doc
: /* Return t if SYMBOL has a non-void default value.
1379 This is the value that is seen in buffers that do not have their own values
1380 for this variable. */)
1384 register Lisp_Object value
;
1386 value
= default_value (symbol
);
1387 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1390 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1391 doc
: /* Return SYMBOL's default value.
1392 This is the value that is seen in buffers that do not have their own values
1393 for this variable. The default value is meaningful for variables with
1394 local bindings in certain buffers. */)
1398 register Lisp_Object value
;
1400 value
= default_value (symbol
);
1401 if (!EQ (value
, Qunbound
))
1404 xsignal1 (Qvoid_variable
, symbol
);
1407 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1408 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1409 The default value is seen in buffers that do not have their own values
1410 for this variable. */)
1412 Lisp_Object symbol
, value
;
1414 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1416 CHECK_SYMBOL (symbol
);
1417 valcontents
= SYMBOL_VALUE (symbol
);
1419 /* Handle variables like case-fold-search that have special slots
1420 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1422 if (BUFFER_OBJFWDP (valcontents
))
1424 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1425 int idx
= PER_BUFFER_IDX (offset
);
1427 PER_BUFFER_DEFAULT (offset
) = value
;
1429 /* If this variable is not always local in all buffers,
1430 set it in the buffers that don't nominally have a local value. */
1435 for (b
= all_buffers
; b
; b
= b
->next
)
1436 if (!PER_BUFFER_VALUE_P (b
, idx
))
1437 PER_BUFFER_VALUE (b
, offset
) = value
;
1442 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1443 return Fset (symbol
, value
);
1445 /* Store new value into the DEFAULT-VALUE slot. */
1446 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1448 /* If the default binding is now loaded, set the REALVALUE slot too. */
1449 current_alist_element
1450 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1451 alist_element_buffer
= Fcar (current_alist_element
);
1452 if (EQ (alist_element_buffer
, current_alist_element
))
1453 store_symval_forwarding (symbol
,
1454 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1460 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1461 doc
: /* Set the default value of variable VAR to VALUE.
1462 VAR, the variable name, is literal (not evaluated);
1463 VALUE is an expression: it is evaluated and its value returned.
1464 The default value of a variable is seen in buffers
1465 that do not have their own values for the variable.
1467 More generally, you can use multiple variables and values, as in
1468 (setq-default VAR VALUE VAR VALUE...)
1469 This sets each VAR's default value to the corresponding VALUE.
1470 The VALUE for the Nth VAR can refer to the new default values
1472 usage: (setq-default [VAR VALUE]...) */)
1476 register Lisp_Object args_left
;
1477 register Lisp_Object val
, symbol
;
1478 struct gcpro gcpro1
;
1488 val
= Feval (Fcar (Fcdr (args_left
)));
1489 symbol
= XCAR (args_left
);
1490 Fset_default (symbol
, val
);
1491 args_left
= Fcdr (XCDR (args_left
));
1493 while (!NILP (args_left
));
1499 /* Lisp functions for creating and removing buffer-local variables. */
1501 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1502 1, 1, "vMake Variable Buffer Local: ",
1503 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1504 At any time, the value for the current buffer is in effect,
1505 unless the variable has never been set in this buffer,
1506 in which case the default value is in effect.
1507 Note that binding the variable with `let', or setting it while
1508 a `let'-style binding made in this buffer is in effect,
1509 does not make the variable buffer-local. Return VARIABLE.
1511 In most cases it is better to use `make-local-variable',
1512 which makes a variable local in just one buffer.
1514 The function `default-value' gets the default value and `set-default' sets it. */)
1516 register Lisp_Object variable
;
1518 register Lisp_Object tem
, valcontents
, newval
;
1520 CHECK_SYMBOL (variable
);
1521 variable
= indirect_variable (variable
);
1523 valcontents
= SYMBOL_VALUE (variable
);
1524 if (XSYMBOL (variable
)->constant
|| KBOARD_OBJFWDP (valcontents
))
1525 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1527 if (BUFFER_OBJFWDP (valcontents
))
1529 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1530 newval
= valcontents
;
1533 if (EQ (valcontents
, Qunbound
))
1534 SET_SYMBOL_VALUE (variable
, Qnil
);
1535 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1537 newval
= allocate_misc ();
1538 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1539 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1540 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1541 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1542 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1543 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1544 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1545 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1546 SET_SYMBOL_VALUE (variable
, newval
);
1548 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1552 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1553 1, 1, "vMake Local Variable: ",
1554 doc
: /* Make VARIABLE have a separate value in the current buffer.
1555 Other buffers will continue to share a common default value.
1556 \(The buffer-local value of VARIABLE starts out as the same value
1557 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1560 If the variable is already arranged to become local when set,
1561 this function causes a local value to exist for this buffer,
1562 just as setting the variable would do.
1564 This function returns VARIABLE, and therefore
1565 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1568 See also `make-variable-buffer-local'.
1570 Do not use `make-local-variable' to make a hook variable buffer-local.
1571 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1573 register Lisp_Object variable
;
1575 register Lisp_Object tem
, valcontents
;
1577 CHECK_SYMBOL (variable
);
1578 variable
= indirect_variable (variable
);
1580 valcontents
= SYMBOL_VALUE (variable
);
1581 if (XSYMBOL (variable
)->constant
|| KBOARD_OBJFWDP (valcontents
))
1582 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1584 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1585 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1586 || BUFFER_OBJFWDP (valcontents
))
1588 tem
= Fboundp (variable
);
1590 /* Make sure the symbol has a local value in this particular buffer,
1591 by setting it to the same value it already has. */
1592 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1595 /* Make sure symbol is set up to hold per-buffer values. */
1596 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1599 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1601 newval
= allocate_misc ();
1602 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1603 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1604 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1605 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1606 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1607 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1608 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1609 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1610 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1611 SET_SYMBOL_VALUE (variable
, newval
);
1613 /* Make sure this buffer has its own value of symbol. */
1614 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1617 /* Swap out any local binding for some other buffer, and make
1618 sure the current value is permanently recorded, if it's the
1620 find_symbol_value (variable
);
1622 current_buffer
->local_var_alist
1623 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1624 current_buffer
->local_var_alist
);
1626 /* Make sure symbol does not think it is set up for this buffer;
1627 force it to look once again for this buffer's value. */
1629 Lisp_Object
*pvalbuf
;
1631 valcontents
= SYMBOL_VALUE (variable
);
1633 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1634 if (current_buffer
== XBUFFER (*pvalbuf
))
1636 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1640 /* If the symbol forwards into a C variable, then load the binding
1641 for this buffer now. If C code modifies the variable before we
1642 load the binding in, then that new value will clobber the default
1643 binding the next time we unload it. */
1644 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1645 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1646 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1651 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1652 1, 1, "vKill Local Variable: ",
1653 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1654 From now on the default value will apply in this buffer. Return VARIABLE. */)
1656 register Lisp_Object variable
;
1658 register Lisp_Object tem
, valcontents
;
1660 CHECK_SYMBOL (variable
);
1661 variable
= indirect_variable (variable
);
1663 valcontents
= SYMBOL_VALUE (variable
);
1665 if (BUFFER_OBJFWDP (valcontents
))
1667 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1668 int idx
= PER_BUFFER_IDX (offset
);
1672 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1673 PER_BUFFER_VALUE (current_buffer
, offset
)
1674 = PER_BUFFER_DEFAULT (offset
);
1679 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1682 /* Get rid of this buffer's alist element, if any. */
1684 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1686 current_buffer
->local_var_alist
1687 = Fdelq (tem
, current_buffer
->local_var_alist
);
1689 /* If the symbol is set up with the current buffer's binding
1690 loaded, recompute its value. We have to do it now, or else
1691 forwarded objects won't work right. */
1693 Lisp_Object
*pvalbuf
, buf
;
1694 valcontents
= SYMBOL_VALUE (variable
);
1695 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1696 XSETBUFFER (buf
, current_buffer
);
1697 if (EQ (buf
, *pvalbuf
))
1700 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1701 find_symbol_value (variable
);
1708 /* Lisp functions for creating and removing buffer-local variables. */
1710 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1711 1, 1, "vMake Variable Frame Local: ",
1712 doc
: /* Enable VARIABLE to have frame-local bindings.
1713 This does not create any frame-local bindings for VARIABLE,
1714 it just makes them possible.
1716 A frame-local binding is actually a frame parameter value.
1717 If a frame F has a value for the frame parameter named VARIABLE,
1718 that also acts as a frame-local binding for VARIABLE in F--
1719 provided this function has been called to enable VARIABLE
1720 to have frame-local bindings at all.
1722 The only way to create a frame-local binding for VARIABLE in a frame
1723 is to set the VARIABLE frame parameter of that frame. See
1724 `modify-frame-parameters' for how to set frame parameters.
1726 Buffer-local bindings take precedence over frame-local bindings. */)
1728 register Lisp_Object variable
;
1730 register Lisp_Object tem
, valcontents
, newval
;
1732 CHECK_SYMBOL (variable
);
1733 variable
= indirect_variable (variable
);
1735 valcontents
= SYMBOL_VALUE (variable
);
1736 if (XSYMBOL (variable
)->constant
|| KBOARD_OBJFWDP (valcontents
)
1737 || BUFFER_OBJFWDP (valcontents
))
1738 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1740 if (BUFFER_LOCAL_VALUEP (valcontents
))
1742 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1746 if (EQ (valcontents
, Qunbound
))
1747 SET_SYMBOL_VALUE (variable
, Qnil
);
1748 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1750 newval
= allocate_misc ();
1751 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1752 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1753 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1754 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1755 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1756 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1757 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1758 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1759 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1760 SET_SYMBOL_VALUE (variable
, newval
);
1764 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1766 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1767 BUFFER defaults to the current buffer. */)
1769 register Lisp_Object variable
, buffer
;
1771 Lisp_Object valcontents
;
1772 register struct buffer
*buf
;
1775 buf
= current_buffer
;
1778 CHECK_BUFFER (buffer
);
1779 buf
= XBUFFER (buffer
);
1782 CHECK_SYMBOL (variable
);
1783 variable
= indirect_variable (variable
);
1785 valcontents
= SYMBOL_VALUE (variable
);
1786 if (BUFFER_LOCAL_VALUEP (valcontents
))
1788 Lisp_Object tail
, elt
;
1790 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1793 if (EQ (variable
, XCAR (elt
)))
1797 if (BUFFER_OBJFWDP (valcontents
))
1799 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1800 int idx
= PER_BUFFER_IDX (offset
);
1801 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1807 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1809 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1810 More precisely, this means that setting the variable \(with `set' or`setq'),
1811 while it does not have a `let'-style binding that was made in BUFFER,
1812 will produce a buffer local binding. See Info node
1813 `(elisp)Creating Buffer-Local'.
1814 BUFFER defaults to the current buffer. */)
1816 register Lisp_Object variable
, buffer
;
1818 Lisp_Object valcontents
;
1819 register struct buffer
*buf
;
1822 buf
= current_buffer
;
1825 CHECK_BUFFER (buffer
);
1826 buf
= XBUFFER (buffer
);
1829 CHECK_SYMBOL (variable
);
1830 variable
= indirect_variable (variable
);
1832 valcontents
= SYMBOL_VALUE (variable
);
1834 if (BUFFER_OBJFWDP (valcontents
))
1835 /* All these slots become local if they are set. */
1837 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1839 Lisp_Object tail
, elt
;
1840 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1842 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1845 if (EQ (variable
, XCAR (elt
)))
1852 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1854 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1855 If the current binding is buffer-local, the value is the current buffer.
1856 If the current binding is frame-local, the value is the selected frame.
1857 If the current binding is global (the default), the value is nil. */)
1859 register Lisp_Object variable
;
1861 Lisp_Object valcontents
;
1863 CHECK_SYMBOL (variable
);
1864 variable
= indirect_variable (variable
);
1866 /* Make sure the current binding is actually swapped in. */
1867 find_symbol_value (variable
);
1869 valcontents
= XSYMBOL (variable
)->value
;
1871 if (BUFFER_LOCAL_VALUEP (valcontents
)
1872 || BUFFER_OBJFWDP (valcontents
))
1874 /* For a local variable, record both the symbol and which
1875 buffer's or frame's value we are saving. */
1876 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1877 return Fcurrent_buffer ();
1878 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1879 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1880 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1886 /* This code is disabled now that we use the selected frame to return
1887 keyboard-local-values. */
1889 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1891 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1892 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1893 If SYMBOL is not a terminal-local variable, then return its normal
1894 value, like `symbol-value'.
1896 TERMINAL may be a terminal id, a frame, or nil (meaning the
1897 selected frame's terminal device). */)
1900 Lisp_Object terminal
;
1903 struct terminal
*t
= get_terminal (terminal
, 1);
1904 push_kboard (t
->kboard
);
1905 result
= Fsymbol_value (symbol
);
1910 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1911 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1912 If VARIABLE is not a terminal-local variable, then set its normal
1913 binding, like `set'.
1915 TERMINAL may be a terminal id, a frame, or nil (meaning the
1916 selected frame's terminal device). */)
1917 (symbol
, terminal
, value
)
1919 Lisp_Object terminal
;
1923 struct terminal
*t
= get_terminal (terminal
, 1);
1924 push_kboard (d
->kboard
);
1925 result
= Fset (symbol
, value
);
1931 /* Find the function at the end of a chain of symbol function indirections. */
1933 /* If OBJECT is a symbol, find the end of its function chain and
1934 return the value found there. If OBJECT is not a symbol, just
1935 return it. If there is a cycle in the function chain, signal a
1936 cyclic-function-indirection error.
1938 This is like Findirect_function, except that it doesn't signal an
1939 error if the chain ends up unbound. */
1941 indirect_function (object
)
1942 register Lisp_Object object
;
1944 Lisp_Object tortoise
, hare
;
1946 hare
= tortoise
= object
;
1950 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1952 hare
= XSYMBOL (hare
)->function
;
1953 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1955 hare
= XSYMBOL (hare
)->function
;
1957 tortoise
= XSYMBOL (tortoise
)->function
;
1959 if (EQ (hare
, tortoise
))
1960 xsignal1 (Qcyclic_function_indirection
, object
);
1966 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1967 doc
: /* Return the function at the end of OBJECT's function chain.
1968 If OBJECT is not a symbol, just return it. Otherwise, follow all
1969 function indirections to find the final function binding and return it.
1970 If the final symbol in the chain is unbound, signal a void-function error.
1971 Optional arg NOERROR non-nil means to return nil instead of signalling.
1972 Signal a cyclic-function-indirection error if there is a loop in the
1973 function chain of symbols. */)
1975 register Lisp_Object object
;
1976 Lisp_Object noerror
;
1980 /* Optimize for no indirection. */
1982 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1983 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1984 result
= indirect_function (result
);
1985 if (!EQ (result
, Qunbound
))
1989 xsignal1 (Qvoid_function
, object
);
1994 /* Extract and set vector and string elements */
1996 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1997 doc
: /* Return the element of ARRAY at index IDX.
1998 ARRAY may be a vector, a string, a char-table, a bool-vector,
1999 or a byte-code object. IDX starts at 0. */)
2001 register Lisp_Object array
;
2004 register int idxval
;
2007 idxval
= XINT (idx
);
2008 if (STRINGP (array
))
2012 if (idxval
< 0 || idxval
>= SCHARS (array
))
2013 args_out_of_range (array
, idx
);
2014 if (! STRING_MULTIBYTE (array
))
2015 return make_number ((unsigned char) SREF (array
, idxval
));
2016 idxval_byte
= string_char_to_byte (array
, idxval
);
2018 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2019 SBYTES (array
) - idxval_byte
);
2020 return make_number (c
);
2022 else if (BOOL_VECTOR_P (array
))
2026 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2027 args_out_of_range (array
, idx
);
2029 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2030 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2032 else if (CHAR_TABLE_P (array
))
2034 CHECK_CHARACTER (idx
);
2035 return CHAR_TABLE_REF (array
, idxval
);
2040 if (VECTORP (array
))
2041 size
= XVECTOR (array
)->size
;
2042 else if (COMPILEDP (array
))
2043 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2045 wrong_type_argument (Qarrayp
, array
);
2047 if (idxval
< 0 || idxval
>= size
)
2048 args_out_of_range (array
, idx
);
2049 return XVECTOR (array
)->contents
[idxval
];
2053 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2054 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2055 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2056 bool-vector. IDX starts at 0. */)
2057 (array
, idx
, newelt
)
2058 register Lisp_Object array
;
2059 Lisp_Object idx
, newelt
;
2061 register int idxval
;
2064 idxval
= XINT (idx
);
2065 CHECK_ARRAY (array
, Qarrayp
);
2066 CHECK_IMPURE (array
);
2068 if (VECTORP (array
))
2070 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2071 args_out_of_range (array
, idx
);
2072 XVECTOR (array
)->contents
[idxval
] = newelt
;
2074 else if (BOOL_VECTOR_P (array
))
2078 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2079 args_out_of_range (array
, idx
);
2081 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2083 if (! NILP (newelt
))
2084 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2086 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2087 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2089 else if (CHAR_TABLE_P (array
))
2091 CHECK_CHARACTER (idx
);
2092 CHAR_TABLE_SET (array
, idxval
, newelt
);
2094 else if (STRING_MULTIBYTE (array
))
2096 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2097 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2099 if (idxval
< 0 || idxval
>= SCHARS (array
))
2100 args_out_of_range (array
, idx
);
2101 CHECK_CHARACTER (newelt
);
2103 nbytes
= SBYTES (array
);
2105 idxval_byte
= string_char_to_byte (array
, idxval
);
2106 p1
= SDATA (array
) + idxval_byte
;
2107 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2108 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2109 if (prev_bytes
!= new_bytes
)
2111 /* We must relocate the string data. */
2112 int nchars
= SCHARS (array
);
2116 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2117 bcopy (SDATA (array
), str
, nbytes
);
2118 allocate_string_data (XSTRING (array
), nchars
,
2119 nbytes
+ new_bytes
- prev_bytes
);
2120 bcopy (str
, SDATA (array
), idxval_byte
);
2121 p1
= SDATA (array
) + idxval_byte
;
2122 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2123 nbytes
- (idxval_byte
+ prev_bytes
));
2125 clear_string_char_byte_cache ();
2132 if (idxval
< 0 || idxval
>= SCHARS (array
))
2133 args_out_of_range (array
, idx
);
2134 CHECK_NUMBER (newelt
);
2136 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2137 args_out_of_range (array
, newelt
);
2138 SSET (array
, idxval
, XINT (newelt
));
2144 /* Arithmetic functions */
2146 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2149 arithcompare (num1
, num2
, comparison
)
2150 Lisp_Object num1
, num2
;
2151 enum comparison comparison
;
2153 double f1
= 0, f2
= 0;
2156 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2157 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2159 if (FLOATP (num1
) || FLOATP (num2
))
2162 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2163 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2169 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2174 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2179 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2184 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2189 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2194 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2203 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2204 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2206 register Lisp_Object num1
, num2
;
2208 return arithcompare (num1
, num2
, equal
);
2211 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2212 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2214 register Lisp_Object num1
, num2
;
2216 return arithcompare (num1
, num2
, less
);
2219 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2220 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2222 register Lisp_Object num1
, num2
;
2224 return arithcompare (num1
, num2
, grtr
);
2227 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2228 doc
: /* Return t if first arg is less than or equal to second arg.
2229 Both must be numbers or markers. */)
2231 register Lisp_Object num1
, num2
;
2233 return arithcompare (num1
, num2
, less_or_equal
);
2236 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2237 doc
: /* Return t if first arg is greater than or equal to second arg.
2238 Both must be numbers or markers. */)
2240 register Lisp_Object num1
, num2
;
2242 return arithcompare (num1
, num2
, grtr_or_equal
);
2245 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2246 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2248 register Lisp_Object num1
, num2
;
2250 return arithcompare (num1
, num2
, notequal
);
2253 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2254 doc
: /* Return t if NUMBER is zero. */)
2256 register Lisp_Object number
;
2258 CHECK_NUMBER_OR_FLOAT (number
);
2260 if (FLOATP (number
))
2262 if (XFLOAT_DATA (number
) == 0.0)
2272 /* Convert between long values and pairs of Lisp integers.
2273 Note that long_to_cons returns a single Lisp integer
2274 when the value fits in one. */
2280 unsigned long top
= i
>> 16;
2281 unsigned int bot
= i
& 0xFFFF;
2283 return make_number (bot
);
2284 if (top
== (unsigned long)-1 >> 16)
2285 return Fcons (make_number (-1), make_number (bot
));
2286 return Fcons (make_number (top
), make_number (bot
));
2293 Lisp_Object top
, bot
;
2300 return ((XINT (top
) << 16) | XINT (bot
));
2303 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2304 doc
: /* Return the decimal representation of NUMBER as a string.
2305 Uses a minus sign if negative.
2306 NUMBER may be an integer or a floating point number. */)
2310 char buffer
[VALBITS
];
2312 CHECK_NUMBER_OR_FLOAT (number
);
2314 if (FLOATP (number
))
2316 char pigbuf
[350]; /* see comments in float_to_string */
2318 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2319 return build_string (pigbuf
);
2322 if (sizeof (int) == sizeof (EMACS_INT
))
2323 sprintf (buffer
, "%d", XINT (number
));
2324 else if (sizeof (long) == sizeof (EMACS_INT
))
2325 sprintf (buffer
, "%ld", (long) XINT (number
));
2328 return build_string (buffer
);
2332 digit_to_number (character
, base
)
2333 int character
, base
;
2337 if (character
>= '0' && character
<= '9')
2338 digit
= character
- '0';
2339 else if (character
>= 'a' && character
<= 'z')
2340 digit
= character
- 'a' + 10;
2341 else if (character
>= 'A' && character
<= 'Z')
2342 digit
= character
- 'A' + 10;
2352 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2353 doc
: /* Parse STRING as a decimal number and return the number.
2354 This parses both integers and floating point numbers.
2355 It ignores leading spaces and tabs.
2357 If BASE, interpret STRING as a number in that base. If BASE isn't
2358 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2359 If the base used is not 10, floating point is not recognized. */)
2361 register Lisp_Object string
, base
;
2363 register unsigned char *p
;
2368 CHECK_STRING (string
);
2374 CHECK_NUMBER (base
);
2376 if (b
< 2 || b
> 16)
2377 xsignal1 (Qargs_out_of_range
, base
);
2380 /* Skip any whitespace at the front of the number. Some versions of
2381 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2383 while (*p
== ' ' || *p
== '\t')
2394 if (isfloat_string (p
) && b
== 10)
2395 val
= make_float (sign
* atof (p
));
2402 int digit
= digit_to_number (*p
++, b
);
2408 val
= make_fixnum_or_float (sign
* v
);
2428 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2429 int, Lisp_Object
*));
2430 extern Lisp_Object
fmod_float ();
2433 arith_driver (code
, nargs
, args
)
2436 register Lisp_Object
*args
;
2438 register Lisp_Object val
;
2439 register int argnum
;
2440 register EMACS_INT accum
= 0;
2441 register EMACS_INT next
;
2443 switch (SWITCH_ENUM_CAST (code
))
2461 for (argnum
= 0; argnum
< nargs
; argnum
++)
2463 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2465 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2468 return float_arith_driver ((double) accum
, argnum
, code
,
2471 next
= XINT (args
[argnum
]);
2472 switch (SWITCH_ENUM_CAST (code
))
2478 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2489 xsignal0 (Qarith_error
);
2503 if (!argnum
|| next
> accum
)
2507 if (!argnum
|| next
< accum
)
2513 XSETINT (val
, accum
);
2518 #define isnan(x) ((x) != (x))
2521 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2523 register int argnum
;
2526 register Lisp_Object
*args
;
2528 register Lisp_Object val
;
2531 for (; argnum
< nargs
; argnum
++)
2533 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2534 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2538 next
= XFLOAT_DATA (val
);
2542 args
[argnum
] = val
; /* runs into a compiler bug. */
2543 next
= XINT (args
[argnum
]);
2545 switch (SWITCH_ENUM_CAST (code
))
2551 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2561 if (! IEEE_FLOATING_POINT
&& next
== 0)
2562 xsignal0 (Qarith_error
);
2569 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2571 if (!argnum
|| isnan (next
) || next
> accum
)
2575 if (!argnum
|| isnan (next
) || next
< accum
)
2581 return make_float (accum
);
2585 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2586 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2587 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2592 return arith_driver (Aadd
, nargs
, args
);
2595 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2596 doc
: /* Negate number or subtract numbers or markers and return the result.
2597 With one arg, negates it. With more than one arg,
2598 subtracts all but the first from the first.
2599 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2604 return arith_driver (Asub
, nargs
, args
);
2607 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2608 doc
: /* Return product of any number of arguments, which are numbers or markers.
2609 usage: (* &rest NUMBERS-OR-MARKERS) */)
2614 return arith_driver (Amult
, nargs
, args
);
2617 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2618 doc
: /* Return first argument divided by all the remaining arguments.
2619 The arguments must be numbers or markers.
2620 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2626 for (argnum
= 2; argnum
< nargs
; argnum
++)
2627 if (FLOATP (args
[argnum
]))
2628 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2629 return arith_driver (Adiv
, nargs
, args
);
2632 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2633 doc
: /* Return remainder of X divided by Y.
2634 Both must be integers or markers. */)
2636 register Lisp_Object x
, y
;
2640 CHECK_NUMBER_COERCE_MARKER (x
);
2641 CHECK_NUMBER_COERCE_MARKER (y
);
2643 if (XFASTINT (y
) == 0)
2644 xsignal0 (Qarith_error
);
2646 XSETINT (val
, XINT (x
) % XINT (y
));
2660 /* If the magnitude of the result exceeds that of the divisor, or
2661 the sign of the result does not agree with that of the dividend,
2662 iterate with the reduced value. This does not yield a
2663 particularly accurate result, but at least it will be in the
2664 range promised by fmod. */
2666 r
-= f2
* floor (r
/ f2
);
2667 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2671 #endif /* ! HAVE_FMOD */
2673 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2674 doc
: /* Return X modulo Y.
2675 The result falls between zero (inclusive) and Y (exclusive).
2676 Both X and Y must be numbers or markers. */)
2678 register Lisp_Object x
, y
;
2683 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2684 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2686 if (FLOATP (x
) || FLOATP (y
))
2687 return fmod_float (x
, y
);
2693 xsignal0 (Qarith_error
);
2697 /* If the "remainder" comes out with the wrong sign, fix it. */
2698 if (i2
< 0 ? i1
> 0 : i1
< 0)
2705 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2706 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2707 The value is always a number; markers are converted to numbers.
2708 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2713 return arith_driver (Amax
, nargs
, args
);
2716 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2717 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2718 The value is always a number; markers are converted to numbers.
2719 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2724 return arith_driver (Amin
, nargs
, args
);
2727 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2728 doc
: /* Return bitwise-and of all the arguments.
2729 Arguments may be integers, or markers converted to integers.
2730 usage: (logand &rest INTS-OR-MARKERS) */)
2735 return arith_driver (Alogand
, nargs
, args
);
2738 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2739 doc
: /* Return bitwise-or of all the arguments.
2740 Arguments may be integers, or markers converted to integers.
2741 usage: (logior &rest INTS-OR-MARKERS) */)
2746 return arith_driver (Alogior
, nargs
, args
);
2749 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2750 doc
: /* Return bitwise-exclusive-or of all the arguments.
2751 Arguments may be integers, or markers converted to integers.
2752 usage: (logxor &rest INTS-OR-MARKERS) */)
2757 return arith_driver (Alogxor
, nargs
, args
);
2760 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2761 doc
: /* Return VALUE with its bits shifted left by COUNT.
2762 If COUNT is negative, shifting is actually to the right.
2763 In this case, the sign bit is duplicated. */)
2765 register Lisp_Object value
, count
;
2767 register Lisp_Object val
;
2769 CHECK_NUMBER (value
);
2770 CHECK_NUMBER (count
);
2772 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2774 else if (XINT (count
) > 0)
2775 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2776 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2777 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2779 XSETINT (val
, XINT (value
) >> -XINT (count
));
2783 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2784 doc
: /* Return VALUE with its bits shifted left by COUNT.
2785 If COUNT is negative, shifting is actually to the right.
2786 In this case, zeros are shifted in on the left. */)
2788 register Lisp_Object value
, count
;
2790 register Lisp_Object val
;
2792 CHECK_NUMBER (value
);
2793 CHECK_NUMBER (count
);
2795 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2797 else if (XINT (count
) > 0)
2798 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2799 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2802 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2806 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2807 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2808 Markers are converted to integers. */)
2810 register Lisp_Object number
;
2812 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2814 if (FLOATP (number
))
2815 return (make_float (1.0 + XFLOAT_DATA (number
)));
2817 XSETINT (number
, XINT (number
) + 1);
2821 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2822 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2823 Markers are converted to integers. */)
2825 register Lisp_Object number
;
2827 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2829 if (FLOATP (number
))
2830 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2832 XSETINT (number
, XINT (number
) - 1);
2836 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2837 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2839 register Lisp_Object number
;
2841 CHECK_NUMBER (number
);
2842 XSETINT (number
, ~XINT (number
));
2846 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2847 doc
: /* Return the byteorder for the machine.
2848 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2849 lowercase l) for small endian machines. */)
2852 unsigned i
= 0x04030201;
2853 int order
= *(char *)&i
== 1 ? 108 : 66;
2855 return make_number (order
);
2863 Lisp_Object error_tail
, arith_tail
;
2865 Qquote
= intern ("quote");
2866 Qlambda
= intern ("lambda");
2867 Qsubr
= intern ("subr");
2868 Qerror_conditions
= intern ("error-conditions");
2869 Qerror_message
= intern ("error-message");
2870 Qtop_level
= intern ("top-level");
2872 Qerror
= intern ("error");
2873 Qquit
= intern ("quit");
2874 Qwrong_type_argument
= intern ("wrong-type-argument");
2875 Qargs_out_of_range
= intern ("args-out-of-range");
2876 Qvoid_function
= intern ("void-function");
2877 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2878 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2879 Qvoid_variable
= intern ("void-variable");
2880 Qsetting_constant
= intern ("setting-constant");
2881 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2883 Qinvalid_function
= intern ("invalid-function");
2884 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2885 Qno_catch
= intern ("no-catch");
2886 Qend_of_file
= intern ("end-of-file");
2887 Qarith_error
= intern ("arith-error");
2888 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2889 Qend_of_buffer
= intern ("end-of-buffer");
2890 Qbuffer_read_only
= intern ("buffer-read-only");
2891 Qtext_read_only
= intern ("text-read-only");
2892 Qmark_inactive
= intern ("mark-inactive");
2894 Qlistp
= intern ("listp");
2895 Qconsp
= intern ("consp");
2896 Qsymbolp
= intern ("symbolp");
2897 Qkeywordp
= intern ("keywordp");
2898 Qintegerp
= intern ("integerp");
2899 Qnatnump
= intern ("natnump");
2900 Qwholenump
= intern ("wholenump");
2901 Qstringp
= intern ("stringp");
2902 Qarrayp
= intern ("arrayp");
2903 Qsequencep
= intern ("sequencep");
2904 Qbufferp
= intern ("bufferp");
2905 Qvectorp
= intern ("vectorp");
2906 Qchar_or_string_p
= intern ("char-or-string-p");
2907 Qmarkerp
= intern ("markerp");
2908 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2909 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2910 Qboundp
= intern ("boundp");
2911 Qfboundp
= intern ("fboundp");
2913 Qfloatp
= intern ("floatp");
2914 Qnumberp
= intern ("numberp");
2915 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2917 Qchar_table_p
= intern ("char-table-p");
2918 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2920 Qsubrp
= intern ("subrp");
2921 Qunevalled
= intern ("unevalled");
2922 Qmany
= intern ("many");
2924 Qcdr
= intern ("cdr");
2926 /* Handle automatic advice activation */
2927 Qad_advice_info
= intern ("ad-advice-info");
2928 Qad_activate_internal
= intern ("ad-activate-internal");
2930 error_tail
= Fcons (Qerror
, Qnil
);
2932 /* ERROR is used as a signaler for random errors for which nothing else is right */
2934 Fput (Qerror
, Qerror_conditions
,
2936 Fput (Qerror
, Qerror_message
,
2937 build_string ("error"));
2939 Fput (Qquit
, Qerror_conditions
,
2940 Fcons (Qquit
, Qnil
));
2941 Fput (Qquit
, Qerror_message
,
2942 build_string ("Quit"));
2944 Fput (Qwrong_type_argument
, Qerror_conditions
,
2945 Fcons (Qwrong_type_argument
, error_tail
));
2946 Fput (Qwrong_type_argument
, Qerror_message
,
2947 build_string ("Wrong type argument"));
2949 Fput (Qargs_out_of_range
, Qerror_conditions
,
2950 Fcons (Qargs_out_of_range
, error_tail
));
2951 Fput (Qargs_out_of_range
, Qerror_message
,
2952 build_string ("Args out of range"));
2954 Fput (Qvoid_function
, Qerror_conditions
,
2955 Fcons (Qvoid_function
, error_tail
));
2956 Fput (Qvoid_function
, Qerror_message
,
2957 build_string ("Symbol's function definition is void"));
2959 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2960 Fcons (Qcyclic_function_indirection
, error_tail
));
2961 Fput (Qcyclic_function_indirection
, Qerror_message
,
2962 build_string ("Symbol's chain of function indirections contains a loop"));
2964 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2965 Fcons (Qcyclic_variable_indirection
, error_tail
));
2966 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2967 build_string ("Symbol's chain of variable indirections contains a loop"));
2969 Qcircular_list
= intern ("circular-list");
2970 staticpro (&Qcircular_list
);
2971 Fput (Qcircular_list
, Qerror_conditions
,
2972 Fcons (Qcircular_list
, error_tail
));
2973 Fput (Qcircular_list
, Qerror_message
,
2974 build_string ("List contains a loop"));
2976 Fput (Qvoid_variable
, Qerror_conditions
,
2977 Fcons (Qvoid_variable
, error_tail
));
2978 Fput (Qvoid_variable
, Qerror_message
,
2979 build_string ("Symbol's value as variable is void"));
2981 Fput (Qsetting_constant
, Qerror_conditions
,
2982 Fcons (Qsetting_constant
, error_tail
));
2983 Fput (Qsetting_constant
, Qerror_message
,
2984 build_string ("Attempt to set a constant symbol"));
2986 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2987 Fcons (Qinvalid_read_syntax
, error_tail
));
2988 Fput (Qinvalid_read_syntax
, Qerror_message
,
2989 build_string ("Invalid read syntax"));
2991 Fput (Qinvalid_function
, Qerror_conditions
,
2992 Fcons (Qinvalid_function
, error_tail
));
2993 Fput (Qinvalid_function
, Qerror_message
,
2994 build_string ("Invalid function"));
2996 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2997 Fcons (Qwrong_number_of_arguments
, error_tail
));
2998 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2999 build_string ("Wrong number of arguments"));
3001 Fput (Qno_catch
, Qerror_conditions
,
3002 Fcons (Qno_catch
, error_tail
));
3003 Fput (Qno_catch
, Qerror_message
,
3004 build_string ("No catch for tag"));
3006 Fput (Qend_of_file
, Qerror_conditions
,
3007 Fcons (Qend_of_file
, error_tail
));
3008 Fput (Qend_of_file
, Qerror_message
,
3009 build_string ("End of file during parsing"));
3011 arith_tail
= Fcons (Qarith_error
, error_tail
);
3012 Fput (Qarith_error
, Qerror_conditions
,
3014 Fput (Qarith_error
, Qerror_message
,
3015 build_string ("Arithmetic error"));
3017 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3018 Fcons (Qbeginning_of_buffer
, error_tail
));
3019 Fput (Qbeginning_of_buffer
, Qerror_message
,
3020 build_string ("Beginning of buffer"));
3022 Fput (Qend_of_buffer
, Qerror_conditions
,
3023 Fcons (Qend_of_buffer
, error_tail
));
3024 Fput (Qend_of_buffer
, Qerror_message
,
3025 build_string ("End of buffer"));
3027 Fput (Qbuffer_read_only
, Qerror_conditions
,
3028 Fcons (Qbuffer_read_only
, error_tail
));
3029 Fput (Qbuffer_read_only
, Qerror_message
,
3030 build_string ("Buffer is read-only"));
3032 Fput (Qtext_read_only
, Qerror_conditions
,
3033 Fcons (Qtext_read_only
, error_tail
));
3034 Fput (Qtext_read_only
, Qerror_message
,
3035 build_string ("Text is read-only"));
3037 Qrange_error
= intern ("range-error");
3038 Qdomain_error
= intern ("domain-error");
3039 Qsingularity_error
= intern ("singularity-error");
3040 Qoverflow_error
= intern ("overflow-error");
3041 Qunderflow_error
= intern ("underflow-error");
3043 Fput (Qdomain_error
, Qerror_conditions
,
3044 Fcons (Qdomain_error
, arith_tail
));
3045 Fput (Qdomain_error
, Qerror_message
,
3046 build_string ("Arithmetic domain error"));
3048 Fput (Qrange_error
, Qerror_conditions
,
3049 Fcons (Qrange_error
, arith_tail
));
3050 Fput (Qrange_error
, Qerror_message
,
3051 build_string ("Arithmetic range error"));
3053 Fput (Qsingularity_error
, Qerror_conditions
,
3054 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3055 Fput (Qsingularity_error
, Qerror_message
,
3056 build_string ("Arithmetic singularity error"));
3058 Fput (Qoverflow_error
, Qerror_conditions
,
3059 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3060 Fput (Qoverflow_error
, Qerror_message
,
3061 build_string ("Arithmetic overflow error"));
3063 Fput (Qunderflow_error
, Qerror_conditions
,
3064 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3065 Fput (Qunderflow_error
, Qerror_message
,
3066 build_string ("Arithmetic underflow error"));
3068 staticpro (&Qrange_error
);
3069 staticpro (&Qdomain_error
);
3070 staticpro (&Qsingularity_error
);
3071 staticpro (&Qoverflow_error
);
3072 staticpro (&Qunderflow_error
);
3076 staticpro (&Qquote
);
3077 staticpro (&Qlambda
);
3079 staticpro (&Qunbound
);
3080 staticpro (&Qerror_conditions
);
3081 staticpro (&Qerror_message
);
3082 staticpro (&Qtop_level
);
3084 staticpro (&Qerror
);
3086 staticpro (&Qwrong_type_argument
);
3087 staticpro (&Qargs_out_of_range
);
3088 staticpro (&Qvoid_function
);
3089 staticpro (&Qcyclic_function_indirection
);
3090 staticpro (&Qcyclic_variable_indirection
);
3091 staticpro (&Qvoid_variable
);
3092 staticpro (&Qsetting_constant
);
3093 staticpro (&Qinvalid_read_syntax
);
3094 staticpro (&Qwrong_number_of_arguments
);
3095 staticpro (&Qinvalid_function
);
3096 staticpro (&Qno_catch
);
3097 staticpro (&Qend_of_file
);
3098 staticpro (&Qarith_error
);
3099 staticpro (&Qbeginning_of_buffer
);
3100 staticpro (&Qend_of_buffer
);
3101 staticpro (&Qbuffer_read_only
);
3102 staticpro (&Qtext_read_only
);
3103 staticpro (&Qmark_inactive
);
3105 staticpro (&Qlistp
);
3106 staticpro (&Qconsp
);
3107 staticpro (&Qsymbolp
);
3108 staticpro (&Qkeywordp
);
3109 staticpro (&Qintegerp
);
3110 staticpro (&Qnatnump
);
3111 staticpro (&Qwholenump
);
3112 staticpro (&Qstringp
);
3113 staticpro (&Qarrayp
);
3114 staticpro (&Qsequencep
);
3115 staticpro (&Qbufferp
);
3116 staticpro (&Qvectorp
);
3117 staticpro (&Qchar_or_string_p
);
3118 staticpro (&Qmarkerp
);
3119 staticpro (&Qbuffer_or_string_p
);
3120 staticpro (&Qinteger_or_marker_p
);
3121 staticpro (&Qfloatp
);
3122 staticpro (&Qnumberp
);
3123 staticpro (&Qnumber_or_marker_p
);
3124 staticpro (&Qchar_table_p
);
3125 staticpro (&Qvector_or_char_table_p
);
3126 staticpro (&Qsubrp
);
3128 staticpro (&Qunevalled
);
3130 staticpro (&Qboundp
);
3131 staticpro (&Qfboundp
);
3133 staticpro (&Qad_advice_info
);
3134 staticpro (&Qad_activate_internal
);
3136 /* Types that type-of returns. */
3137 Qinteger
= intern ("integer");
3138 Qsymbol
= intern ("symbol");
3139 Qstring
= intern ("string");
3140 Qcons
= intern ("cons");
3141 Qmarker
= intern ("marker");
3142 Qoverlay
= intern ("overlay");
3143 Qfloat
= intern ("float");
3144 Qwindow_configuration
= intern ("window-configuration");
3145 Qprocess
= intern ("process");
3146 Qwindow
= intern ("window");
3147 /* Qsubr = intern ("subr"); */
3148 Qcompiled_function
= intern ("compiled-function");
3149 Qbuffer
= intern ("buffer");
3150 Qframe
= intern ("frame");
3151 Qvector
= intern ("vector");
3152 Qchar_table
= intern ("char-table");
3153 Qbool_vector
= intern ("bool-vector");
3154 Qhash_table
= intern ("hash-table");
3156 staticpro (&Qinteger
);
3157 staticpro (&Qsymbol
);
3158 staticpro (&Qstring
);
3160 staticpro (&Qmarker
);
3161 staticpro (&Qoverlay
);
3162 staticpro (&Qfloat
);
3163 staticpro (&Qwindow_configuration
);
3164 staticpro (&Qprocess
);
3165 staticpro (&Qwindow
);
3166 /* staticpro (&Qsubr); */
3167 staticpro (&Qcompiled_function
);
3168 staticpro (&Qbuffer
);
3169 staticpro (&Qframe
);
3170 staticpro (&Qvector
);
3171 staticpro (&Qchar_table
);
3172 staticpro (&Qbool_vector
);
3173 staticpro (&Qhash_table
);
3175 defsubr (&Sindirect_variable
);
3176 defsubr (&Sinteractive_form
);
3179 defsubr (&Stype_of
);
3184 defsubr (&Sintegerp
);
3185 defsubr (&Sinteger_or_marker_p
);
3186 defsubr (&Snumberp
);
3187 defsubr (&Snumber_or_marker_p
);
3189 defsubr (&Snatnump
);
3190 defsubr (&Ssymbolp
);
3191 defsubr (&Skeywordp
);
3192 defsubr (&Sstringp
);
3193 defsubr (&Smultibyte_string_p
);
3194 defsubr (&Svectorp
);
3195 defsubr (&Schar_table_p
);
3196 defsubr (&Svector_or_char_table_p
);
3197 defsubr (&Sbool_vector_p
);
3199 defsubr (&Ssequencep
);
3200 defsubr (&Sbufferp
);
3201 defsubr (&Smarkerp
);
3203 defsubr (&Sbyte_code_function_p
);
3204 defsubr (&Schar_or_string_p
);
3207 defsubr (&Scar_safe
);
3208 defsubr (&Scdr_safe
);
3211 defsubr (&Ssymbol_function
);
3212 defsubr (&Sindirect_function
);
3213 defsubr (&Ssymbol_plist
);
3214 defsubr (&Ssymbol_name
);
3215 defsubr (&Smakunbound
);
3216 defsubr (&Sfmakunbound
);
3218 defsubr (&Sfboundp
);
3220 defsubr (&Sdefalias
);
3221 defsubr (&Ssetplist
);
3222 defsubr (&Ssymbol_value
);
3224 defsubr (&Sdefault_boundp
);
3225 defsubr (&Sdefault_value
);
3226 defsubr (&Sset_default
);
3227 defsubr (&Ssetq_default
);
3228 defsubr (&Smake_variable_buffer_local
);
3229 defsubr (&Smake_local_variable
);
3230 defsubr (&Skill_local_variable
);
3231 defsubr (&Smake_variable_frame_local
);
3232 defsubr (&Slocal_variable_p
);
3233 defsubr (&Slocal_variable_if_set_p
);
3234 defsubr (&Svariable_binding_locus
);
3235 #if 0 /* XXX Remove this. --lorentey */
3236 defsubr (&Sterminal_local_value
);
3237 defsubr (&Sset_terminal_local_value
);
3241 defsubr (&Snumber_to_string
);
3242 defsubr (&Sstring_to_number
);
3243 defsubr (&Seqlsign
);
3266 defsubr (&Sbyteorder
);
3267 defsubr (&Ssubr_arity
);
3268 defsubr (&Ssubr_name
);
3270 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3272 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3273 doc
: /* The largest value that is representable in a Lisp integer. */);
3274 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3276 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3277 doc
: /* The smallest value that is representable in a Lisp integer. */);
3278 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3285 #if defined(USG) && !defined(POSIX_SIGNALS)
3286 /* USG systems forget handlers when they are used;
3287 must reestablish each time */
3288 signal (signo
, arith_error
);
3291 /* VMS systems are like USG. */
3292 signal (signo
, arith_error
);
3296 #else /* not BSD4_1 */
3297 sigsetmask (SIGEMPTYMASK
);
3298 #endif /* not BSD4_1 */
3300 SIGNAL_THREAD_CHECK (signo
);
3301 xsignal0 (Qarith_error
);
3307 /* Don't do this if just dumping out.
3308 We don't want to call `signal' in this case
3309 so that we don't have trouble with dumping
3310 signal-delivering routines in an inconsistent state. */
3314 #endif /* CANNOT_DUMP */
3315 signal (SIGFPE
, arith_error
);
3318 signal (SIGEMT
, arith_error
);
3322 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3323 (do not change this comment) */