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 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 xsignal (Qcircular_list
, list
);
113 wrong_type_argument (predicate
, value
)
114 register Lisp_Object predicate
, value
;
116 /* If VALUE is not even a valid Lisp object, abort here
117 where we can get a backtrace showing where it came from. */
118 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
121 xsignal2 (Qwrong_type_argument
, predicate
, value
);
127 error ("Attempt to modify read-only object");
131 args_out_of_range (a1
, a2
)
134 xsignal2 (Qargs_out_of_range
, a1
, a2
);
138 args_out_of_range_3 (a1
, a2
, a3
)
139 Lisp_Object a1
, a2
, a3
;
141 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
144 /* On some machines, XINT needs a temporary location.
145 Here it is, in case it is needed. */
147 int sign_extend_temp
;
149 /* On a few machines, XINT can only be done by calling this. */
152 sign_extend_lisp_int (num
)
155 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
156 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
158 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
161 /* Data type predicates */
163 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
164 doc
: /* Return t if the two args are the same Lisp object. */)
166 Lisp_Object obj1
, obj2
;
173 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
174 doc
: /* Return t if OBJECT is nil. */)
183 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
184 doc
: /* Return a symbol representing the type of OBJECT.
185 The symbol returned names the object's basic type;
186 for example, (type-of 1) returns `integer'. */)
190 switch (XGCTYPE (object
))
205 switch (XMISCTYPE (object
))
207 case Lisp_Misc_Marker
:
209 case Lisp_Misc_Overlay
:
211 case Lisp_Misc_Float
:
216 case Lisp_Vectorlike
:
217 if (GC_WINDOW_CONFIGURATIONP (object
))
218 return Qwindow_configuration
;
219 if (GC_PROCESSP (object
))
221 if (GC_WINDOWP (object
))
223 if (GC_SUBRP (object
))
225 if (GC_COMPILEDP (object
))
226 return Qcompiled_function
;
227 if (GC_BUFFERP (object
))
229 if (GC_CHAR_TABLE_P (object
))
231 if (GC_BOOL_VECTOR_P (object
))
233 if (GC_FRAMEP (object
))
235 if (GC_HASH_TABLE_P (object
))
247 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
248 doc
: /* Return t if OBJECT is a cons cell. */)
257 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
258 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
267 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
268 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
269 Otherwise, return nil. */)
273 if (CONSP (object
) || NILP (object
))
278 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
279 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
283 if (CONSP (object
) || NILP (object
))
288 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
289 doc
: /* Return t if OBJECT is a symbol. */)
293 if (SYMBOLP (object
))
298 /* Define this in C to avoid unnecessarily consing up the symbol
300 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
301 doc
: /* Return t if OBJECT is a keyword.
302 This means that it is a symbol with a print name beginning with `:'
303 interned in the initial obarray. */)
308 && SREF (SYMBOL_NAME (object
), 0) == ':'
309 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
314 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
315 doc
: /* Return t if OBJECT is a vector. */)
319 if (VECTORP (object
))
324 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a string. */)
329 if (STRINGP (object
))
334 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
336 doc
: /* Return t if OBJECT is a multibyte string. */)
340 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
345 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
346 doc
: /* Return t if OBJECT is a char-table. */)
350 if (CHAR_TABLE_P (object
))
355 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
356 Svector_or_char_table_p
, 1, 1, 0,
357 doc
: /* Return t if OBJECT is a char-table or vector. */)
361 if (VECTORP (object
) || CHAR_TABLE_P (object
))
366 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
367 doc
: /* Return t if OBJECT is a bool-vector. */)
371 if (BOOL_VECTOR_P (object
))
376 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is an array (string or vector). */)
386 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is a sequence (list or array). */)
389 register Lisp_Object object
;
391 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
396 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is an editor buffer. */)
401 if (BUFFERP (object
))
406 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
411 if (MARKERP (object
))
416 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
417 doc
: /* Return t if OBJECT is a built-in function. */)
426 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
428 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
432 if (COMPILEDP (object
))
437 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
438 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
440 register Lisp_Object object
;
442 if (CHARACTERP (object
) || STRINGP (object
))
447 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
448 doc
: /* Return t if OBJECT is an integer. */)
452 if (INTEGERP (object
))
457 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
458 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
460 register Lisp_Object object
;
462 if (MARKERP (object
) || INTEGERP (object
))
467 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
468 doc
: /* Return t if OBJECT is a nonnegative integer. */)
472 if (NATNUMP (object
))
477 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
478 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
482 if (NUMBERP (object
))
488 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
489 Snumber_or_marker_p
, 1, 1, 0,
490 doc
: /* Return t if OBJECT is a number or a marker. */)
494 if (NUMBERP (object
) || MARKERP (object
))
499 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
500 doc
: /* Return t if OBJECT is a floating point number. */)
510 /* Extract and set components of lists */
512 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
513 doc
: /* Return the car of LIST. If arg is nil, return nil.
514 Error if arg is not nil and not a cons cell. See also `car-safe'.
516 See Info node `(elisp)Cons Cells' for a discussion of related basic
517 Lisp concepts such as car, cdr, cons cell and list. */)
519 register Lisp_Object list
;
524 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
525 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
529 return CAR_SAFE (object
);
532 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
533 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
534 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
536 See Info node `(elisp)Cons Cells' for a discussion of related basic
537 Lisp concepts such as cdr, car, cons cell and list. */)
539 register Lisp_Object list
;
544 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
545 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
549 return CDR_SAFE (object
);
552 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
553 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
555 register Lisp_Object cell
, newcar
;
559 XSETCAR (cell
, newcar
);
563 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
564 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
566 register Lisp_Object cell
, newcdr
;
570 XSETCDR (cell
, newcdr
);
574 /* Extract and set components of symbols */
576 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
577 doc
: /* Return t if SYMBOL's value is not void. */)
579 register Lisp_Object symbol
;
581 Lisp_Object valcontents
;
582 CHECK_SYMBOL (symbol
);
584 valcontents
= SYMBOL_VALUE (symbol
);
586 if (BUFFER_LOCAL_VALUEP (valcontents
)
587 || SOME_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 CHECK_SYMBOL (symbol
);
666 if (NILP (symbol
) || EQ (symbol
, Qt
))
667 xsignal1 (Qsetting_constant
, symbol
);
668 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
669 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
671 XSYMBOL (symbol
)->function
= definition
;
672 /* Handle automatic advice activation */
673 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
675 call2 (Qad_activate_internal
, symbol
, Qnil
);
676 definition
= XSYMBOL (symbol
)->function
;
681 extern Lisp_Object Qfunction_documentation
;
683 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
684 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
685 Associates the function with the current load file, if any.
686 The optional third argument DOCSTRING specifies the documentation string
687 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
688 determined by DEFINITION. */)
689 (symbol
, definition
, docstring
)
690 register Lisp_Object symbol
, definition
, docstring
;
692 CHECK_SYMBOL (symbol
);
693 if (CONSP (XSYMBOL (symbol
)->function
)
694 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
695 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
696 definition
= Ffset (symbol
, definition
);
697 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
698 if (!NILP (docstring
))
699 Fput (symbol
, Qfunction_documentation
, docstring
);
703 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
704 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
706 register Lisp_Object symbol
, newplist
;
708 CHECK_SYMBOL (symbol
);
709 XSYMBOL (symbol
)->plist
= newplist
;
713 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
714 doc
: /* Return minimum and maximum number of args allowed for SUBR.
715 SUBR must be a built-in function.
716 The returned value is a pair (MIN . MAX). MIN is the minimum number
717 of args. MAX is the maximum number or the symbol `many', for a
718 function with `&rest' args, or `unevalled' for a special form. */)
722 short minargs
, maxargs
;
724 minargs
= XSUBR (subr
)->min_args
;
725 maxargs
= XSUBR (subr
)->max_args
;
727 return Fcons (make_number (minargs
), Qmany
);
728 else if (maxargs
== UNEVALLED
)
729 return Fcons (make_number (minargs
), Qunevalled
);
731 return Fcons (make_number (minargs
), make_number (maxargs
));
734 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
735 doc
: /* Return name of subroutine SUBR.
736 SUBR must be a built-in function. */)
742 name
= XSUBR (subr
)->symbol_name
;
743 return make_string (name
, strlen (name
));
746 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
747 doc
: /* Return the interactive form of CMD or nil if none.
748 If CMD is not a command, the return value is nil.
749 Value, if non-nil, is a list \(interactive SPEC). */)
753 Lisp_Object fun
= indirect_function (cmd
);
757 if (XSUBR (fun
)->prompt
)
758 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
760 else if (COMPILEDP (fun
))
762 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
763 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
765 else if (CONSP (fun
))
767 Lisp_Object funcar
= XCAR (fun
);
768 if (EQ (funcar
, Qlambda
))
769 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
770 else if (EQ (funcar
, Qautoload
))
774 do_autoload (fun
, cmd
);
776 return Finteractive_form (cmd
);
783 /***********************************************************************
784 Getting and Setting Values of Symbols
785 ***********************************************************************/
787 /* Return the symbol holding SYMBOL's value. Signal
788 `cyclic-variable-indirection' if SYMBOL's chain of variable
789 indirections contains a loop. */
792 indirect_variable (symbol
)
795 Lisp_Object tortoise
, hare
;
797 hare
= tortoise
= symbol
;
799 while (XSYMBOL (hare
)->indirect_variable
)
801 hare
= XSYMBOL (hare
)->value
;
802 if (!XSYMBOL (hare
)->indirect_variable
)
805 hare
= XSYMBOL (hare
)->value
;
806 tortoise
= XSYMBOL (tortoise
)->value
;
808 if (EQ (hare
, tortoise
))
809 xsignal1 (Qcyclic_variable_indirection
, symbol
);
816 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
817 doc
: /* Return the variable at the end of OBJECT's variable chain.
818 If OBJECT is a symbol, follow all variable indirections and return the final
819 variable. If OBJECT is not a symbol, just return it.
820 Signal a cyclic-variable-indirection error if there is a loop in the
821 variable chain of symbols. */)
825 if (SYMBOLP (object
))
826 object
= indirect_variable (object
);
831 /* Given the raw contents of a symbol value cell,
832 return the Lisp value of the symbol.
833 This does not handle buffer-local variables; use
834 swap_in_symval_forwarding for that. */
837 do_symval_forwarding (valcontents
)
838 register Lisp_Object valcontents
;
840 register Lisp_Object val
;
842 if (MISCP (valcontents
))
843 switch (XMISCTYPE (valcontents
))
845 case Lisp_Misc_Intfwd
:
846 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
849 case Lisp_Misc_Boolfwd
:
850 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
852 case Lisp_Misc_Objfwd
:
853 return *XOBJFWD (valcontents
)->objvar
;
855 case Lisp_Misc_Buffer_Objfwd
:
856 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
857 return PER_BUFFER_VALUE (current_buffer
, offset
);
859 case Lisp_Misc_Kboard_Objfwd
:
860 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
861 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
866 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
867 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
868 buffer-independent contents of the value cell: forwarded just one
869 step past the buffer-localness.
871 BUF non-zero means set the value in buffer BUF instead of the
872 current buffer. This only plays a role for per-buffer variables. */
875 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
877 register Lisp_Object valcontents
, newval
;
880 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
883 switch (XMISCTYPE (valcontents
))
885 case Lisp_Misc_Intfwd
:
886 CHECK_NUMBER (newval
);
887 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
888 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
889 error ("Value out of range for variable `%s'",
890 SDATA (SYMBOL_NAME (symbol
)));
893 case Lisp_Misc_Boolfwd
:
894 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
897 case Lisp_Misc_Objfwd
:
898 *XOBJFWD (valcontents
)->objvar
= newval
;
900 /* If this variable is a default for something stored
901 in the buffer itself, such as default-fill-column,
902 find the buffers that don't have local values for it
904 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
905 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
907 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
908 - (char *) &buffer_defaults
);
909 int idx
= PER_BUFFER_IDX (offset
);
916 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
921 buf
= Fcdr (XCAR (tail
));
922 if (!BUFFERP (buf
)) continue;
925 if (! PER_BUFFER_VALUE_P (b
, idx
))
926 PER_BUFFER_VALUE (b
, offset
) = newval
;
931 case Lisp_Misc_Buffer_Objfwd
:
933 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
936 type
= PER_BUFFER_TYPE (offset
);
937 if (! NILP (type
) && ! NILP (newval
)
938 && XTYPE (newval
) != XINT (type
))
939 buffer_slot_type_mismatch (offset
);
942 buf
= current_buffer
;
943 PER_BUFFER_VALUE (buf
, offset
) = newval
;
947 case Lisp_Misc_Kboard_Objfwd
:
949 char *base
= (char *) current_kboard
;
950 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
951 *(Lisp_Object
*) p
= newval
;
962 valcontents
= SYMBOL_VALUE (symbol
);
963 if (BUFFER_LOCAL_VALUEP (valcontents
)
964 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
965 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
967 SET_SYMBOL_VALUE (symbol
, newval
);
971 /* Set up SYMBOL to refer to its global binding.
972 This makes it safe to alter the status of other bindings. */
975 swap_in_global_binding (symbol
)
978 Lisp_Object valcontents
, cdr
;
980 valcontents
= SYMBOL_VALUE (symbol
);
981 if (!BUFFER_LOCAL_VALUEP (valcontents
)
982 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
984 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
986 /* Unload the previously loaded binding. */
988 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
990 /* Select the global binding in the symbol. */
992 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
994 /* Indicate that the global binding is set up now. */
995 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
996 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
997 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
998 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1001 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1002 VALCONTENTS is the contents of its value cell,
1003 which points to a struct Lisp_Buffer_Local_Value.
1005 Return the value forwarded one step past the buffer-local stage.
1006 This could be another forwarding pointer. */
1009 swap_in_symval_forwarding (symbol
, valcontents
)
1010 Lisp_Object symbol
, valcontents
;
1012 register Lisp_Object tem1
;
1014 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1017 || current_buffer
!= XBUFFER (tem1
)
1018 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1019 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1021 if (XSYMBOL (symbol
)->indirect_variable
)
1022 symbol
= indirect_variable (symbol
);
1024 /* Unload the previously loaded binding. */
1025 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1027 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1028 /* Choose the new binding. */
1029 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1030 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1031 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1034 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1035 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1037 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1039 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1042 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1044 /* Load the new binding. */
1045 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1046 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1047 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1048 store_symval_forwarding (symbol
,
1049 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1052 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1055 /* Find the value of a symbol, returning Qunbound if it's not bound.
1056 This is helpful for code which just wants to get a variable's value
1057 if it has one, without signaling an error.
1058 Note that it must not be possible to quit
1059 within this function. Great care is required for this. */
1062 find_symbol_value (symbol
)
1065 register Lisp_Object valcontents
;
1066 register Lisp_Object val
;
1068 CHECK_SYMBOL (symbol
);
1069 valcontents
= SYMBOL_VALUE (symbol
);
1071 if (BUFFER_LOCAL_VALUEP (valcontents
)
1072 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1073 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1075 if (MISCP (valcontents
))
1077 switch (XMISCTYPE (valcontents
))
1079 case Lisp_Misc_Intfwd
:
1080 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1083 case Lisp_Misc_Boolfwd
:
1084 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1086 case Lisp_Misc_Objfwd
:
1087 return *XOBJFWD (valcontents
)->objvar
;
1089 case Lisp_Misc_Buffer_Objfwd
:
1090 return PER_BUFFER_VALUE (current_buffer
,
1091 XBUFFER_OBJFWD (valcontents
)->offset
);
1093 case Lisp_Misc_Kboard_Objfwd
:
1094 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1095 + (char *)current_kboard
);
1102 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1103 doc
: /* Return SYMBOL's value. Error if that is void. */)
1109 val
= find_symbol_value (symbol
);
1110 if (!EQ (val
, Qunbound
))
1113 xsignal1 (Qvoid_variable
, symbol
);
1116 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1117 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1119 register Lisp_Object symbol
, newval
;
1121 return set_internal (symbol
, newval
, current_buffer
, 0);
1124 /* Return 1 if SYMBOL currently has a let-binding
1125 which was made in the buffer that is now current. */
1128 let_shadows_buffer_binding_p (symbol
)
1131 volatile struct specbinding
*p
;
1133 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1135 && CONSP (p
->symbol
))
1137 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1138 if ((EQ (symbol
, let_bound_symbol
)
1139 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1140 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1141 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1145 return p
>= specpdl
;
1148 /* Store the value NEWVAL into SYMBOL.
1149 If buffer-locality is an issue, BUF specifies which buffer to use.
1150 (0 stands for the current buffer.)
1152 If BINDFLAG is zero, then if this symbol is supposed to become
1153 local in every buffer where it is set, then we make it local.
1154 If BINDFLAG is nonzero, we don't do that. */
1157 set_internal (symbol
, newval
, buf
, bindflag
)
1158 register Lisp_Object symbol
, newval
;
1162 int voide
= EQ (newval
, Qunbound
);
1164 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1167 buf
= current_buffer
;
1169 /* If restoring in a dead buffer, do nothing. */
1170 if (NILP (buf
->name
))
1173 CHECK_SYMBOL (symbol
);
1174 if (SYMBOL_CONSTANT_P (symbol
)
1175 && (NILP (Fkeywordp (symbol
))
1176 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1177 xsignal1 (Qsetting_constant
, symbol
);
1179 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1181 if (BUFFER_OBJFWDP (valcontents
))
1183 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1184 int idx
= PER_BUFFER_IDX (offset
);
1187 && !let_shadows_buffer_binding_p (symbol
))
1188 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1190 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1191 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1193 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1194 if (XSYMBOL (symbol
)->indirect_variable
)
1195 symbol
= indirect_variable (symbol
);
1197 /* What binding is loaded right now? */
1198 current_alist_element
1199 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1201 /* If the current buffer is not the buffer whose binding is
1202 loaded, or if there may be frame-local bindings and the frame
1203 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1204 the default binding is loaded, the loaded binding may be the
1206 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1207 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1208 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1209 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1210 || (BUFFER_LOCAL_VALUEP (valcontents
)
1211 && EQ (XCAR (current_alist_element
),
1212 current_alist_element
)))
1214 /* The currently loaded binding is not necessarily valid.
1215 We need to unload it, and choose a new binding. */
1217 /* Write out `realvalue' to the old loaded binding. */
1218 Fsetcdr (current_alist_element
,
1219 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1221 /* Find the new binding. */
1222 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1223 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1224 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1228 /* This buffer still sees the default value. */
1230 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1231 or if this is `let' rather than `set',
1232 make CURRENT-ALIST-ELEMENT point to itself,
1233 indicating that we're seeing the default value.
1234 Likewise if the variable has been let-bound
1235 in the current buffer. */
1236 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1237 || let_shadows_buffer_binding_p (symbol
))
1239 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1241 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1242 tem1
= Fassq (symbol
,
1243 XFRAME (selected_frame
)->param_alist
);
1246 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1248 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1250 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1251 and we're not within a let that was made for this buffer,
1252 create a new buffer-local binding for the variable.
1253 That means, give this buffer a new assoc for a local value
1254 and load that binding. */
1257 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1258 buf
->local_var_alist
1259 = Fcons (tem1
, buf
->local_var_alist
);
1263 /* Record which binding is now loaded. */
1264 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1267 /* Set `buffer' and `frame' slots for the binding now loaded. */
1268 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1269 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1271 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1274 /* If storing void (making the symbol void), forward only through
1275 buffer-local indicator, not through Lisp_Objfwd, etc. */
1277 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1279 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1281 /* If we just set a variable whose current binding is frame-local,
1282 store the new value in the frame parameter too. */
1284 if (BUFFER_LOCAL_VALUEP (valcontents
)
1285 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1287 /* What binding is loaded right now? */
1288 current_alist_element
1289 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1291 /* If the current buffer is not the buffer whose binding is
1292 loaded, or if there may be frame-local bindings and the frame
1293 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1294 the default binding is loaded, the loaded binding may be the
1296 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1297 XSETCDR (current_alist_element
, newval
);
1303 /* Access or set a buffer-local symbol's default value. */
1305 /* Return the default value of SYMBOL, but don't check for voidness.
1306 Return Qunbound if it is void. */
1309 default_value (symbol
)
1312 register Lisp_Object valcontents
;
1314 CHECK_SYMBOL (symbol
);
1315 valcontents
= SYMBOL_VALUE (symbol
);
1317 /* For a built-in buffer-local variable, get the default value
1318 rather than letting do_symval_forwarding get the current value. */
1319 if (BUFFER_OBJFWDP (valcontents
))
1321 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1322 if (PER_BUFFER_IDX (offset
) != 0)
1323 return PER_BUFFER_DEFAULT (offset
);
1326 /* Handle user-created local variables. */
1327 if (BUFFER_LOCAL_VALUEP (valcontents
)
1328 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1330 /* If var is set up for a buffer that lacks a local value for it,
1331 the current value is nominally the default value.
1332 But the `realvalue' slot may be more up to date, since
1333 ordinary setq stores just that slot. So use that. */
1334 Lisp_Object current_alist_element
, alist_element_car
;
1335 current_alist_element
1336 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1337 alist_element_car
= XCAR (current_alist_element
);
1338 if (EQ (alist_element_car
, current_alist_element
))
1339 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1341 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1343 /* For other variables, get the current value. */
1344 return do_symval_forwarding (valcontents
);
1347 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1348 doc
: /* Return t if SYMBOL has a non-void default value.
1349 This is the value that is seen in buffers that do not have their own values
1350 for this variable. */)
1354 register Lisp_Object value
;
1356 value
= default_value (symbol
);
1357 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1360 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1361 doc
: /* Return SYMBOL's default value.
1362 This is the value that is seen in buffers that do not have their own values
1363 for this variable. The default value is meaningful for variables with
1364 local bindings in certain buffers. */)
1368 register Lisp_Object value
;
1370 value
= default_value (symbol
);
1371 if (!EQ (value
, Qunbound
))
1374 xsignal1 (Qvoid_variable
, symbol
);
1377 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1378 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1379 The default value is seen in buffers that do not have their own values
1380 for this variable. */)
1382 Lisp_Object symbol
, value
;
1384 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1386 CHECK_SYMBOL (symbol
);
1387 valcontents
= SYMBOL_VALUE (symbol
);
1389 /* Handle variables like case-fold-search that have special slots
1390 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1392 if (BUFFER_OBJFWDP (valcontents
))
1394 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1395 int idx
= PER_BUFFER_IDX (offset
);
1397 PER_BUFFER_DEFAULT (offset
) = value
;
1399 /* If this variable is not always local in all buffers,
1400 set it in the buffers that don't nominally have a local value. */
1405 for (b
= all_buffers
; b
; b
= b
->next
)
1406 if (!PER_BUFFER_VALUE_P (b
, idx
))
1407 PER_BUFFER_VALUE (b
, offset
) = value
;
1412 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1413 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1414 return Fset (symbol
, value
);
1416 /* Store new value into the DEFAULT-VALUE slot. */
1417 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1419 /* If the default binding is now loaded, set the REALVALUE slot too. */
1420 current_alist_element
1421 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1422 alist_element_buffer
= Fcar (current_alist_element
);
1423 if (EQ (alist_element_buffer
, current_alist_element
))
1424 store_symval_forwarding (symbol
,
1425 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1431 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1432 doc
: /* Set the default value of variable VAR to VALUE.
1433 VAR, the variable name, is literal (not evaluated);
1434 VALUE is an expression: it is evaluated and its value returned.
1435 The default value of a variable is seen in buffers
1436 that do not have their own values for the variable.
1438 More generally, you can use multiple variables and values, as in
1439 (setq-default VAR VALUE VAR VALUE...)
1440 This sets each VAR's default value to the corresponding VALUE.
1441 The VALUE for the Nth VAR can refer to the new default values
1443 usage: (setq-default [VAR VALUE...]) */)
1447 register Lisp_Object args_left
;
1448 register Lisp_Object val
, symbol
;
1449 struct gcpro gcpro1
;
1459 val
= Feval (Fcar (Fcdr (args_left
)));
1460 symbol
= XCAR (args_left
);
1461 Fset_default (symbol
, val
);
1462 args_left
= Fcdr (XCDR (args_left
));
1464 while (!NILP (args_left
));
1470 /* Lisp functions for creating and removing buffer-local variables. */
1472 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1473 1, 1, "vMake Variable Buffer Local: ",
1474 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1475 At any time, the value for the current buffer is in effect,
1476 unless the variable has never been set in this buffer,
1477 in which case the default value is in effect.
1478 Note that binding the variable with `let', or setting it while
1479 a `let'-style binding made in this buffer is in effect,
1480 does not make the variable buffer-local. Return VARIABLE.
1482 In most cases it is better to use `make-local-variable',
1483 which makes a variable local in just one buffer.
1485 The function `default-value' gets the default value and `set-default' sets it. */)
1487 register Lisp_Object variable
;
1489 register Lisp_Object tem
, valcontents
, newval
;
1491 CHECK_SYMBOL (variable
);
1492 variable
= indirect_variable (variable
);
1494 valcontents
= SYMBOL_VALUE (variable
);
1495 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1496 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1498 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1500 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1502 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1505 if (EQ (valcontents
, Qunbound
))
1506 SET_SYMBOL_VALUE (variable
, Qnil
);
1507 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1509 newval
= allocate_misc ();
1510 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1511 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1512 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1513 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1514 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1515 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1516 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1517 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1518 SET_SYMBOL_VALUE (variable
, newval
);
1522 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1523 1, 1, "vMake Local Variable: ",
1524 doc
: /* Make VARIABLE have a separate value in the current buffer.
1525 Other buffers will continue to share a common default value.
1526 \(The buffer-local value of VARIABLE starts out as the same value
1527 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1530 If the variable is already arranged to become local when set,
1531 this function causes a local value to exist for this buffer,
1532 just as setting the variable would do.
1534 This function returns VARIABLE, and therefore
1535 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1538 See also `make-variable-buffer-local'.
1540 Do not use `make-local-variable' to make a hook variable buffer-local.
1541 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1543 register Lisp_Object variable
;
1545 register Lisp_Object tem
, valcontents
;
1547 CHECK_SYMBOL (variable
);
1548 variable
= indirect_variable (variable
);
1550 valcontents
= SYMBOL_VALUE (variable
);
1551 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1552 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1554 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1556 tem
= Fboundp (variable
);
1558 /* Make sure the symbol has a local value in this particular buffer,
1559 by setting it to the same value it already has. */
1560 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1563 /* Make sure symbol is set up to hold per-buffer values. */
1564 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1567 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1569 newval
= allocate_misc ();
1570 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1571 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1572 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1573 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1574 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1575 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1576 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1577 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1578 SET_SYMBOL_VALUE (variable
, newval
);;
1580 /* Make sure this buffer has its own value of symbol. */
1581 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1584 /* Swap out any local binding for some other buffer, and make
1585 sure the current value is permanently recorded, if it's the
1587 find_symbol_value (variable
);
1589 current_buffer
->local_var_alist
1590 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1591 current_buffer
->local_var_alist
);
1593 /* Make sure symbol does not think it is set up for this buffer;
1594 force it to look once again for this buffer's value. */
1596 Lisp_Object
*pvalbuf
;
1598 valcontents
= SYMBOL_VALUE (variable
);
1600 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1601 if (current_buffer
== XBUFFER (*pvalbuf
))
1603 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1607 /* If the symbol forwards into a C variable, then load the binding
1608 for this buffer now. If C code modifies the variable before we
1609 load the binding in, then that new value will clobber the default
1610 binding the next time we unload it. */
1611 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1612 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1613 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1618 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1619 1, 1, "vKill Local Variable: ",
1620 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1621 From now on the default value will apply in this buffer. Return VARIABLE. */)
1623 register Lisp_Object variable
;
1625 register Lisp_Object tem
, valcontents
;
1627 CHECK_SYMBOL (variable
);
1628 variable
= indirect_variable (variable
);
1630 valcontents
= SYMBOL_VALUE (variable
);
1632 if (BUFFER_OBJFWDP (valcontents
))
1634 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1635 int idx
= PER_BUFFER_IDX (offset
);
1639 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1640 PER_BUFFER_VALUE (current_buffer
, offset
)
1641 = PER_BUFFER_DEFAULT (offset
);
1646 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1647 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1650 /* Get rid of this buffer's alist element, if any. */
1652 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1654 current_buffer
->local_var_alist
1655 = Fdelq (tem
, current_buffer
->local_var_alist
);
1657 /* If the symbol is set up with the current buffer's binding
1658 loaded, recompute its value. We have to do it now, or else
1659 forwarded objects won't work right. */
1661 Lisp_Object
*pvalbuf
, buf
;
1662 valcontents
= SYMBOL_VALUE (variable
);
1663 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1664 XSETBUFFER (buf
, current_buffer
);
1665 if (EQ (buf
, *pvalbuf
))
1668 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1669 find_symbol_value (variable
);
1676 /* Lisp functions for creating and removing buffer-local variables. */
1678 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1679 1, 1, "vMake Variable Frame Local: ",
1680 doc
: /* Enable VARIABLE to have frame-local bindings.
1681 This does not create any frame-local bindings for VARIABLE,
1682 it just makes them possible.
1684 A frame-local binding is actually a frame parameter value.
1685 If a frame F has a value for the frame parameter named VARIABLE,
1686 that also acts as a frame-local binding for VARIABLE in F--
1687 provided this function has been called to enable VARIABLE
1688 to have frame-local bindings at all.
1690 The only way to create a frame-local binding for VARIABLE in a frame
1691 is to set the VARIABLE frame parameter of that frame. See
1692 `modify-frame-parameters' for how to set frame parameters.
1694 Buffer-local bindings take precedence over frame-local bindings. */)
1696 register Lisp_Object variable
;
1698 register Lisp_Object tem
, valcontents
, newval
;
1700 CHECK_SYMBOL (variable
);
1701 variable
= indirect_variable (variable
);
1703 valcontents
= SYMBOL_VALUE (variable
);
1704 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1705 || BUFFER_OBJFWDP (valcontents
))
1706 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1708 if (BUFFER_LOCAL_VALUEP (valcontents
)
1709 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1711 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1715 if (EQ (valcontents
, Qunbound
))
1716 SET_SYMBOL_VALUE (variable
, Qnil
);
1717 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1719 newval
= allocate_misc ();
1720 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1721 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1722 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1723 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1724 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1725 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1726 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1727 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1728 SET_SYMBOL_VALUE (variable
, newval
);
1732 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1734 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1735 BUFFER defaults to the current buffer. */)
1737 register Lisp_Object variable
, buffer
;
1739 Lisp_Object valcontents
;
1740 register struct buffer
*buf
;
1743 buf
= current_buffer
;
1746 CHECK_BUFFER (buffer
);
1747 buf
= XBUFFER (buffer
);
1750 CHECK_SYMBOL (variable
);
1751 variable
= indirect_variable (variable
);
1753 valcontents
= SYMBOL_VALUE (variable
);
1754 if (BUFFER_LOCAL_VALUEP (valcontents
)
1755 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1757 Lisp_Object tail
, elt
;
1759 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1762 if (EQ (variable
, XCAR (elt
)))
1766 if (BUFFER_OBJFWDP (valcontents
))
1768 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1769 int idx
= PER_BUFFER_IDX (offset
);
1770 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1776 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1778 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1779 More precisely, this means that setting the variable \(with `set' or`setq'),
1780 while it does not have a `let'-style binding that was made in BUFFER,
1781 will produce a buffer local binding. See Info node
1782 `(elisp)Creating Buffer-Local'.
1783 BUFFER defaults to the current buffer. */)
1785 register Lisp_Object variable
, buffer
;
1787 Lisp_Object valcontents
;
1788 register struct buffer
*buf
;
1791 buf
= current_buffer
;
1794 CHECK_BUFFER (buffer
);
1795 buf
= XBUFFER (buffer
);
1798 CHECK_SYMBOL (variable
);
1799 variable
= indirect_variable (variable
);
1801 valcontents
= SYMBOL_VALUE (variable
);
1803 /* This means that make-variable-buffer-local was done. */
1804 if (BUFFER_LOCAL_VALUEP (valcontents
))
1806 /* All these slots become local if they are set. */
1807 if (BUFFER_OBJFWDP (valcontents
))
1809 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1811 Lisp_Object tail
, elt
;
1812 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1815 if (EQ (variable
, XCAR (elt
)))
1822 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1824 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1825 If the current binding is buffer-local, the value is the current buffer.
1826 If the current binding is frame-local, the value is the selected frame.
1827 If the current binding is global (the default), the value is nil. */)
1829 register Lisp_Object variable
;
1831 Lisp_Object valcontents
;
1833 CHECK_SYMBOL (variable
);
1834 variable
= indirect_variable (variable
);
1836 /* Make sure the current binding is actually swapped in. */
1837 find_symbol_value (variable
);
1839 valcontents
= XSYMBOL (variable
)->value
;
1841 if (BUFFER_LOCAL_VALUEP (valcontents
)
1842 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1843 || BUFFER_OBJFWDP (valcontents
))
1845 /* For a local variable, record both the symbol and which
1846 buffer's or frame's value we are saving. */
1847 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1848 return Fcurrent_buffer ();
1849 else if (!BUFFER_OBJFWDP (valcontents
)
1850 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1851 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1857 /* Find the function at the end of a chain of symbol function indirections. */
1859 /* If OBJECT is a symbol, find the end of its function chain and
1860 return the value found there. If OBJECT is not a symbol, just
1861 return it. If there is a cycle in the function chain, signal a
1862 cyclic-function-indirection error.
1864 This is like Findirect_function, except that it doesn't signal an
1865 error if the chain ends up unbound. */
1867 indirect_function (object
)
1868 register Lisp_Object object
;
1870 Lisp_Object tortoise
, hare
;
1872 hare
= tortoise
= object
;
1876 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1878 hare
= XSYMBOL (hare
)->function
;
1879 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1881 hare
= XSYMBOL (hare
)->function
;
1883 tortoise
= XSYMBOL (tortoise
)->function
;
1885 if (EQ (hare
, tortoise
))
1886 xsignal1 (Qcyclic_function_indirection
, object
);
1892 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1893 doc
: /* Return the function at the end of OBJECT's function chain.
1894 If OBJECT is not a symbol, just return it. Otherwise, follow all
1895 function indirections to find the final function binding and return it.
1896 If the final symbol in the chain is unbound, signal a void-function error.
1897 Optional arg NOERROR non-nil means to return nil instead of signalling.
1898 Signal a cyclic-function-indirection error if there is a loop in the
1899 function chain of symbols. */)
1901 register Lisp_Object object
;
1902 Lisp_Object noerror
;
1906 /* Optimize for no indirection. */
1908 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1909 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1910 result
= indirect_function (result
);
1911 if (!EQ (result
, Qunbound
))
1915 xsignal1 (Qvoid_function
, object
);
1920 /* Extract and set vector and string elements */
1922 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1923 doc
: /* Return the element of ARRAY at index IDX.
1924 ARRAY may be a vector, a string, a char-table, a bool-vector,
1925 or a byte-code object. IDX starts at 0. */)
1927 register Lisp_Object array
;
1930 register int idxval
;
1933 idxval
= XINT (idx
);
1934 if (STRINGP (array
))
1938 if (idxval
< 0 || idxval
>= SCHARS (array
))
1939 args_out_of_range (array
, idx
);
1940 if (! STRING_MULTIBYTE (array
))
1941 return make_number ((unsigned char) SREF (array
, idxval
));
1942 idxval_byte
= string_char_to_byte (array
, idxval
);
1944 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1945 SBYTES (array
) - idxval_byte
);
1946 return make_number (c
);
1948 else if (BOOL_VECTOR_P (array
))
1952 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1953 args_out_of_range (array
, idx
);
1955 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1956 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1958 else if (CHAR_TABLE_P (array
))
1960 CHECK_CHARACTER (idx
);
1961 return CHAR_TABLE_REF (array
, idxval
);
1966 if (VECTORP (array
))
1967 size
= XVECTOR (array
)->size
;
1968 else if (COMPILEDP (array
))
1969 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1971 wrong_type_argument (Qarrayp
, array
);
1973 if (idxval
< 0 || idxval
>= size
)
1974 args_out_of_range (array
, idx
);
1975 return XVECTOR (array
)->contents
[idxval
];
1979 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1980 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
1981 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
1982 bool-vector. IDX starts at 0. */)
1983 (array
, idx
, newelt
)
1984 register Lisp_Object array
;
1985 Lisp_Object idx
, newelt
;
1987 register int idxval
;
1990 idxval
= XINT (idx
);
1991 CHECK_ARRAY (array
, Qarrayp
);
1992 CHECK_IMPURE (array
);
1994 if (VECTORP (array
))
1996 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1997 args_out_of_range (array
, idx
);
1998 XVECTOR (array
)->contents
[idxval
] = newelt
;
2000 else if (BOOL_VECTOR_P (array
))
2004 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2005 args_out_of_range (array
, idx
);
2007 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2009 if (! NILP (newelt
))
2010 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2012 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2013 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2015 else if (CHAR_TABLE_P (array
))
2017 CHECK_CHARACTER (idx
);
2018 CHAR_TABLE_SET (array
, idxval
, newelt
);
2020 else if (STRING_MULTIBYTE (array
))
2022 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2023 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2025 if (idxval
< 0 || idxval
>= SCHARS (array
))
2026 args_out_of_range (array
, idx
);
2027 CHECK_CHARACTER (newelt
);
2029 nbytes
= SBYTES (array
);
2031 idxval_byte
= string_char_to_byte (array
, idxval
);
2032 p1
= SDATA (array
) + idxval_byte
;
2033 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2034 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2035 if (prev_bytes
!= new_bytes
)
2037 /* We must relocate the string data. */
2038 int nchars
= SCHARS (array
);
2042 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2043 bcopy (SDATA (array
), str
, nbytes
);
2044 allocate_string_data (XSTRING (array
), nchars
,
2045 nbytes
+ new_bytes
- prev_bytes
);
2046 bcopy (str
, SDATA (array
), idxval_byte
);
2047 p1
= SDATA (array
) + idxval_byte
;
2048 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2049 nbytes
- (idxval_byte
+ prev_bytes
));
2051 clear_string_char_byte_cache ();
2058 if (idxval
< 0 || idxval
>= SCHARS (array
))
2059 args_out_of_range (array
, idx
);
2060 CHECK_NUMBER (newelt
);
2062 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2063 args_out_of_range (array
, newelt
);
2064 SSET (array
, idxval
, XINT (newelt
));
2070 /* Arithmetic functions */
2072 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2075 arithcompare (num1
, num2
, comparison
)
2076 Lisp_Object num1
, num2
;
2077 enum comparison comparison
;
2079 double f1
= 0, f2
= 0;
2082 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2083 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2085 if (FLOATP (num1
) || FLOATP (num2
))
2088 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2089 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2095 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2100 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2105 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2110 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2115 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2120 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2129 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2130 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2132 register Lisp_Object num1
, num2
;
2134 return arithcompare (num1
, num2
, equal
);
2137 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2138 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2140 register Lisp_Object num1
, num2
;
2142 return arithcompare (num1
, num2
, less
);
2145 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2146 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2148 register Lisp_Object num1
, num2
;
2150 return arithcompare (num1
, num2
, grtr
);
2153 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2154 doc
: /* Return t if first arg is less than or equal to second arg.
2155 Both must be numbers or markers. */)
2157 register Lisp_Object num1
, num2
;
2159 return arithcompare (num1
, num2
, less_or_equal
);
2162 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2163 doc
: /* Return t if first arg is greater than or equal to second arg.
2164 Both must be numbers or markers. */)
2166 register Lisp_Object num1
, num2
;
2168 return arithcompare (num1
, num2
, grtr_or_equal
);
2171 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2172 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2174 register Lisp_Object num1
, num2
;
2176 return arithcompare (num1
, num2
, notequal
);
2179 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2180 doc
: /* Return t if NUMBER is zero. */)
2182 register Lisp_Object number
;
2184 CHECK_NUMBER_OR_FLOAT (number
);
2186 if (FLOATP (number
))
2188 if (XFLOAT_DATA (number
) == 0.0)
2198 /* Convert between long values and pairs of Lisp integers. */
2204 unsigned long top
= i
>> 16;
2205 unsigned int bot
= i
& 0xFFFF;
2207 return make_number (bot
);
2208 if (top
== (unsigned long)-1 >> 16)
2209 return Fcons (make_number (-1), make_number (bot
));
2210 return Fcons (make_number (top
), make_number (bot
));
2217 Lisp_Object top
, bot
;
2224 return ((XINT (top
) << 16) | XINT (bot
));
2227 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2228 doc
: /* Return the decimal representation of NUMBER as a string.
2229 Uses a minus sign if negative.
2230 NUMBER may be an integer or a floating point number. */)
2234 char buffer
[VALBITS
];
2236 CHECK_NUMBER_OR_FLOAT (number
);
2238 if (FLOATP (number
))
2240 char pigbuf
[350]; /* see comments in float_to_string */
2242 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2243 return build_string (pigbuf
);
2246 if (sizeof (int) == sizeof (EMACS_INT
))
2247 sprintf (buffer
, "%d", XINT (number
));
2248 else if (sizeof (long) == sizeof (EMACS_INT
))
2249 sprintf (buffer
, "%ld", (long) XINT (number
));
2252 return build_string (buffer
);
2256 digit_to_number (character
, base
)
2257 int character
, base
;
2261 if (character
>= '0' && character
<= '9')
2262 digit
= character
- '0';
2263 else if (character
>= 'a' && character
<= 'z')
2264 digit
= character
- 'a' + 10;
2265 else if (character
>= 'A' && character
<= 'Z')
2266 digit
= character
- 'A' + 10;
2276 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2277 doc
: /* Parse STRING as a decimal number and return the number.
2278 This parses both integers and floating point numbers.
2279 It ignores leading spaces and tabs.
2281 If BASE, interpret STRING as a number in that base. If BASE isn't
2282 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2283 If the base used is not 10, floating point is not recognized. */)
2285 register Lisp_Object string
, base
;
2287 register unsigned char *p
;
2292 CHECK_STRING (string
);
2298 CHECK_NUMBER (base
);
2300 if (b
< 2 || b
> 16)
2301 xsignal1 (Qargs_out_of_range
, base
);
2304 /* Skip any whitespace at the front of the number. Some versions of
2305 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2307 while (*p
== ' ' || *p
== '\t')
2318 if (isfloat_string (p
) && b
== 10)
2319 val
= make_float (sign
* atof (p
));
2326 int digit
= digit_to_number (*p
++, b
);
2332 val
= make_fixnum_or_float (sign
* v
);
2352 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2353 int, Lisp_Object
*));
2354 extern Lisp_Object
fmod_float ();
2357 arith_driver (code
, nargs
, args
)
2360 register Lisp_Object
*args
;
2362 register Lisp_Object val
;
2363 register int argnum
;
2364 register EMACS_INT accum
= 0;
2365 register EMACS_INT next
;
2367 switch (SWITCH_ENUM_CAST (code
))
2385 for (argnum
= 0; argnum
< nargs
; argnum
++)
2387 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2389 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2392 return float_arith_driver ((double) accum
, argnum
, code
,
2395 next
= XINT (args
[argnum
]);
2396 switch (SWITCH_ENUM_CAST (code
))
2402 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2413 xsignal0 (Qarith_error
);
2427 if (!argnum
|| next
> accum
)
2431 if (!argnum
|| next
< accum
)
2437 XSETINT (val
, accum
);
2442 #define isnan(x) ((x) != (x))
2445 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2447 register int argnum
;
2450 register Lisp_Object
*args
;
2452 register Lisp_Object val
;
2455 for (; argnum
< nargs
; argnum
++)
2457 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2458 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2462 next
= XFLOAT_DATA (val
);
2466 args
[argnum
] = val
; /* runs into a compiler bug. */
2467 next
= XINT (args
[argnum
]);
2469 switch (SWITCH_ENUM_CAST (code
))
2475 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2485 if (! IEEE_FLOATING_POINT
&& next
== 0)
2486 xsignal0 (Qarith_error
);
2493 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2495 if (!argnum
|| isnan (next
) || next
> accum
)
2499 if (!argnum
|| isnan (next
) || next
< accum
)
2505 return make_float (accum
);
2509 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2510 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2511 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2516 return arith_driver (Aadd
, nargs
, args
);
2519 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2520 doc
: /* Negate number or subtract numbers or markers and return the result.
2521 With one arg, negates it. With more than one arg,
2522 subtracts all but the first from the first.
2523 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2528 return arith_driver (Asub
, nargs
, args
);
2531 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2532 doc
: /* Return product of any number of arguments, which are numbers or markers.
2533 usage: (* &rest NUMBERS-OR-MARKERS) */)
2538 return arith_driver (Amult
, nargs
, args
);
2541 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2542 doc
: /* Return first argument divided by all the remaining arguments.
2543 The arguments must be numbers or markers.
2544 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2550 for (argnum
= 2; argnum
< nargs
; argnum
++)
2551 if (FLOATP (args
[argnum
]))
2552 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2553 return arith_driver (Adiv
, nargs
, args
);
2556 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2557 doc
: /* Return remainder of X divided by Y.
2558 Both must be integers or markers. */)
2560 register Lisp_Object x
, y
;
2564 CHECK_NUMBER_COERCE_MARKER (x
);
2565 CHECK_NUMBER_COERCE_MARKER (y
);
2567 if (XFASTINT (y
) == 0)
2568 xsignal0 (Qarith_error
);
2570 XSETINT (val
, XINT (x
) % XINT (y
));
2584 /* If the magnitude of the result exceeds that of the divisor, or
2585 the sign of the result does not agree with that of the dividend,
2586 iterate with the reduced value. This does not yield a
2587 particularly accurate result, but at least it will be in the
2588 range promised by fmod. */
2590 r
-= f2
* floor (r
/ f2
);
2591 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2595 #endif /* ! HAVE_FMOD */
2597 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2598 doc
: /* Return X modulo Y.
2599 The result falls between zero (inclusive) and Y (exclusive).
2600 Both X and Y must be numbers or markers. */)
2602 register Lisp_Object x
, y
;
2607 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2608 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2610 if (FLOATP (x
) || FLOATP (y
))
2611 return fmod_float (x
, y
);
2617 xsignal0 (Qarith_error
);
2621 /* If the "remainder" comes out with the wrong sign, fix it. */
2622 if (i2
< 0 ? i1
> 0 : i1
< 0)
2629 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2630 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2631 The value is always a number; markers are converted to numbers.
2632 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2637 return arith_driver (Amax
, nargs
, args
);
2640 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2641 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2642 The value is always a number; markers are converted to numbers.
2643 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2648 return arith_driver (Amin
, nargs
, args
);
2651 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2652 doc
: /* Return bitwise-and of all the arguments.
2653 Arguments may be integers, or markers converted to integers.
2654 usage: (logand &rest INTS-OR-MARKERS) */)
2659 return arith_driver (Alogand
, nargs
, args
);
2662 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2663 doc
: /* Return bitwise-or of all the arguments.
2664 Arguments may be integers, or markers converted to integers.
2665 usage: (logior &rest INTS-OR-MARKERS) */)
2670 return arith_driver (Alogior
, nargs
, args
);
2673 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2674 doc
: /* Return bitwise-exclusive-or of all the arguments.
2675 Arguments may be integers, or markers converted to integers.
2676 usage: (logxor &rest INTS-OR-MARKERS) */)
2681 return arith_driver (Alogxor
, nargs
, args
);
2684 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2685 doc
: /* Return VALUE with its bits shifted left by COUNT.
2686 If COUNT is negative, shifting is actually to the right.
2687 In this case, the sign bit is duplicated. */)
2689 register Lisp_Object value
, count
;
2691 register Lisp_Object val
;
2693 CHECK_NUMBER (value
);
2694 CHECK_NUMBER (count
);
2696 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2698 else if (XINT (count
) > 0)
2699 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2700 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2701 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2703 XSETINT (val
, XINT (value
) >> -XINT (count
));
2707 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2708 doc
: /* Return VALUE with its bits shifted left by COUNT.
2709 If COUNT is negative, shifting is actually to the right.
2710 In this case, zeros are shifted in on the left. */)
2712 register Lisp_Object value
, count
;
2714 register Lisp_Object val
;
2716 CHECK_NUMBER (value
);
2717 CHECK_NUMBER (count
);
2719 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2721 else if (XINT (count
) > 0)
2722 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2723 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2726 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2730 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2731 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2732 Markers are converted to integers. */)
2734 register Lisp_Object number
;
2736 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2738 if (FLOATP (number
))
2739 return (make_float (1.0 + XFLOAT_DATA (number
)));
2741 XSETINT (number
, XINT (number
) + 1);
2745 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2746 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2747 Markers are converted to integers. */)
2749 register Lisp_Object number
;
2751 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2753 if (FLOATP (number
))
2754 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2756 XSETINT (number
, XINT (number
) - 1);
2760 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2761 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2763 register Lisp_Object number
;
2765 CHECK_NUMBER (number
);
2766 XSETINT (number
, ~XINT (number
));
2770 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2771 doc
: /* Return the byteorder for the machine.
2772 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2773 lowercase l) for small endian machines. */)
2776 unsigned i
= 0x04030201;
2777 int order
= *(char *)&i
== 1 ? 108 : 66;
2779 return make_number (order
);
2787 Lisp_Object error_tail
, arith_tail
;
2789 Qquote
= intern ("quote");
2790 Qlambda
= intern ("lambda");
2791 Qsubr
= intern ("subr");
2792 Qerror_conditions
= intern ("error-conditions");
2793 Qerror_message
= intern ("error-message");
2794 Qtop_level
= intern ("top-level");
2796 Qerror
= intern ("error");
2797 Qquit
= intern ("quit");
2798 Qwrong_type_argument
= intern ("wrong-type-argument");
2799 Qargs_out_of_range
= intern ("args-out-of-range");
2800 Qvoid_function
= intern ("void-function");
2801 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2802 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2803 Qvoid_variable
= intern ("void-variable");
2804 Qsetting_constant
= intern ("setting-constant");
2805 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2807 Qinvalid_function
= intern ("invalid-function");
2808 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2809 Qno_catch
= intern ("no-catch");
2810 Qend_of_file
= intern ("end-of-file");
2811 Qarith_error
= intern ("arith-error");
2812 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2813 Qend_of_buffer
= intern ("end-of-buffer");
2814 Qbuffer_read_only
= intern ("buffer-read-only");
2815 Qtext_read_only
= intern ("text-read-only");
2816 Qmark_inactive
= intern ("mark-inactive");
2818 Qlistp
= intern ("listp");
2819 Qconsp
= intern ("consp");
2820 Qsymbolp
= intern ("symbolp");
2821 Qkeywordp
= intern ("keywordp");
2822 Qintegerp
= intern ("integerp");
2823 Qnatnump
= intern ("natnump");
2824 Qwholenump
= intern ("wholenump");
2825 Qstringp
= intern ("stringp");
2826 Qarrayp
= intern ("arrayp");
2827 Qsequencep
= intern ("sequencep");
2828 Qbufferp
= intern ("bufferp");
2829 Qvectorp
= intern ("vectorp");
2830 Qchar_or_string_p
= intern ("char-or-string-p");
2831 Qmarkerp
= intern ("markerp");
2832 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2833 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2834 Qboundp
= intern ("boundp");
2835 Qfboundp
= intern ("fboundp");
2837 Qfloatp
= intern ("floatp");
2838 Qnumberp
= intern ("numberp");
2839 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2841 Qchar_table_p
= intern ("char-table-p");
2842 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2844 Qsubrp
= intern ("subrp");
2845 Qunevalled
= intern ("unevalled");
2846 Qmany
= intern ("many");
2848 Qcdr
= intern ("cdr");
2850 /* Handle automatic advice activation */
2851 Qad_advice_info
= intern ("ad-advice-info");
2852 Qad_activate_internal
= intern ("ad-activate-internal");
2854 error_tail
= Fcons (Qerror
, Qnil
);
2856 /* ERROR is used as a signaler for random errors for which nothing else is right */
2858 Fput (Qerror
, Qerror_conditions
,
2860 Fput (Qerror
, Qerror_message
,
2861 build_string ("error"));
2863 Fput (Qquit
, Qerror_conditions
,
2864 Fcons (Qquit
, Qnil
));
2865 Fput (Qquit
, Qerror_message
,
2866 build_string ("Quit"));
2868 Fput (Qwrong_type_argument
, Qerror_conditions
,
2869 Fcons (Qwrong_type_argument
, error_tail
));
2870 Fput (Qwrong_type_argument
, Qerror_message
,
2871 build_string ("Wrong type argument"));
2873 Fput (Qargs_out_of_range
, Qerror_conditions
,
2874 Fcons (Qargs_out_of_range
, error_tail
));
2875 Fput (Qargs_out_of_range
, Qerror_message
,
2876 build_string ("Args out of range"));
2878 Fput (Qvoid_function
, Qerror_conditions
,
2879 Fcons (Qvoid_function
, error_tail
));
2880 Fput (Qvoid_function
, Qerror_message
,
2881 build_string ("Symbol's function definition is void"));
2883 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2884 Fcons (Qcyclic_function_indirection
, error_tail
));
2885 Fput (Qcyclic_function_indirection
, Qerror_message
,
2886 build_string ("Symbol's chain of function indirections contains a loop"));
2888 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2889 Fcons (Qcyclic_variable_indirection
, error_tail
));
2890 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2891 build_string ("Symbol's chain of variable indirections contains a loop"));
2893 Qcircular_list
= intern ("circular-list");
2894 staticpro (&Qcircular_list
);
2895 Fput (Qcircular_list
, Qerror_conditions
,
2896 Fcons (Qcircular_list
, error_tail
));
2897 Fput (Qcircular_list
, Qerror_message
,
2898 build_string ("List contains a loop"));
2900 Fput (Qvoid_variable
, Qerror_conditions
,
2901 Fcons (Qvoid_variable
, error_tail
));
2902 Fput (Qvoid_variable
, Qerror_message
,
2903 build_string ("Symbol's value as variable is void"));
2905 Fput (Qsetting_constant
, Qerror_conditions
,
2906 Fcons (Qsetting_constant
, error_tail
));
2907 Fput (Qsetting_constant
, Qerror_message
,
2908 build_string ("Attempt to set a constant symbol"));
2910 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2911 Fcons (Qinvalid_read_syntax
, error_tail
));
2912 Fput (Qinvalid_read_syntax
, Qerror_message
,
2913 build_string ("Invalid read syntax"));
2915 Fput (Qinvalid_function
, Qerror_conditions
,
2916 Fcons (Qinvalid_function
, error_tail
));
2917 Fput (Qinvalid_function
, Qerror_message
,
2918 build_string ("Invalid function"));
2920 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2921 Fcons (Qwrong_number_of_arguments
, error_tail
));
2922 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2923 build_string ("Wrong number of arguments"));
2925 Fput (Qno_catch
, Qerror_conditions
,
2926 Fcons (Qno_catch
, error_tail
));
2927 Fput (Qno_catch
, Qerror_message
,
2928 build_string ("No catch for tag"));
2930 Fput (Qend_of_file
, Qerror_conditions
,
2931 Fcons (Qend_of_file
, error_tail
));
2932 Fput (Qend_of_file
, Qerror_message
,
2933 build_string ("End of file during parsing"));
2935 arith_tail
= Fcons (Qarith_error
, error_tail
);
2936 Fput (Qarith_error
, Qerror_conditions
,
2938 Fput (Qarith_error
, Qerror_message
,
2939 build_string ("Arithmetic error"));
2941 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2942 Fcons (Qbeginning_of_buffer
, error_tail
));
2943 Fput (Qbeginning_of_buffer
, Qerror_message
,
2944 build_string ("Beginning of buffer"));
2946 Fput (Qend_of_buffer
, Qerror_conditions
,
2947 Fcons (Qend_of_buffer
, error_tail
));
2948 Fput (Qend_of_buffer
, Qerror_message
,
2949 build_string ("End of buffer"));
2951 Fput (Qbuffer_read_only
, Qerror_conditions
,
2952 Fcons (Qbuffer_read_only
, error_tail
));
2953 Fput (Qbuffer_read_only
, Qerror_message
,
2954 build_string ("Buffer is read-only"));
2956 Fput (Qtext_read_only
, Qerror_conditions
,
2957 Fcons (Qtext_read_only
, error_tail
));
2958 Fput (Qtext_read_only
, Qerror_message
,
2959 build_string ("Text is read-only"));
2961 Qrange_error
= intern ("range-error");
2962 Qdomain_error
= intern ("domain-error");
2963 Qsingularity_error
= intern ("singularity-error");
2964 Qoverflow_error
= intern ("overflow-error");
2965 Qunderflow_error
= intern ("underflow-error");
2967 Fput (Qdomain_error
, Qerror_conditions
,
2968 Fcons (Qdomain_error
, arith_tail
));
2969 Fput (Qdomain_error
, Qerror_message
,
2970 build_string ("Arithmetic domain error"));
2972 Fput (Qrange_error
, Qerror_conditions
,
2973 Fcons (Qrange_error
, arith_tail
));
2974 Fput (Qrange_error
, Qerror_message
,
2975 build_string ("Arithmetic range error"));
2977 Fput (Qsingularity_error
, Qerror_conditions
,
2978 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2979 Fput (Qsingularity_error
, Qerror_message
,
2980 build_string ("Arithmetic singularity error"));
2982 Fput (Qoverflow_error
, Qerror_conditions
,
2983 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2984 Fput (Qoverflow_error
, Qerror_message
,
2985 build_string ("Arithmetic overflow error"));
2987 Fput (Qunderflow_error
, Qerror_conditions
,
2988 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2989 Fput (Qunderflow_error
, Qerror_message
,
2990 build_string ("Arithmetic underflow error"));
2992 staticpro (&Qrange_error
);
2993 staticpro (&Qdomain_error
);
2994 staticpro (&Qsingularity_error
);
2995 staticpro (&Qoverflow_error
);
2996 staticpro (&Qunderflow_error
);
3000 staticpro (&Qquote
);
3001 staticpro (&Qlambda
);
3003 staticpro (&Qunbound
);
3004 staticpro (&Qerror_conditions
);
3005 staticpro (&Qerror_message
);
3006 staticpro (&Qtop_level
);
3008 staticpro (&Qerror
);
3010 staticpro (&Qwrong_type_argument
);
3011 staticpro (&Qargs_out_of_range
);
3012 staticpro (&Qvoid_function
);
3013 staticpro (&Qcyclic_function_indirection
);
3014 staticpro (&Qcyclic_variable_indirection
);
3015 staticpro (&Qvoid_variable
);
3016 staticpro (&Qsetting_constant
);
3017 staticpro (&Qinvalid_read_syntax
);
3018 staticpro (&Qwrong_number_of_arguments
);
3019 staticpro (&Qinvalid_function
);
3020 staticpro (&Qno_catch
);
3021 staticpro (&Qend_of_file
);
3022 staticpro (&Qarith_error
);
3023 staticpro (&Qbeginning_of_buffer
);
3024 staticpro (&Qend_of_buffer
);
3025 staticpro (&Qbuffer_read_only
);
3026 staticpro (&Qtext_read_only
);
3027 staticpro (&Qmark_inactive
);
3029 staticpro (&Qlistp
);
3030 staticpro (&Qconsp
);
3031 staticpro (&Qsymbolp
);
3032 staticpro (&Qkeywordp
);
3033 staticpro (&Qintegerp
);
3034 staticpro (&Qnatnump
);
3035 staticpro (&Qwholenump
);
3036 staticpro (&Qstringp
);
3037 staticpro (&Qarrayp
);
3038 staticpro (&Qsequencep
);
3039 staticpro (&Qbufferp
);
3040 staticpro (&Qvectorp
);
3041 staticpro (&Qchar_or_string_p
);
3042 staticpro (&Qmarkerp
);
3043 staticpro (&Qbuffer_or_string_p
);
3044 staticpro (&Qinteger_or_marker_p
);
3045 staticpro (&Qfloatp
);
3046 staticpro (&Qnumberp
);
3047 staticpro (&Qnumber_or_marker_p
);
3048 staticpro (&Qchar_table_p
);
3049 staticpro (&Qvector_or_char_table_p
);
3050 staticpro (&Qsubrp
);
3052 staticpro (&Qunevalled
);
3054 staticpro (&Qboundp
);
3055 staticpro (&Qfboundp
);
3057 staticpro (&Qad_advice_info
);
3058 staticpro (&Qad_activate_internal
);
3060 /* Types that type-of returns. */
3061 Qinteger
= intern ("integer");
3062 Qsymbol
= intern ("symbol");
3063 Qstring
= intern ("string");
3064 Qcons
= intern ("cons");
3065 Qmarker
= intern ("marker");
3066 Qoverlay
= intern ("overlay");
3067 Qfloat
= intern ("float");
3068 Qwindow_configuration
= intern ("window-configuration");
3069 Qprocess
= intern ("process");
3070 Qwindow
= intern ("window");
3071 /* Qsubr = intern ("subr"); */
3072 Qcompiled_function
= intern ("compiled-function");
3073 Qbuffer
= intern ("buffer");
3074 Qframe
= intern ("frame");
3075 Qvector
= intern ("vector");
3076 Qchar_table
= intern ("char-table");
3077 Qbool_vector
= intern ("bool-vector");
3078 Qhash_table
= intern ("hash-table");
3080 staticpro (&Qinteger
);
3081 staticpro (&Qsymbol
);
3082 staticpro (&Qstring
);
3084 staticpro (&Qmarker
);
3085 staticpro (&Qoverlay
);
3086 staticpro (&Qfloat
);
3087 staticpro (&Qwindow_configuration
);
3088 staticpro (&Qprocess
);
3089 staticpro (&Qwindow
);
3090 /* staticpro (&Qsubr); */
3091 staticpro (&Qcompiled_function
);
3092 staticpro (&Qbuffer
);
3093 staticpro (&Qframe
);
3094 staticpro (&Qvector
);
3095 staticpro (&Qchar_table
);
3096 staticpro (&Qbool_vector
);
3097 staticpro (&Qhash_table
);
3099 defsubr (&Sindirect_variable
);
3100 defsubr (&Sinteractive_form
);
3103 defsubr (&Stype_of
);
3108 defsubr (&Sintegerp
);
3109 defsubr (&Sinteger_or_marker_p
);
3110 defsubr (&Snumberp
);
3111 defsubr (&Snumber_or_marker_p
);
3113 defsubr (&Snatnump
);
3114 defsubr (&Ssymbolp
);
3115 defsubr (&Skeywordp
);
3116 defsubr (&Sstringp
);
3117 defsubr (&Smultibyte_string_p
);
3118 defsubr (&Svectorp
);
3119 defsubr (&Schar_table_p
);
3120 defsubr (&Svector_or_char_table_p
);
3121 defsubr (&Sbool_vector_p
);
3123 defsubr (&Ssequencep
);
3124 defsubr (&Sbufferp
);
3125 defsubr (&Smarkerp
);
3127 defsubr (&Sbyte_code_function_p
);
3128 defsubr (&Schar_or_string_p
);
3131 defsubr (&Scar_safe
);
3132 defsubr (&Scdr_safe
);
3135 defsubr (&Ssymbol_function
);
3136 defsubr (&Sindirect_function
);
3137 defsubr (&Ssymbol_plist
);
3138 defsubr (&Ssymbol_name
);
3139 defsubr (&Smakunbound
);
3140 defsubr (&Sfmakunbound
);
3142 defsubr (&Sfboundp
);
3144 defsubr (&Sdefalias
);
3145 defsubr (&Ssetplist
);
3146 defsubr (&Ssymbol_value
);
3148 defsubr (&Sdefault_boundp
);
3149 defsubr (&Sdefault_value
);
3150 defsubr (&Sset_default
);
3151 defsubr (&Ssetq_default
);
3152 defsubr (&Smake_variable_buffer_local
);
3153 defsubr (&Smake_local_variable
);
3154 defsubr (&Skill_local_variable
);
3155 defsubr (&Smake_variable_frame_local
);
3156 defsubr (&Slocal_variable_p
);
3157 defsubr (&Slocal_variable_if_set_p
);
3158 defsubr (&Svariable_binding_locus
);
3161 defsubr (&Snumber_to_string
);
3162 defsubr (&Sstring_to_number
);
3163 defsubr (&Seqlsign
);
3186 defsubr (&Sbyteorder
);
3187 defsubr (&Ssubr_arity
);
3188 defsubr (&Ssubr_name
);
3190 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3192 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3193 doc
: /* The largest value that is representable in a Lisp integer. */);
3194 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3196 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3197 doc
: /* The smallest value that is representable in a Lisp integer. */);
3198 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3205 #if defined(USG) && !defined(POSIX_SIGNALS)
3206 /* USG systems forget handlers when they are used;
3207 must reestablish each time */
3208 signal (signo
, arith_error
);
3211 /* VMS systems are like USG. */
3212 signal (signo
, arith_error
);
3216 #else /* not BSD4_1 */
3217 sigsetmask (SIGEMPTYMASK
);
3218 #endif /* not BSD4_1 */
3220 SIGNAL_THREAD_CHECK (signo
);
3221 xsignal0 (Qarith_error
);
3227 /* Don't do this if just dumping out.
3228 We don't want to call `signal' in this case
3229 so that we don't have trouble with dumping
3230 signal-delivering routines in an inconsistent state. */
3234 #endif /* CANNOT_DUMP */
3235 signal (SIGFPE
, arith_error
);
3238 signal (SIGEMT
, arith_error
);
3242 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3243 (do not change this comment) */