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. */
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 (INTEGERP (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
); /* Check cycles. */
755 if (NILP (fun
) || EQ (fun
, Qunbound
))
758 /* Use an `interactive-form' property if present, analogous to the
759 function-documentation property. */
761 while (SYMBOLP (fun
))
763 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
767 fun
= Fsymbol_function (fun
);
772 if (XSUBR (fun
)->prompt
)
773 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
775 else if (COMPILEDP (fun
))
777 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
778 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
780 else if (CONSP (fun
))
782 Lisp_Object funcar
= XCAR (fun
);
783 if (EQ (funcar
, Qlambda
))
784 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
785 else if (EQ (funcar
, Qautoload
))
789 do_autoload (fun
, cmd
);
791 return Finteractive_form (cmd
);
798 /***********************************************************************
799 Getting and Setting Values of Symbols
800 ***********************************************************************/
802 /* Return the symbol holding SYMBOL's value. Signal
803 `cyclic-variable-indirection' if SYMBOL's chain of variable
804 indirections contains a loop. */
807 indirect_variable (symbol
)
810 Lisp_Object tortoise
, hare
;
812 hare
= tortoise
= symbol
;
814 while (XSYMBOL (hare
)->indirect_variable
)
816 hare
= XSYMBOL (hare
)->value
;
817 if (!XSYMBOL (hare
)->indirect_variable
)
820 hare
= XSYMBOL (hare
)->value
;
821 tortoise
= XSYMBOL (tortoise
)->value
;
823 if (EQ (hare
, tortoise
))
824 xsignal1 (Qcyclic_variable_indirection
, symbol
);
831 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
832 doc
: /* Return the variable at the end of OBJECT's variable chain.
833 If OBJECT is a symbol, follow all variable indirections and return the final
834 variable. If OBJECT is not a symbol, just return it.
835 Signal a cyclic-variable-indirection error if there is a loop in the
836 variable chain of symbols. */)
840 if (SYMBOLP (object
))
841 object
= indirect_variable (object
);
846 /* Given the raw contents of a symbol value cell,
847 return the Lisp value of the symbol.
848 This does not handle buffer-local variables; use
849 swap_in_symval_forwarding for that. */
852 do_symval_forwarding (valcontents
)
853 register Lisp_Object valcontents
;
855 register Lisp_Object val
;
857 if (MISCP (valcontents
))
858 switch (XMISCTYPE (valcontents
))
860 case Lisp_Misc_Intfwd
:
861 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
864 case Lisp_Misc_Boolfwd
:
865 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
867 case Lisp_Misc_Objfwd
:
868 return *XOBJFWD (valcontents
)->objvar
;
870 case Lisp_Misc_Buffer_Objfwd
:
871 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
872 return PER_BUFFER_VALUE (current_buffer
, offset
);
874 case Lisp_Misc_Kboard_Objfwd
:
875 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
876 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
881 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
882 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
883 buffer-independent contents of the value cell: forwarded just one
884 step past the buffer-localness.
886 BUF non-zero means set the value in buffer BUF instead of the
887 current buffer. This only plays a role for per-buffer variables. */
890 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
892 register Lisp_Object valcontents
, newval
;
895 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
898 switch (XMISCTYPE (valcontents
))
900 case Lisp_Misc_Intfwd
:
901 CHECK_NUMBER (newval
);
902 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
903 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
904 error ("Value out of range for variable `%s'",
905 SDATA (SYMBOL_NAME (symbol
)));
908 case Lisp_Misc_Boolfwd
:
909 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
912 case Lisp_Misc_Objfwd
:
913 *XOBJFWD (valcontents
)->objvar
= newval
;
915 /* If this variable is a default for something stored
916 in the buffer itself, such as default-fill-column,
917 find the buffers that don't have local values for it
919 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
920 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
922 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
923 - (char *) &buffer_defaults
);
924 int idx
= PER_BUFFER_IDX (offset
);
931 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
936 buf
= Fcdr (XCAR (tail
));
937 if (!BUFFERP (buf
)) continue;
940 if (! PER_BUFFER_VALUE_P (b
, idx
))
941 PER_BUFFER_VALUE (b
, offset
) = newval
;
946 case Lisp_Misc_Buffer_Objfwd
:
948 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
951 type
= PER_BUFFER_TYPE (offset
);
952 if (! NILP (type
) && ! NILP (newval
)
953 && XTYPE (newval
) != XINT (type
))
954 buffer_slot_type_mismatch (offset
);
957 buf
= current_buffer
;
958 PER_BUFFER_VALUE (buf
, offset
) = newval
;
962 case Lisp_Misc_Kboard_Objfwd
:
964 char *base
= (char *) current_kboard
;
965 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
966 *(Lisp_Object
*) p
= newval
;
977 valcontents
= SYMBOL_VALUE (symbol
);
978 if (BUFFER_LOCAL_VALUEP (valcontents
)
979 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
980 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
982 SET_SYMBOL_VALUE (symbol
, newval
);
986 /* Set up SYMBOL to refer to its global binding.
987 This makes it safe to alter the status of other bindings. */
990 swap_in_global_binding (symbol
)
993 Lisp_Object valcontents
, cdr
;
995 valcontents
= SYMBOL_VALUE (symbol
);
996 if (!BUFFER_LOCAL_VALUEP (valcontents
)
997 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
999 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1001 /* Unload the previously loaded binding. */
1002 Fsetcdr (XCAR (cdr
),
1003 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1005 /* Select the global binding in the symbol. */
1007 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1009 /* Indicate that the global binding is set up now. */
1010 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1011 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1012 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1013 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1016 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1017 VALCONTENTS is the contents of its value cell,
1018 which points to a struct Lisp_Buffer_Local_Value.
1020 Return the value forwarded one step past the buffer-local stage.
1021 This could be another forwarding pointer. */
1024 swap_in_symval_forwarding (symbol
, valcontents
)
1025 Lisp_Object symbol
, valcontents
;
1027 register Lisp_Object tem1
;
1029 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1032 || current_buffer
!= XBUFFER (tem1
)
1033 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1034 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1036 if (XSYMBOL (symbol
)->indirect_variable
)
1037 symbol
= indirect_variable (symbol
);
1039 /* Unload the previously loaded binding. */
1040 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1042 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1043 /* Choose the new binding. */
1044 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1045 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1046 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1049 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1050 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1052 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1054 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1057 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1059 /* Load the new binding. */
1060 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1061 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1062 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1063 store_symval_forwarding (symbol
,
1064 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1067 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1070 /* Find the value of a symbol, returning Qunbound if it's not bound.
1071 This is helpful for code which just wants to get a variable's value
1072 if it has one, without signaling an error.
1073 Note that it must not be possible to quit
1074 within this function. Great care is required for this. */
1077 find_symbol_value (symbol
)
1080 register Lisp_Object valcontents
;
1081 register Lisp_Object val
;
1083 CHECK_SYMBOL (symbol
);
1084 valcontents
= SYMBOL_VALUE (symbol
);
1086 if (BUFFER_LOCAL_VALUEP (valcontents
)
1087 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1088 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1090 if (MISCP (valcontents
))
1092 switch (XMISCTYPE (valcontents
))
1094 case Lisp_Misc_Intfwd
:
1095 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1098 case Lisp_Misc_Boolfwd
:
1099 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1101 case Lisp_Misc_Objfwd
:
1102 return *XOBJFWD (valcontents
)->objvar
;
1104 case Lisp_Misc_Buffer_Objfwd
:
1105 return PER_BUFFER_VALUE (current_buffer
,
1106 XBUFFER_OBJFWD (valcontents
)->offset
);
1108 case Lisp_Misc_Kboard_Objfwd
:
1109 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1110 + (char *)current_kboard
);
1117 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1118 doc
: /* Return SYMBOL's value. Error if that is void. */)
1124 val
= find_symbol_value (symbol
);
1125 if (!EQ (val
, Qunbound
))
1128 xsignal1 (Qvoid_variable
, symbol
);
1131 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1132 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1134 register Lisp_Object symbol
, newval
;
1136 return set_internal (symbol
, newval
, current_buffer
, 0);
1139 /* Return 1 if SYMBOL currently has a let-binding
1140 which was made in the buffer that is now current. */
1143 let_shadows_buffer_binding_p (symbol
)
1146 volatile struct specbinding
*p
;
1148 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1150 && CONSP (p
->symbol
))
1152 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1153 if ((EQ (symbol
, let_bound_symbol
)
1154 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1155 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1156 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1160 return p
>= specpdl
;
1163 /* Store the value NEWVAL into SYMBOL.
1164 If buffer-locality is an issue, BUF specifies which buffer to use.
1165 (0 stands for the current buffer.)
1167 If BINDFLAG is zero, then if this symbol is supposed to become
1168 local in every buffer where it is set, then we make it local.
1169 If BINDFLAG is nonzero, we don't do that. */
1172 set_internal (symbol
, newval
, buf
, bindflag
)
1173 register Lisp_Object symbol
, newval
;
1177 int voide
= EQ (newval
, Qunbound
);
1179 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1182 buf
= current_buffer
;
1184 /* If restoring in a dead buffer, do nothing. */
1185 if (NILP (buf
->name
))
1188 CHECK_SYMBOL (symbol
);
1189 if (SYMBOL_CONSTANT_P (symbol
)
1190 && (NILP (Fkeywordp (symbol
))
1191 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1192 xsignal1 (Qsetting_constant
, symbol
);
1194 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1196 if (BUFFER_OBJFWDP (valcontents
))
1198 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1199 int idx
= PER_BUFFER_IDX (offset
);
1202 && !let_shadows_buffer_binding_p (symbol
))
1203 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1205 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1206 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1208 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1209 if (XSYMBOL (symbol
)->indirect_variable
)
1210 symbol
= indirect_variable (symbol
);
1212 /* What binding is loaded right now? */
1213 current_alist_element
1214 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1216 /* If the current buffer is not the buffer whose binding is
1217 loaded, or if there may be frame-local bindings and the frame
1218 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1219 the default binding is loaded, the loaded binding may be the
1221 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1222 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1223 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1224 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1225 || (BUFFER_LOCAL_VALUEP (valcontents
)
1226 && EQ (XCAR (current_alist_element
),
1227 current_alist_element
)))
1229 /* The currently loaded binding is not necessarily valid.
1230 We need to unload it, and choose a new binding. */
1232 /* Write out `realvalue' to the old loaded binding. */
1233 Fsetcdr (current_alist_element
,
1234 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1236 /* Find the new binding. */
1237 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1238 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1239 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1243 /* This buffer still sees the default value. */
1245 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1246 or if this is `let' rather than `set',
1247 make CURRENT-ALIST-ELEMENT point to itself,
1248 indicating that we're seeing the default value.
1249 Likewise if the variable has been let-bound
1250 in the current buffer. */
1251 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1252 || let_shadows_buffer_binding_p (symbol
))
1254 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1256 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1257 tem1
= Fassq (symbol
,
1258 XFRAME (selected_frame
)->param_alist
);
1261 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1263 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1265 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1266 and we're not within a let that was made for this buffer,
1267 create a new buffer-local binding for the variable.
1268 That means, give this buffer a new assoc for a local value
1269 and load that binding. */
1272 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1273 buf
->local_var_alist
1274 = Fcons (tem1
, buf
->local_var_alist
);
1278 /* Record which binding is now loaded. */
1279 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1282 /* Set `buffer' and `frame' slots for the binding now loaded. */
1283 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1284 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1286 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1289 /* If storing void (making the symbol void), forward only through
1290 buffer-local indicator, not through Lisp_Objfwd, etc. */
1292 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1294 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1296 /* If we just set a variable whose current binding is frame-local,
1297 store the new value in the frame parameter too. */
1299 if (BUFFER_LOCAL_VALUEP (valcontents
)
1300 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1302 /* What binding is loaded right now? */
1303 current_alist_element
1304 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1306 /* If the current buffer is not the buffer whose binding is
1307 loaded, or if there may be frame-local bindings and the frame
1308 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1309 the default binding is loaded, the loaded binding may be the
1311 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1312 XSETCDR (current_alist_element
, newval
);
1318 /* Access or set a buffer-local symbol's default value. */
1320 /* Return the default value of SYMBOL, but don't check for voidness.
1321 Return Qunbound if it is void. */
1324 default_value (symbol
)
1327 register Lisp_Object valcontents
;
1329 CHECK_SYMBOL (symbol
);
1330 valcontents
= SYMBOL_VALUE (symbol
);
1332 /* For a built-in buffer-local variable, get the default value
1333 rather than letting do_symval_forwarding get the current value. */
1334 if (BUFFER_OBJFWDP (valcontents
))
1336 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1337 if (PER_BUFFER_IDX (offset
) != 0)
1338 return PER_BUFFER_DEFAULT (offset
);
1341 /* Handle user-created local variables. */
1342 if (BUFFER_LOCAL_VALUEP (valcontents
)
1343 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1345 /* If var is set up for a buffer that lacks a local value for it,
1346 the current value is nominally the default value.
1347 But the `realvalue' slot may be more up to date, since
1348 ordinary setq stores just that slot. So use that. */
1349 Lisp_Object current_alist_element
, alist_element_car
;
1350 current_alist_element
1351 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1352 alist_element_car
= XCAR (current_alist_element
);
1353 if (EQ (alist_element_car
, current_alist_element
))
1354 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1356 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1358 /* For other variables, get the current value. */
1359 return do_symval_forwarding (valcontents
);
1362 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1363 doc
: /* Return t if SYMBOL has a non-void default value.
1364 This is the value that is seen in buffers that do not have their own values
1365 for this variable. */)
1369 register Lisp_Object value
;
1371 value
= default_value (symbol
);
1372 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1375 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1376 doc
: /* Return SYMBOL's default value.
1377 This is the value that is seen in buffers that do not have their own values
1378 for this variable. The default value is meaningful for variables with
1379 local bindings in certain buffers. */)
1383 register Lisp_Object value
;
1385 value
= default_value (symbol
);
1386 if (!EQ (value
, Qunbound
))
1389 xsignal1 (Qvoid_variable
, symbol
);
1392 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1393 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1394 The default value is seen in buffers that do not have their own values
1395 for this variable. */)
1397 Lisp_Object symbol
, value
;
1399 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1401 CHECK_SYMBOL (symbol
);
1402 valcontents
= SYMBOL_VALUE (symbol
);
1404 /* Handle variables like case-fold-search that have special slots
1405 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1407 if (BUFFER_OBJFWDP (valcontents
))
1409 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1410 int idx
= PER_BUFFER_IDX (offset
);
1412 PER_BUFFER_DEFAULT (offset
) = value
;
1414 /* If this variable is not always local in all buffers,
1415 set it in the buffers that don't nominally have a local value. */
1420 for (b
= all_buffers
; b
; b
= b
->next
)
1421 if (!PER_BUFFER_VALUE_P (b
, idx
))
1422 PER_BUFFER_VALUE (b
, offset
) = value
;
1427 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1428 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1429 return Fset (symbol
, value
);
1431 /* Store new value into the DEFAULT-VALUE slot. */
1432 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1434 /* If the default binding is now loaded, set the REALVALUE slot too. */
1435 current_alist_element
1436 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1437 alist_element_buffer
= Fcar (current_alist_element
);
1438 if (EQ (alist_element_buffer
, current_alist_element
))
1439 store_symval_forwarding (symbol
,
1440 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1446 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1447 doc
: /* Set the default value of variable VAR to VALUE.
1448 VAR, the variable name, is literal (not evaluated);
1449 VALUE is an expression: it is evaluated and its value returned.
1450 The default value of a variable is seen in buffers
1451 that do not have their own values for the variable.
1453 More generally, you can use multiple variables and values, as in
1454 (setq-default VAR VALUE VAR VALUE...)
1455 This sets each VAR's default value to the corresponding VALUE.
1456 The VALUE for the Nth VAR can refer to the new default values
1458 usage: (setq-default [VAR VALUE]...) */)
1462 register Lisp_Object args_left
;
1463 register Lisp_Object val
, symbol
;
1464 struct gcpro gcpro1
;
1474 val
= Feval (Fcar (Fcdr (args_left
)));
1475 symbol
= XCAR (args_left
);
1476 Fset_default (symbol
, val
);
1477 args_left
= Fcdr (XCDR (args_left
));
1479 while (!NILP (args_left
));
1485 /* Lisp functions for creating and removing buffer-local variables. */
1487 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1488 1, 1, "vMake Variable Buffer Local: ",
1489 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1490 At any time, the value for the current buffer is in effect,
1491 unless the variable has never been set in this buffer,
1492 in which case the default value is in effect.
1493 Note that binding the variable with `let', or setting it while
1494 a `let'-style binding made in this buffer is in effect,
1495 does not make the variable buffer-local. Return VARIABLE.
1497 In most cases it is better to use `make-local-variable',
1498 which makes a variable local in just one buffer.
1500 The function `default-value' gets the default value and `set-default' sets it. */)
1502 register Lisp_Object variable
;
1504 register Lisp_Object tem
, valcontents
, newval
;
1506 CHECK_SYMBOL (variable
);
1507 variable
= indirect_variable (variable
);
1509 valcontents
= SYMBOL_VALUE (variable
);
1510 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1511 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1513 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1515 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1517 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1520 if (EQ (valcontents
, Qunbound
))
1521 SET_SYMBOL_VALUE (variable
, Qnil
);
1522 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1524 newval
= allocate_misc ();
1525 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1526 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1527 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1528 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1529 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1530 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1531 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1532 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1533 SET_SYMBOL_VALUE (variable
, newval
);
1537 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1538 1, 1, "vMake Local Variable: ",
1539 doc
: /* Make VARIABLE have a separate value in the current buffer.
1540 Other buffers will continue to share a common default value.
1541 \(The buffer-local value of VARIABLE starts out as the same value
1542 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1545 If the variable is already arranged to become local when set,
1546 this function causes a local value to exist for this buffer,
1547 just as setting the variable would do.
1549 This function returns VARIABLE, and therefore
1550 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1553 See also `make-variable-buffer-local'.
1555 Do not use `make-local-variable' to make a hook variable buffer-local.
1556 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1558 register Lisp_Object variable
;
1560 register Lisp_Object tem
, valcontents
;
1562 CHECK_SYMBOL (variable
);
1563 variable
= indirect_variable (variable
);
1565 valcontents
= SYMBOL_VALUE (variable
);
1566 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1567 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1569 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1571 tem
= Fboundp (variable
);
1573 /* Make sure the symbol has a local value in this particular buffer,
1574 by setting it to the same value it already has. */
1575 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1578 /* Make sure symbol is set up to hold per-buffer values. */
1579 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1582 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1584 newval
= allocate_misc ();
1585 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1586 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1587 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1588 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1589 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1590 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1591 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1592 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1593 SET_SYMBOL_VALUE (variable
, newval
);
1595 /* Make sure this buffer has its own value of symbol. */
1596 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1599 /* Swap out any local binding for some other buffer, and make
1600 sure the current value is permanently recorded, if it's the
1602 find_symbol_value (variable
);
1604 current_buffer
->local_var_alist
1605 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1606 current_buffer
->local_var_alist
);
1608 /* Make sure symbol does not think it is set up for this buffer;
1609 force it to look once again for this buffer's value. */
1611 Lisp_Object
*pvalbuf
;
1613 valcontents
= SYMBOL_VALUE (variable
);
1615 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1616 if (current_buffer
== XBUFFER (*pvalbuf
))
1618 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1622 /* If the symbol forwards into a C variable, then load the binding
1623 for this buffer now. If C code modifies the variable before we
1624 load the binding in, then that new value will clobber the default
1625 binding the next time we unload it. */
1626 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1627 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1628 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1633 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1634 1, 1, "vKill Local Variable: ",
1635 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1636 From now on the default value will apply in this buffer. Return VARIABLE. */)
1638 register Lisp_Object variable
;
1640 register Lisp_Object tem
, valcontents
;
1642 CHECK_SYMBOL (variable
);
1643 variable
= indirect_variable (variable
);
1645 valcontents
= SYMBOL_VALUE (variable
);
1647 if (BUFFER_OBJFWDP (valcontents
))
1649 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1650 int idx
= PER_BUFFER_IDX (offset
);
1654 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1655 PER_BUFFER_VALUE (current_buffer
, offset
)
1656 = PER_BUFFER_DEFAULT (offset
);
1661 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1662 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1665 /* Get rid of this buffer's alist element, if any. */
1667 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1669 current_buffer
->local_var_alist
1670 = Fdelq (tem
, current_buffer
->local_var_alist
);
1672 /* If the symbol is set up with the current buffer's binding
1673 loaded, recompute its value. We have to do it now, or else
1674 forwarded objects won't work right. */
1676 Lisp_Object
*pvalbuf
, buf
;
1677 valcontents
= SYMBOL_VALUE (variable
);
1678 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1679 XSETBUFFER (buf
, current_buffer
);
1680 if (EQ (buf
, *pvalbuf
))
1683 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1684 find_symbol_value (variable
);
1691 /* Lisp functions for creating and removing buffer-local variables. */
1693 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1694 1, 1, "vMake Variable Frame Local: ",
1695 doc
: /* Enable VARIABLE to have frame-local bindings.
1696 This does not create any frame-local bindings for VARIABLE,
1697 it just makes them possible.
1699 A frame-local binding is actually a frame parameter value.
1700 If a frame F has a value for the frame parameter named VARIABLE,
1701 that also acts as a frame-local binding for VARIABLE in F--
1702 provided this function has been called to enable VARIABLE
1703 to have frame-local bindings at all.
1705 The only way to create a frame-local binding for VARIABLE in a frame
1706 is to set the VARIABLE frame parameter of that frame. See
1707 `modify-frame-parameters' for how to set frame parameters.
1709 Buffer-local bindings take precedence over frame-local bindings. */)
1711 register Lisp_Object variable
;
1713 register Lisp_Object tem
, valcontents
, newval
;
1715 CHECK_SYMBOL (variable
);
1716 variable
= indirect_variable (variable
);
1718 valcontents
= SYMBOL_VALUE (variable
);
1719 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1720 || BUFFER_OBJFWDP (valcontents
))
1721 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1723 if (BUFFER_LOCAL_VALUEP (valcontents
)
1724 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1726 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1730 if (EQ (valcontents
, Qunbound
))
1731 SET_SYMBOL_VALUE (variable
, Qnil
);
1732 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1734 newval
= allocate_misc ();
1735 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1736 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1737 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1738 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1739 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1740 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1741 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1742 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1743 SET_SYMBOL_VALUE (variable
, newval
);
1747 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1749 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1750 BUFFER defaults to the current buffer. */)
1752 register Lisp_Object variable
, buffer
;
1754 Lisp_Object valcontents
;
1755 register struct buffer
*buf
;
1758 buf
= current_buffer
;
1761 CHECK_BUFFER (buffer
);
1762 buf
= XBUFFER (buffer
);
1765 CHECK_SYMBOL (variable
);
1766 variable
= indirect_variable (variable
);
1768 valcontents
= SYMBOL_VALUE (variable
);
1769 if (BUFFER_LOCAL_VALUEP (valcontents
)
1770 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1772 Lisp_Object tail
, elt
;
1774 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1777 if (EQ (variable
, XCAR (elt
)))
1781 if (BUFFER_OBJFWDP (valcontents
))
1783 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1784 int idx
= PER_BUFFER_IDX (offset
);
1785 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1791 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1793 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1794 More precisely, this means that setting the variable \(with `set' or`setq'),
1795 while it does not have a `let'-style binding that was made in BUFFER,
1796 will produce a buffer local binding. See Info node
1797 `(elisp)Creating Buffer-Local'.
1798 BUFFER defaults to the current buffer. */)
1800 register Lisp_Object variable
, buffer
;
1802 Lisp_Object valcontents
;
1803 register struct buffer
*buf
;
1806 buf
= current_buffer
;
1809 CHECK_BUFFER (buffer
);
1810 buf
= XBUFFER (buffer
);
1813 CHECK_SYMBOL (variable
);
1814 variable
= indirect_variable (variable
);
1816 valcontents
= SYMBOL_VALUE (variable
);
1818 /* This means that make-variable-buffer-local was done. */
1819 if (BUFFER_LOCAL_VALUEP (valcontents
))
1821 /* All these slots become local if they are set. */
1822 if (BUFFER_OBJFWDP (valcontents
))
1824 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1826 Lisp_Object tail
, elt
;
1827 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1830 if (EQ (variable
, XCAR (elt
)))
1837 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1839 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1840 If the current binding is buffer-local, the value is the current buffer.
1841 If the current binding is frame-local, the value is the selected frame.
1842 If the current binding is global (the default), the value is nil. */)
1844 register Lisp_Object variable
;
1846 Lisp_Object valcontents
;
1848 CHECK_SYMBOL (variable
);
1849 variable
= indirect_variable (variable
);
1851 /* Make sure the current binding is actually swapped in. */
1852 find_symbol_value (variable
);
1854 valcontents
= XSYMBOL (variable
)->value
;
1856 if (BUFFER_LOCAL_VALUEP (valcontents
)
1857 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1858 || BUFFER_OBJFWDP (valcontents
))
1860 /* For a local variable, record both the symbol and which
1861 buffer's or frame's value we are saving. */
1862 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1863 return Fcurrent_buffer ();
1864 else if (!BUFFER_OBJFWDP (valcontents
)
1865 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1866 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1872 /* Find the function at the end of a chain of symbol function indirections. */
1874 /* If OBJECT is a symbol, find the end of its function chain and
1875 return the value found there. If OBJECT is not a symbol, just
1876 return it. If there is a cycle in the function chain, signal a
1877 cyclic-function-indirection error.
1879 This is like Findirect_function, except that it doesn't signal an
1880 error if the chain ends up unbound. */
1882 indirect_function (object
)
1883 register Lisp_Object object
;
1885 Lisp_Object tortoise
, hare
;
1887 hare
= tortoise
= object
;
1891 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1893 hare
= XSYMBOL (hare
)->function
;
1894 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1896 hare
= XSYMBOL (hare
)->function
;
1898 tortoise
= XSYMBOL (tortoise
)->function
;
1900 if (EQ (hare
, tortoise
))
1901 xsignal1 (Qcyclic_function_indirection
, object
);
1907 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1908 doc
: /* Return the function at the end of OBJECT's function chain.
1909 If OBJECT is not a symbol, just return it. Otherwise, follow all
1910 function indirections to find the final function binding and return it.
1911 If the final symbol in the chain is unbound, signal a void-function error.
1912 Optional arg NOERROR non-nil means to return nil instead of signalling.
1913 Signal a cyclic-function-indirection error if there is a loop in the
1914 function chain of symbols. */)
1916 register Lisp_Object object
;
1917 Lisp_Object noerror
;
1921 /* Optimize for no indirection. */
1923 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1924 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1925 result
= indirect_function (result
);
1926 if (!EQ (result
, Qunbound
))
1930 xsignal1 (Qvoid_function
, object
);
1935 /* Extract and set vector and string elements */
1937 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1938 doc
: /* Return the element of ARRAY at index IDX.
1939 ARRAY may be a vector, a string, a char-table, a bool-vector,
1940 or a byte-code object. IDX starts at 0. */)
1942 register Lisp_Object array
;
1945 register int idxval
;
1948 idxval
= XINT (idx
);
1949 if (STRINGP (array
))
1953 if (idxval
< 0 || idxval
>= SCHARS (array
))
1954 args_out_of_range (array
, idx
);
1955 if (! STRING_MULTIBYTE (array
))
1956 return make_number ((unsigned char) SREF (array
, idxval
));
1957 idxval_byte
= string_char_to_byte (array
, idxval
);
1959 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1960 SBYTES (array
) - idxval_byte
);
1961 return make_number (c
);
1963 else if (BOOL_VECTOR_P (array
))
1967 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1968 args_out_of_range (array
, idx
);
1970 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1971 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1973 else if (CHAR_TABLE_P (array
))
1980 args_out_of_range (array
, idx
);
1981 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1983 if (! SINGLE_BYTE_CHAR_P (idxval
))
1984 args_out_of_range (array
, idx
);
1985 /* For ASCII and 8-bit European characters, the element is
1986 stored in the top table. */
1987 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1991 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
1992 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
1993 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
1994 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
1997 val
= XCHAR_TABLE (array
)->defalt
;
1998 while (NILP (val
)) /* Follow parents until we find some value. */
2000 array
= XCHAR_TABLE (array
)->parent
;
2003 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2005 val
= XCHAR_TABLE (array
)->defalt
;
2012 Lisp_Object sub_table
;
2013 Lisp_Object current_default
;
2015 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2016 if (code
[1] < 32) code
[1] = -1;
2017 else if (code
[2] < 32) code
[2] = -1;
2019 /* Here, the possible range of CODE[0] (== charset ID) is
2020 128..MAX_CHARSET. Since the top level char table contains
2021 data for multibyte characters after 256th element, we must
2022 increment CODE[0] by 128 to get a correct index. */
2024 code
[3] = -1; /* anchor */
2026 try_parent_char_table
:
2027 current_default
= XCHAR_TABLE (array
)->defalt
;
2029 for (i
= 0; code
[i
] >= 0; i
++)
2031 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2032 if (SUB_CHAR_TABLE_P (val
))
2035 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2036 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2041 val
= current_default
;
2044 array
= XCHAR_TABLE (array
)->parent
;
2046 goto try_parent_char_table
;
2051 /* Reaching here means IDXVAL is a generic character in
2052 which each character or a group has independent value.
2053 Essentially it's nonsense to get a value for such a
2054 generic character, but for backward compatibility, we try
2055 the default value and parent. */
2056 val
= current_default
;
2059 array
= XCHAR_TABLE (array
)->parent
;
2061 goto try_parent_char_table
;
2069 if (VECTORP (array
))
2070 size
= XVECTOR (array
)->size
;
2071 else if (COMPILEDP (array
))
2072 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2074 wrong_type_argument (Qarrayp
, array
);
2076 if (idxval
< 0 || idxval
>= size
)
2077 args_out_of_range (array
, idx
);
2078 return XVECTOR (array
)->contents
[idxval
];
2082 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2083 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2084 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2085 bool-vector. IDX starts at 0. */)
2086 (array
, idx
, newelt
)
2087 register Lisp_Object array
;
2088 Lisp_Object idx
, newelt
;
2090 register int idxval
;
2093 idxval
= XINT (idx
);
2094 CHECK_ARRAY (array
, Qarrayp
);
2095 CHECK_IMPURE (array
);
2097 if (VECTORP (array
))
2099 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2100 args_out_of_range (array
, idx
);
2101 XVECTOR (array
)->contents
[idxval
] = newelt
;
2103 else if (BOOL_VECTOR_P (array
))
2107 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2108 args_out_of_range (array
, idx
);
2110 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2112 if (! NILP (newelt
))
2113 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2115 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2116 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2118 else if (CHAR_TABLE_P (array
))
2121 args_out_of_range (array
, idx
);
2122 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2124 if (! SINGLE_BYTE_CHAR_P (idxval
))
2125 args_out_of_range (array
, idx
);
2126 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2133 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2134 if (code
[1] < 32) code
[1] = -1;
2135 else if (code
[2] < 32) code
[2] = -1;
2137 /* See the comment of the corresponding part in Faref. */
2139 code
[3] = -1; /* anchor */
2140 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2142 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2143 if (SUB_CHAR_TABLE_P (val
))
2149 /* VAL is a leaf. Create a sub char table with the
2150 initial value VAL and look into it. */
2152 temp
= make_sub_char_table (val
);
2153 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2157 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2160 else if (STRING_MULTIBYTE (array
))
2162 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2163 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2165 if (idxval
< 0 || idxval
>= SCHARS (array
))
2166 args_out_of_range (array
, idx
);
2167 CHECK_NUMBER (newelt
);
2169 nbytes
= SBYTES (array
);
2171 idxval_byte
= string_char_to_byte (array
, idxval
);
2172 p1
= SDATA (array
) + idxval_byte
;
2173 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2174 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2175 if (prev_bytes
!= new_bytes
)
2177 /* We must relocate the string data. */
2178 int nchars
= SCHARS (array
);
2182 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2183 bcopy (SDATA (array
), str
, nbytes
);
2184 allocate_string_data (XSTRING (array
), nchars
,
2185 nbytes
+ new_bytes
- prev_bytes
);
2186 bcopy (str
, SDATA (array
), idxval_byte
);
2187 p1
= SDATA (array
) + idxval_byte
;
2188 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2189 nbytes
- (idxval_byte
+ prev_bytes
));
2191 clear_string_char_byte_cache ();
2198 if (idxval
< 0 || idxval
>= SCHARS (array
))
2199 args_out_of_range (array
, idx
);
2200 CHECK_NUMBER (newelt
);
2202 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2203 SSET (array
, idxval
, XINT (newelt
));
2206 /* We must relocate the string data while converting it to
2208 int idxval_byte
, prev_bytes
, new_bytes
;
2209 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2210 unsigned char *origstr
= SDATA (array
), *str
;
2214 nchars
= SCHARS (array
);
2215 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2216 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2218 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2219 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2220 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2222 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2223 allocate_string_data (XSTRING (array
), nchars
,
2224 nbytes
+ new_bytes
- prev_bytes
);
2225 bcopy (str
, SDATA (array
), idxval_byte
);
2226 p1
= SDATA (array
) + idxval_byte
;
2229 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2230 nbytes
- (idxval_byte
+ prev_bytes
));
2232 clear_string_char_byte_cache ();
2239 /* Arithmetic functions */
2241 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2244 arithcompare (num1
, num2
, comparison
)
2245 Lisp_Object num1
, num2
;
2246 enum comparison comparison
;
2248 double f1
= 0, f2
= 0;
2251 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2252 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2254 if (FLOATP (num1
) || FLOATP (num2
))
2257 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2258 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2264 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2269 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2274 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2279 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2284 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2289 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2298 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2299 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2301 register Lisp_Object num1
, num2
;
2303 return arithcompare (num1
, num2
, equal
);
2306 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2307 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2309 register Lisp_Object num1
, num2
;
2311 return arithcompare (num1
, num2
, less
);
2314 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2315 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2317 register Lisp_Object num1
, num2
;
2319 return arithcompare (num1
, num2
, grtr
);
2322 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2323 doc
: /* Return t if first arg is less than or equal to second arg.
2324 Both must be numbers or markers. */)
2326 register Lisp_Object num1
, num2
;
2328 return arithcompare (num1
, num2
, less_or_equal
);
2331 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2332 doc
: /* Return t if first arg is greater than or equal to second arg.
2333 Both must be numbers or markers. */)
2335 register Lisp_Object num1
, num2
;
2337 return arithcompare (num1
, num2
, grtr_or_equal
);
2340 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2341 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2343 register Lisp_Object num1
, num2
;
2345 return arithcompare (num1
, num2
, notequal
);
2348 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2349 doc
: /* Return t if NUMBER is zero. */)
2351 register Lisp_Object number
;
2353 CHECK_NUMBER_OR_FLOAT (number
);
2355 if (FLOATP (number
))
2357 if (XFLOAT_DATA (number
) == 0.0)
2367 /* Convert between long values and pairs of Lisp integers.
2368 Note that long_to_cons returns a single Lisp integer
2369 when the value fits in one. */
2375 unsigned long top
= i
>> 16;
2376 unsigned int bot
= i
& 0xFFFF;
2378 return make_number (bot
);
2379 if (top
== (unsigned long)-1 >> 16)
2380 return Fcons (make_number (-1), make_number (bot
));
2381 return Fcons (make_number (top
), make_number (bot
));
2388 Lisp_Object top
, bot
;
2395 return ((XINT (top
) << 16) | XINT (bot
));
2398 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2399 doc
: /* Return the decimal representation of NUMBER as a string.
2400 Uses a minus sign if negative.
2401 NUMBER may be an integer or a floating point number. */)
2405 char buffer
[VALBITS
];
2407 CHECK_NUMBER_OR_FLOAT (number
);
2409 if (FLOATP (number
))
2411 char pigbuf
[350]; /* see comments in float_to_string */
2413 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2414 return build_string (pigbuf
);
2417 if (sizeof (int) == sizeof (EMACS_INT
))
2418 sprintf (buffer
, "%d", XINT (number
));
2419 else if (sizeof (long) == sizeof (EMACS_INT
))
2420 sprintf (buffer
, "%ld", (long) XINT (number
));
2423 return build_string (buffer
);
2427 digit_to_number (character
, base
)
2428 int character
, base
;
2432 if (character
>= '0' && character
<= '9')
2433 digit
= character
- '0';
2434 else if (character
>= 'a' && character
<= 'z')
2435 digit
= character
- 'a' + 10;
2436 else if (character
>= 'A' && character
<= 'Z')
2437 digit
= character
- 'A' + 10;
2447 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2448 doc
: /* Parse STRING as a decimal number and return the number.
2449 This parses both integers and floating point numbers.
2450 It ignores leading spaces and tabs.
2452 If BASE, interpret STRING as a number in that base. If BASE isn't
2453 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2454 If the base used is not 10, floating point is not recognized. */)
2456 register Lisp_Object string
, base
;
2458 register unsigned char *p
;
2463 CHECK_STRING (string
);
2469 CHECK_NUMBER (base
);
2471 if (b
< 2 || b
> 16)
2472 xsignal1 (Qargs_out_of_range
, base
);
2475 /* Skip any whitespace at the front of the number. Some versions of
2476 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2478 while (*p
== ' ' || *p
== '\t')
2489 if (isfloat_string (p
) && b
== 10)
2490 val
= make_float (sign
* atof (p
));
2497 int digit
= digit_to_number (*p
++, b
);
2503 val
= make_fixnum_or_float (sign
* v
);
2523 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2524 int, Lisp_Object
*));
2525 extern Lisp_Object
fmod_float ();
2528 arith_driver (code
, nargs
, args
)
2531 register Lisp_Object
*args
;
2533 register Lisp_Object val
;
2534 register int argnum
;
2535 register EMACS_INT accum
= 0;
2536 register EMACS_INT next
;
2538 switch (SWITCH_ENUM_CAST (code
))
2556 for (argnum
= 0; argnum
< nargs
; argnum
++)
2558 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2560 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2563 return float_arith_driver ((double) accum
, argnum
, code
,
2566 next
= XINT (args
[argnum
]);
2567 switch (SWITCH_ENUM_CAST (code
))
2573 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2584 xsignal0 (Qarith_error
);
2598 if (!argnum
|| next
> accum
)
2602 if (!argnum
|| next
< accum
)
2608 XSETINT (val
, accum
);
2613 #define isnan(x) ((x) != (x))
2616 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2618 register int argnum
;
2621 register Lisp_Object
*args
;
2623 register Lisp_Object val
;
2626 for (; argnum
< nargs
; argnum
++)
2628 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2629 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2633 next
= XFLOAT_DATA (val
);
2637 args
[argnum
] = val
; /* runs into a compiler bug. */
2638 next
= XINT (args
[argnum
]);
2640 switch (SWITCH_ENUM_CAST (code
))
2646 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2656 if (! IEEE_FLOATING_POINT
&& next
== 0)
2657 xsignal0 (Qarith_error
);
2664 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2666 if (!argnum
|| isnan (next
) || next
> accum
)
2670 if (!argnum
|| isnan (next
) || next
< accum
)
2676 return make_float (accum
);
2680 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2681 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2682 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2687 return arith_driver (Aadd
, nargs
, args
);
2690 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2691 doc
: /* Negate number or subtract numbers or markers and return the result.
2692 With one arg, negates it. With more than one arg,
2693 subtracts all but the first from the first.
2694 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2699 return arith_driver (Asub
, nargs
, args
);
2702 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2703 doc
: /* Return product of any number of arguments, which are numbers or markers.
2704 usage: (* &rest NUMBERS-OR-MARKERS) */)
2709 return arith_driver (Amult
, nargs
, args
);
2712 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2713 doc
: /* Return first argument divided by all the remaining arguments.
2714 The arguments must be numbers or markers.
2715 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2721 for (argnum
= 2; argnum
< nargs
; argnum
++)
2722 if (FLOATP (args
[argnum
]))
2723 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2724 return arith_driver (Adiv
, nargs
, args
);
2727 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2728 doc
: /* Return remainder of X divided by Y.
2729 Both must be integers or markers. */)
2731 register Lisp_Object x
, y
;
2735 CHECK_NUMBER_COERCE_MARKER (x
);
2736 CHECK_NUMBER_COERCE_MARKER (y
);
2738 if (XFASTINT (y
) == 0)
2739 xsignal0 (Qarith_error
);
2741 XSETINT (val
, XINT (x
) % XINT (y
));
2755 /* If the magnitude of the result exceeds that of the divisor, or
2756 the sign of the result does not agree with that of the dividend,
2757 iterate with the reduced value. This does not yield a
2758 particularly accurate result, but at least it will be in the
2759 range promised by fmod. */
2761 r
-= f2
* floor (r
/ f2
);
2762 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2766 #endif /* ! HAVE_FMOD */
2768 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2769 doc
: /* Return X modulo Y.
2770 The result falls between zero (inclusive) and Y (exclusive).
2771 Both X and Y must be numbers or markers. */)
2773 register Lisp_Object x
, y
;
2778 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2779 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2781 if (FLOATP (x
) || FLOATP (y
))
2782 return fmod_float (x
, y
);
2788 xsignal0 (Qarith_error
);
2792 /* If the "remainder" comes out with the wrong sign, fix it. */
2793 if (i2
< 0 ? i1
> 0 : i1
< 0)
2800 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2801 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2802 The value is always a number; markers are converted to numbers.
2803 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2808 return arith_driver (Amax
, nargs
, args
);
2811 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2812 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2813 The value is always a number; markers are converted to numbers.
2814 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2819 return arith_driver (Amin
, nargs
, args
);
2822 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2823 doc
: /* Return bitwise-and of all the arguments.
2824 Arguments may be integers, or markers converted to integers.
2825 usage: (logand &rest INTS-OR-MARKERS) */)
2830 return arith_driver (Alogand
, nargs
, args
);
2833 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2834 doc
: /* Return bitwise-or of all the arguments.
2835 Arguments may be integers, or markers converted to integers.
2836 usage: (logior &rest INTS-OR-MARKERS) */)
2841 return arith_driver (Alogior
, nargs
, args
);
2844 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2845 doc
: /* Return bitwise-exclusive-or of all the arguments.
2846 Arguments may be integers, or markers converted to integers.
2847 usage: (logxor &rest INTS-OR-MARKERS) */)
2852 return arith_driver (Alogxor
, nargs
, args
);
2855 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2856 doc
: /* Return VALUE with its bits shifted left by COUNT.
2857 If COUNT is negative, shifting is actually to the right.
2858 In this case, the sign bit is duplicated. */)
2860 register Lisp_Object value
, count
;
2862 register Lisp_Object val
;
2864 CHECK_NUMBER (value
);
2865 CHECK_NUMBER (count
);
2867 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2869 else if (XINT (count
) > 0)
2870 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2871 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2872 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2874 XSETINT (val
, XINT (value
) >> -XINT (count
));
2878 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2879 doc
: /* Return VALUE with its bits shifted left by COUNT.
2880 If COUNT is negative, shifting is actually to the right.
2881 In this case, zeros are shifted in on the left. */)
2883 register Lisp_Object value
, count
;
2885 register Lisp_Object val
;
2887 CHECK_NUMBER (value
);
2888 CHECK_NUMBER (count
);
2890 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2892 else if (XINT (count
) > 0)
2893 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2894 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2897 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2901 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2902 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2903 Markers are converted to integers. */)
2905 register Lisp_Object number
;
2907 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2909 if (FLOATP (number
))
2910 return (make_float (1.0 + XFLOAT_DATA (number
)));
2912 XSETINT (number
, XINT (number
) + 1);
2916 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2917 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2918 Markers are converted to integers. */)
2920 register Lisp_Object number
;
2922 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2924 if (FLOATP (number
))
2925 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2927 XSETINT (number
, XINT (number
) - 1);
2931 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2932 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2934 register Lisp_Object number
;
2936 CHECK_NUMBER (number
);
2937 XSETINT (number
, ~XINT (number
));
2941 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2942 doc
: /* Return the byteorder for the machine.
2943 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2944 lowercase l) for small endian machines. */)
2947 unsigned i
= 0x04030201;
2948 int order
= *(char *)&i
== 1 ? 108 : 66;
2950 return make_number (order
);
2958 Lisp_Object error_tail
, arith_tail
;
2960 Qquote
= intern ("quote");
2961 Qlambda
= intern ("lambda");
2962 Qsubr
= intern ("subr");
2963 Qerror_conditions
= intern ("error-conditions");
2964 Qerror_message
= intern ("error-message");
2965 Qtop_level
= intern ("top-level");
2967 Qerror
= intern ("error");
2968 Qquit
= intern ("quit");
2969 Qwrong_type_argument
= intern ("wrong-type-argument");
2970 Qargs_out_of_range
= intern ("args-out-of-range");
2971 Qvoid_function
= intern ("void-function");
2972 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2973 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2974 Qvoid_variable
= intern ("void-variable");
2975 Qsetting_constant
= intern ("setting-constant");
2976 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2978 Qinvalid_function
= intern ("invalid-function");
2979 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2980 Qno_catch
= intern ("no-catch");
2981 Qend_of_file
= intern ("end-of-file");
2982 Qarith_error
= intern ("arith-error");
2983 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2984 Qend_of_buffer
= intern ("end-of-buffer");
2985 Qbuffer_read_only
= intern ("buffer-read-only");
2986 Qtext_read_only
= intern ("text-read-only");
2987 Qmark_inactive
= intern ("mark-inactive");
2989 Qlistp
= intern ("listp");
2990 Qconsp
= intern ("consp");
2991 Qsymbolp
= intern ("symbolp");
2992 Qkeywordp
= intern ("keywordp");
2993 Qintegerp
= intern ("integerp");
2994 Qnatnump
= intern ("natnump");
2995 Qwholenump
= intern ("wholenump");
2996 Qstringp
= intern ("stringp");
2997 Qarrayp
= intern ("arrayp");
2998 Qsequencep
= intern ("sequencep");
2999 Qbufferp
= intern ("bufferp");
3000 Qvectorp
= intern ("vectorp");
3001 Qchar_or_string_p
= intern ("char-or-string-p");
3002 Qmarkerp
= intern ("markerp");
3003 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3004 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3005 Qboundp
= intern ("boundp");
3006 Qfboundp
= intern ("fboundp");
3008 Qfloatp
= intern ("floatp");
3009 Qnumberp
= intern ("numberp");
3010 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3012 Qchar_table_p
= intern ("char-table-p");
3013 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3015 Qsubrp
= intern ("subrp");
3016 Qunevalled
= intern ("unevalled");
3017 Qmany
= intern ("many");
3019 Qcdr
= intern ("cdr");
3021 /* Handle automatic advice activation */
3022 Qad_advice_info
= intern ("ad-advice-info");
3023 Qad_activate_internal
= intern ("ad-activate-internal");
3025 error_tail
= Fcons (Qerror
, Qnil
);
3027 /* ERROR is used as a signaler for random errors for which nothing else is right */
3029 Fput (Qerror
, Qerror_conditions
,
3031 Fput (Qerror
, Qerror_message
,
3032 build_string ("error"));
3034 Fput (Qquit
, Qerror_conditions
,
3035 Fcons (Qquit
, Qnil
));
3036 Fput (Qquit
, Qerror_message
,
3037 build_string ("Quit"));
3039 Fput (Qwrong_type_argument
, Qerror_conditions
,
3040 Fcons (Qwrong_type_argument
, error_tail
));
3041 Fput (Qwrong_type_argument
, Qerror_message
,
3042 build_string ("Wrong type argument"));
3044 Fput (Qargs_out_of_range
, Qerror_conditions
,
3045 Fcons (Qargs_out_of_range
, error_tail
));
3046 Fput (Qargs_out_of_range
, Qerror_message
,
3047 build_string ("Args out of range"));
3049 Fput (Qvoid_function
, Qerror_conditions
,
3050 Fcons (Qvoid_function
, error_tail
));
3051 Fput (Qvoid_function
, Qerror_message
,
3052 build_string ("Symbol's function definition is void"));
3054 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3055 Fcons (Qcyclic_function_indirection
, error_tail
));
3056 Fput (Qcyclic_function_indirection
, Qerror_message
,
3057 build_string ("Symbol's chain of function indirections contains a loop"));
3059 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3060 Fcons (Qcyclic_variable_indirection
, error_tail
));
3061 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3062 build_string ("Symbol's chain of variable indirections contains a loop"));
3064 Qcircular_list
= intern ("circular-list");
3065 staticpro (&Qcircular_list
);
3066 Fput (Qcircular_list
, Qerror_conditions
,
3067 Fcons (Qcircular_list
, error_tail
));
3068 Fput (Qcircular_list
, Qerror_message
,
3069 build_string ("List contains a loop"));
3071 Fput (Qvoid_variable
, Qerror_conditions
,
3072 Fcons (Qvoid_variable
, error_tail
));
3073 Fput (Qvoid_variable
, Qerror_message
,
3074 build_string ("Symbol's value as variable is void"));
3076 Fput (Qsetting_constant
, Qerror_conditions
,
3077 Fcons (Qsetting_constant
, error_tail
));
3078 Fput (Qsetting_constant
, Qerror_message
,
3079 build_string ("Attempt to set a constant symbol"));
3081 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3082 Fcons (Qinvalid_read_syntax
, error_tail
));
3083 Fput (Qinvalid_read_syntax
, Qerror_message
,
3084 build_string ("Invalid read syntax"));
3086 Fput (Qinvalid_function
, Qerror_conditions
,
3087 Fcons (Qinvalid_function
, error_tail
));
3088 Fput (Qinvalid_function
, Qerror_message
,
3089 build_string ("Invalid function"));
3091 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3092 Fcons (Qwrong_number_of_arguments
, error_tail
));
3093 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3094 build_string ("Wrong number of arguments"));
3096 Fput (Qno_catch
, Qerror_conditions
,
3097 Fcons (Qno_catch
, error_tail
));
3098 Fput (Qno_catch
, Qerror_message
,
3099 build_string ("No catch for tag"));
3101 Fput (Qend_of_file
, Qerror_conditions
,
3102 Fcons (Qend_of_file
, error_tail
));
3103 Fput (Qend_of_file
, Qerror_message
,
3104 build_string ("End of file during parsing"));
3106 arith_tail
= Fcons (Qarith_error
, error_tail
);
3107 Fput (Qarith_error
, Qerror_conditions
,
3109 Fput (Qarith_error
, Qerror_message
,
3110 build_string ("Arithmetic error"));
3112 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3113 Fcons (Qbeginning_of_buffer
, error_tail
));
3114 Fput (Qbeginning_of_buffer
, Qerror_message
,
3115 build_string ("Beginning of buffer"));
3117 Fput (Qend_of_buffer
, Qerror_conditions
,
3118 Fcons (Qend_of_buffer
, error_tail
));
3119 Fput (Qend_of_buffer
, Qerror_message
,
3120 build_string ("End of buffer"));
3122 Fput (Qbuffer_read_only
, Qerror_conditions
,
3123 Fcons (Qbuffer_read_only
, error_tail
));
3124 Fput (Qbuffer_read_only
, Qerror_message
,
3125 build_string ("Buffer is read-only"));
3127 Fput (Qtext_read_only
, Qerror_conditions
,
3128 Fcons (Qtext_read_only
, error_tail
));
3129 Fput (Qtext_read_only
, Qerror_message
,
3130 build_string ("Text is read-only"));
3132 Qrange_error
= intern ("range-error");
3133 Qdomain_error
= intern ("domain-error");
3134 Qsingularity_error
= intern ("singularity-error");
3135 Qoverflow_error
= intern ("overflow-error");
3136 Qunderflow_error
= intern ("underflow-error");
3138 Fput (Qdomain_error
, Qerror_conditions
,
3139 Fcons (Qdomain_error
, arith_tail
));
3140 Fput (Qdomain_error
, Qerror_message
,
3141 build_string ("Arithmetic domain error"));
3143 Fput (Qrange_error
, Qerror_conditions
,
3144 Fcons (Qrange_error
, arith_tail
));
3145 Fput (Qrange_error
, Qerror_message
,
3146 build_string ("Arithmetic range error"));
3148 Fput (Qsingularity_error
, Qerror_conditions
,
3149 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3150 Fput (Qsingularity_error
, Qerror_message
,
3151 build_string ("Arithmetic singularity error"));
3153 Fput (Qoverflow_error
, Qerror_conditions
,
3154 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3155 Fput (Qoverflow_error
, Qerror_message
,
3156 build_string ("Arithmetic overflow error"));
3158 Fput (Qunderflow_error
, Qerror_conditions
,
3159 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3160 Fput (Qunderflow_error
, Qerror_message
,
3161 build_string ("Arithmetic underflow error"));
3163 staticpro (&Qrange_error
);
3164 staticpro (&Qdomain_error
);
3165 staticpro (&Qsingularity_error
);
3166 staticpro (&Qoverflow_error
);
3167 staticpro (&Qunderflow_error
);
3171 staticpro (&Qquote
);
3172 staticpro (&Qlambda
);
3174 staticpro (&Qunbound
);
3175 staticpro (&Qerror_conditions
);
3176 staticpro (&Qerror_message
);
3177 staticpro (&Qtop_level
);
3179 staticpro (&Qerror
);
3181 staticpro (&Qwrong_type_argument
);
3182 staticpro (&Qargs_out_of_range
);
3183 staticpro (&Qvoid_function
);
3184 staticpro (&Qcyclic_function_indirection
);
3185 staticpro (&Qcyclic_variable_indirection
);
3186 staticpro (&Qvoid_variable
);
3187 staticpro (&Qsetting_constant
);
3188 staticpro (&Qinvalid_read_syntax
);
3189 staticpro (&Qwrong_number_of_arguments
);
3190 staticpro (&Qinvalid_function
);
3191 staticpro (&Qno_catch
);
3192 staticpro (&Qend_of_file
);
3193 staticpro (&Qarith_error
);
3194 staticpro (&Qbeginning_of_buffer
);
3195 staticpro (&Qend_of_buffer
);
3196 staticpro (&Qbuffer_read_only
);
3197 staticpro (&Qtext_read_only
);
3198 staticpro (&Qmark_inactive
);
3200 staticpro (&Qlistp
);
3201 staticpro (&Qconsp
);
3202 staticpro (&Qsymbolp
);
3203 staticpro (&Qkeywordp
);
3204 staticpro (&Qintegerp
);
3205 staticpro (&Qnatnump
);
3206 staticpro (&Qwholenump
);
3207 staticpro (&Qstringp
);
3208 staticpro (&Qarrayp
);
3209 staticpro (&Qsequencep
);
3210 staticpro (&Qbufferp
);
3211 staticpro (&Qvectorp
);
3212 staticpro (&Qchar_or_string_p
);
3213 staticpro (&Qmarkerp
);
3214 staticpro (&Qbuffer_or_string_p
);
3215 staticpro (&Qinteger_or_marker_p
);
3216 staticpro (&Qfloatp
);
3217 staticpro (&Qnumberp
);
3218 staticpro (&Qnumber_or_marker_p
);
3219 staticpro (&Qchar_table_p
);
3220 staticpro (&Qvector_or_char_table_p
);
3221 staticpro (&Qsubrp
);
3223 staticpro (&Qunevalled
);
3225 staticpro (&Qboundp
);
3226 staticpro (&Qfboundp
);
3228 staticpro (&Qad_advice_info
);
3229 staticpro (&Qad_activate_internal
);
3231 /* Types that type-of returns. */
3232 Qinteger
= intern ("integer");
3233 Qsymbol
= intern ("symbol");
3234 Qstring
= intern ("string");
3235 Qcons
= intern ("cons");
3236 Qmarker
= intern ("marker");
3237 Qoverlay
= intern ("overlay");
3238 Qfloat
= intern ("float");
3239 Qwindow_configuration
= intern ("window-configuration");
3240 Qprocess
= intern ("process");
3241 Qwindow
= intern ("window");
3242 /* Qsubr = intern ("subr"); */
3243 Qcompiled_function
= intern ("compiled-function");
3244 Qbuffer
= intern ("buffer");
3245 Qframe
= intern ("frame");
3246 Qvector
= intern ("vector");
3247 Qchar_table
= intern ("char-table");
3248 Qbool_vector
= intern ("bool-vector");
3249 Qhash_table
= intern ("hash-table");
3251 staticpro (&Qinteger
);
3252 staticpro (&Qsymbol
);
3253 staticpro (&Qstring
);
3255 staticpro (&Qmarker
);
3256 staticpro (&Qoverlay
);
3257 staticpro (&Qfloat
);
3258 staticpro (&Qwindow_configuration
);
3259 staticpro (&Qprocess
);
3260 staticpro (&Qwindow
);
3261 /* staticpro (&Qsubr); */
3262 staticpro (&Qcompiled_function
);
3263 staticpro (&Qbuffer
);
3264 staticpro (&Qframe
);
3265 staticpro (&Qvector
);
3266 staticpro (&Qchar_table
);
3267 staticpro (&Qbool_vector
);
3268 staticpro (&Qhash_table
);
3270 defsubr (&Sindirect_variable
);
3271 defsubr (&Sinteractive_form
);
3274 defsubr (&Stype_of
);
3279 defsubr (&Sintegerp
);
3280 defsubr (&Sinteger_or_marker_p
);
3281 defsubr (&Snumberp
);
3282 defsubr (&Snumber_or_marker_p
);
3284 defsubr (&Snatnump
);
3285 defsubr (&Ssymbolp
);
3286 defsubr (&Skeywordp
);
3287 defsubr (&Sstringp
);
3288 defsubr (&Smultibyte_string_p
);
3289 defsubr (&Svectorp
);
3290 defsubr (&Schar_table_p
);
3291 defsubr (&Svector_or_char_table_p
);
3292 defsubr (&Sbool_vector_p
);
3294 defsubr (&Ssequencep
);
3295 defsubr (&Sbufferp
);
3296 defsubr (&Smarkerp
);
3298 defsubr (&Sbyte_code_function_p
);
3299 defsubr (&Schar_or_string_p
);
3302 defsubr (&Scar_safe
);
3303 defsubr (&Scdr_safe
);
3306 defsubr (&Ssymbol_function
);
3307 defsubr (&Sindirect_function
);
3308 defsubr (&Ssymbol_plist
);
3309 defsubr (&Ssymbol_name
);
3310 defsubr (&Smakunbound
);
3311 defsubr (&Sfmakunbound
);
3313 defsubr (&Sfboundp
);
3315 defsubr (&Sdefalias
);
3316 defsubr (&Ssetplist
);
3317 defsubr (&Ssymbol_value
);
3319 defsubr (&Sdefault_boundp
);
3320 defsubr (&Sdefault_value
);
3321 defsubr (&Sset_default
);
3322 defsubr (&Ssetq_default
);
3323 defsubr (&Smake_variable_buffer_local
);
3324 defsubr (&Smake_local_variable
);
3325 defsubr (&Skill_local_variable
);
3326 defsubr (&Smake_variable_frame_local
);
3327 defsubr (&Slocal_variable_p
);
3328 defsubr (&Slocal_variable_if_set_p
);
3329 defsubr (&Svariable_binding_locus
);
3332 defsubr (&Snumber_to_string
);
3333 defsubr (&Sstring_to_number
);
3334 defsubr (&Seqlsign
);
3357 defsubr (&Sbyteorder
);
3358 defsubr (&Ssubr_arity
);
3359 defsubr (&Ssubr_name
);
3361 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3363 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3364 doc
: /* The largest value that is representable in a Lisp integer. */);
3365 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3367 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3368 doc
: /* The smallest value that is representable in a Lisp integer. */);
3369 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3376 #if defined(USG) && !defined(POSIX_SIGNALS)
3377 /* USG systems forget handlers when they are used;
3378 must reestablish each time */
3379 signal (signo
, arith_error
);
3382 /* VMS systems are like USG. */
3383 signal (signo
, arith_error
);
3387 #else /* not BSD4_1 */
3388 sigsetmask (SIGEMPTYMASK
);
3389 #endif /* not BSD4_1 */
3391 SIGNAL_THREAD_CHECK (signo
);
3392 xsignal0 (Qarith_error
);
3398 /* Don't do this if just dumping out.
3399 We don't want to call `signal' in this case
3400 so that we don't have trouble with dumping
3401 signal-delivering routines in an inconsistent state. */
3405 #endif /* CANNOT_DUMP */
3406 signal (SIGFPE
, arith_error
);
3409 signal (SIGEMT
, arith_error
);
3413 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3414 (do not change this comment) */