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 register Lisp_Object function
;
667 CHECK_SYMBOL (symbol
);
668 if (NILP (symbol
) || EQ (symbol
, Qt
))
669 xsignal1 (Qsetting_constant
, symbol
);
671 function
= XSYMBOL (symbol
)->function
;
673 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
674 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
676 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
677 Fput (symbol
, Qautoload
, XCDR (function
));
679 XSYMBOL (symbol
)->function
= definition
;
680 /* Handle automatic advice activation */
681 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
683 call2 (Qad_activate_internal
, symbol
, Qnil
);
684 definition
= XSYMBOL (symbol
)->function
;
689 extern Lisp_Object Qfunction_documentation
;
691 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
692 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
693 Associates the function with the current load file, if any.
694 The optional third argument DOCSTRING specifies the documentation string
695 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
696 determined by DEFINITION. */)
697 (symbol
, definition
, docstring
)
698 register Lisp_Object symbol
, definition
, docstring
;
700 CHECK_SYMBOL (symbol
);
701 if (CONSP (XSYMBOL (symbol
)->function
)
702 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
703 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
704 definition
= Ffset (symbol
, definition
);
705 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
706 if (!NILP (docstring
))
707 Fput (symbol
, Qfunction_documentation
, docstring
);
711 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
712 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
714 register Lisp_Object symbol
, newplist
;
716 CHECK_SYMBOL (symbol
);
717 XSYMBOL (symbol
)->plist
= newplist
;
721 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
722 doc
: /* Return minimum and maximum number of args allowed for SUBR.
723 SUBR must be a built-in function.
724 The returned value is a pair (MIN . MAX). MIN is the minimum number
725 of args. MAX is the maximum number or the symbol `many', for a
726 function with `&rest' args, or `unevalled' for a special form. */)
730 short minargs
, maxargs
;
732 minargs
= XSUBR (subr
)->min_args
;
733 maxargs
= XSUBR (subr
)->max_args
;
735 return Fcons (make_number (minargs
), Qmany
);
736 else if (maxargs
== UNEVALLED
)
737 return Fcons (make_number (minargs
), Qunevalled
);
739 return Fcons (make_number (minargs
), make_number (maxargs
));
742 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
743 doc
: /* Return name of subroutine SUBR.
744 SUBR must be a built-in function. */)
750 name
= XSUBR (subr
)->symbol_name
;
751 return make_string (name
, strlen (name
));
754 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
755 doc
: /* Return the interactive form of CMD or nil if none.
756 If CMD is not a command, the return value is nil.
757 Value, if non-nil, is a list \(interactive SPEC). */)
761 Lisp_Object fun
= indirect_function (cmd
);
765 if (XSUBR (fun
)->prompt
)
766 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
768 else if (COMPILEDP (fun
))
770 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
771 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
773 else if (CONSP (fun
))
775 Lisp_Object funcar
= XCAR (fun
);
776 if (EQ (funcar
, Qlambda
))
777 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
778 else if (EQ (funcar
, Qautoload
))
782 do_autoload (fun
, cmd
);
784 return Finteractive_form (cmd
);
791 /***********************************************************************
792 Getting and Setting Values of Symbols
793 ***********************************************************************/
795 /* Return the symbol holding SYMBOL's value. Signal
796 `cyclic-variable-indirection' if SYMBOL's chain of variable
797 indirections contains a loop. */
800 indirect_variable (symbol
)
803 Lisp_Object tortoise
, hare
;
805 hare
= tortoise
= symbol
;
807 while (XSYMBOL (hare
)->indirect_variable
)
809 hare
= XSYMBOL (hare
)->value
;
810 if (!XSYMBOL (hare
)->indirect_variable
)
813 hare
= XSYMBOL (hare
)->value
;
814 tortoise
= XSYMBOL (tortoise
)->value
;
816 if (EQ (hare
, tortoise
))
817 xsignal1 (Qcyclic_variable_indirection
, symbol
);
824 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
825 doc
: /* Return the variable at the end of OBJECT's variable chain.
826 If OBJECT is a symbol, follow all variable indirections and return the final
827 variable. If OBJECT is not a symbol, just return it.
828 Signal a cyclic-variable-indirection error if there is a loop in the
829 variable chain of symbols. */)
833 if (SYMBOLP (object
))
834 object
= indirect_variable (object
);
839 /* Given the raw contents of a symbol value cell,
840 return the Lisp value of the symbol.
841 This does not handle buffer-local variables; use
842 swap_in_symval_forwarding for that. */
845 do_symval_forwarding (valcontents
)
846 register Lisp_Object valcontents
;
848 register Lisp_Object val
;
850 if (MISCP (valcontents
))
851 switch (XMISCTYPE (valcontents
))
853 case Lisp_Misc_Intfwd
:
854 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
857 case Lisp_Misc_Boolfwd
:
858 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
860 case Lisp_Misc_Objfwd
:
861 return *XOBJFWD (valcontents
)->objvar
;
863 case Lisp_Misc_Buffer_Objfwd
:
864 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
865 return PER_BUFFER_VALUE (current_buffer
, offset
);
867 case Lisp_Misc_Kboard_Objfwd
:
868 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
869 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
874 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
875 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
876 buffer-independent contents of the value cell: forwarded just one
877 step past the buffer-localness.
879 BUF non-zero means set the value in buffer BUF instead of the
880 current buffer. This only plays a role for per-buffer variables. */
883 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
885 register Lisp_Object valcontents
, newval
;
888 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
891 switch (XMISCTYPE (valcontents
))
893 case Lisp_Misc_Intfwd
:
894 CHECK_NUMBER (newval
);
895 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
896 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
897 error ("Value out of range for variable `%s'",
898 SDATA (SYMBOL_NAME (symbol
)));
901 case Lisp_Misc_Boolfwd
:
902 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
905 case Lisp_Misc_Objfwd
:
906 *XOBJFWD (valcontents
)->objvar
= newval
;
908 /* If this variable is a default for something stored
909 in the buffer itself, such as default-fill-column,
910 find the buffers that don't have local values for it
912 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
913 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
915 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
916 - (char *) &buffer_defaults
);
917 int idx
= PER_BUFFER_IDX (offset
);
924 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
929 buf
= Fcdr (XCAR (tail
));
930 if (!BUFFERP (buf
)) continue;
933 if (! PER_BUFFER_VALUE_P (b
, idx
))
934 PER_BUFFER_VALUE (b
, offset
) = newval
;
939 case Lisp_Misc_Buffer_Objfwd
:
941 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
944 type
= PER_BUFFER_TYPE (offset
);
945 if (! NILP (type
) && ! NILP (newval
)
946 && XTYPE (newval
) != XINT (type
))
947 buffer_slot_type_mismatch (offset
);
950 buf
= current_buffer
;
951 PER_BUFFER_VALUE (buf
, offset
) = newval
;
955 case Lisp_Misc_Kboard_Objfwd
:
957 char *base
= (char *) current_kboard
;
958 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
959 *(Lisp_Object
*) p
= newval
;
970 valcontents
= SYMBOL_VALUE (symbol
);
971 if (BUFFER_LOCAL_VALUEP (valcontents
)
972 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
973 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
975 SET_SYMBOL_VALUE (symbol
, newval
);
979 /* Set up SYMBOL to refer to its global binding.
980 This makes it safe to alter the status of other bindings. */
983 swap_in_global_binding (symbol
)
986 Lisp_Object valcontents
, cdr
;
988 valcontents
= SYMBOL_VALUE (symbol
);
989 if (!BUFFER_LOCAL_VALUEP (valcontents
)
990 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
992 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
994 /* Unload the previously loaded binding. */
996 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
998 /* Select the global binding in the symbol. */
1000 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1002 /* Indicate that the global binding is set up now. */
1003 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1004 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1005 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1006 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1009 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1010 VALCONTENTS is the contents of its value cell,
1011 which points to a struct Lisp_Buffer_Local_Value.
1013 Return the value forwarded one step past the buffer-local stage.
1014 This could be another forwarding pointer. */
1017 swap_in_symval_forwarding (symbol
, valcontents
)
1018 Lisp_Object symbol
, valcontents
;
1020 register Lisp_Object tem1
;
1022 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1025 || current_buffer
!= XBUFFER (tem1
)
1026 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1027 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1029 if (XSYMBOL (symbol
)->indirect_variable
)
1030 symbol
= indirect_variable (symbol
);
1032 /* Unload the previously loaded binding. */
1033 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1035 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1036 /* Choose the new binding. */
1037 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1038 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1039 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1042 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1043 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1045 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1047 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1050 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1052 /* Load the new binding. */
1053 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1054 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1055 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1056 store_symval_forwarding (symbol
,
1057 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1060 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1063 /* Find the value of a symbol, returning Qunbound if it's not bound.
1064 This is helpful for code which just wants to get a variable's value
1065 if it has one, without signaling an error.
1066 Note that it must not be possible to quit
1067 within this function. Great care is required for this. */
1070 find_symbol_value (symbol
)
1073 register Lisp_Object valcontents
;
1074 register Lisp_Object val
;
1076 CHECK_SYMBOL (symbol
);
1077 valcontents
= SYMBOL_VALUE (symbol
);
1079 if (BUFFER_LOCAL_VALUEP (valcontents
)
1080 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1081 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1083 if (MISCP (valcontents
))
1085 switch (XMISCTYPE (valcontents
))
1087 case Lisp_Misc_Intfwd
:
1088 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1091 case Lisp_Misc_Boolfwd
:
1092 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1094 case Lisp_Misc_Objfwd
:
1095 return *XOBJFWD (valcontents
)->objvar
;
1097 case Lisp_Misc_Buffer_Objfwd
:
1098 return PER_BUFFER_VALUE (current_buffer
,
1099 XBUFFER_OBJFWD (valcontents
)->offset
);
1101 case Lisp_Misc_Kboard_Objfwd
:
1102 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1103 + (char *)current_kboard
);
1110 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1111 doc
: /* Return SYMBOL's value. Error if that is void. */)
1117 val
= find_symbol_value (symbol
);
1118 if (!EQ (val
, Qunbound
))
1121 xsignal1 (Qvoid_variable
, symbol
);
1124 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1125 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1127 register Lisp_Object symbol
, newval
;
1129 return set_internal (symbol
, newval
, current_buffer
, 0);
1132 /* Return 1 if SYMBOL currently has a let-binding
1133 which was made in the buffer that is now current. */
1136 let_shadows_buffer_binding_p (symbol
)
1139 volatile struct specbinding
*p
;
1141 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1143 && CONSP (p
->symbol
))
1145 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1146 if ((EQ (symbol
, let_bound_symbol
)
1147 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1148 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1149 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1153 return p
>= specpdl
;
1156 /* Store the value NEWVAL into SYMBOL.
1157 If buffer-locality is an issue, BUF specifies which buffer to use.
1158 (0 stands for the current buffer.)
1160 If BINDFLAG is zero, then if this symbol is supposed to become
1161 local in every buffer where it is set, then we make it local.
1162 If BINDFLAG is nonzero, we don't do that. */
1165 set_internal (symbol
, newval
, buf
, bindflag
)
1166 register Lisp_Object symbol
, newval
;
1170 int voide
= EQ (newval
, Qunbound
);
1172 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1175 buf
= current_buffer
;
1177 /* If restoring in a dead buffer, do nothing. */
1178 if (NILP (buf
->name
))
1181 CHECK_SYMBOL (symbol
);
1182 if (SYMBOL_CONSTANT_P (symbol
)
1183 && (NILP (Fkeywordp (symbol
))
1184 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1185 xsignal1 (Qsetting_constant
, symbol
);
1187 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1189 if (BUFFER_OBJFWDP (valcontents
))
1191 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1192 int idx
= PER_BUFFER_IDX (offset
);
1195 && !let_shadows_buffer_binding_p (symbol
))
1196 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1198 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1199 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1201 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1202 if (XSYMBOL (symbol
)->indirect_variable
)
1203 symbol
= indirect_variable (symbol
);
1205 /* What binding is loaded right now? */
1206 current_alist_element
1207 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1209 /* If the current buffer is not the buffer whose binding is
1210 loaded, or if there may be frame-local bindings and the frame
1211 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1212 the default binding is loaded, the loaded binding may be the
1214 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1215 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1216 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1217 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1218 || (BUFFER_LOCAL_VALUEP (valcontents
)
1219 && EQ (XCAR (current_alist_element
),
1220 current_alist_element
)))
1222 /* The currently loaded binding is not necessarily valid.
1223 We need to unload it, and choose a new binding. */
1225 /* Write out `realvalue' to the old loaded binding. */
1226 Fsetcdr (current_alist_element
,
1227 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1229 /* Find the new binding. */
1230 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1231 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1232 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1236 /* This buffer still sees the default value. */
1238 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1239 or if this is `let' rather than `set',
1240 make CURRENT-ALIST-ELEMENT point to itself,
1241 indicating that we're seeing the default value.
1242 Likewise if the variable has been let-bound
1243 in the current buffer. */
1244 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1245 || let_shadows_buffer_binding_p (symbol
))
1247 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1249 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1250 tem1
= Fassq (symbol
,
1251 XFRAME (selected_frame
)->param_alist
);
1254 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1256 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1258 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1259 and we're not within a let that was made for this buffer,
1260 create a new buffer-local binding for the variable.
1261 That means, give this buffer a new assoc for a local value
1262 and load that binding. */
1265 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1266 buf
->local_var_alist
1267 = Fcons (tem1
, buf
->local_var_alist
);
1271 /* Record which binding is now loaded. */
1272 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1275 /* Set `buffer' and `frame' slots for the binding now loaded. */
1276 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1277 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1279 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1282 /* If storing void (making the symbol void), forward only through
1283 buffer-local indicator, not through Lisp_Objfwd, etc. */
1285 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1287 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1289 /* If we just set a variable whose current binding is frame-local,
1290 store the new value in the frame parameter too. */
1292 if (BUFFER_LOCAL_VALUEP (valcontents
)
1293 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1295 /* What binding is loaded right now? */
1296 current_alist_element
1297 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1299 /* If the current buffer is not the buffer whose binding is
1300 loaded, or if there may be frame-local bindings and the frame
1301 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1302 the default binding is loaded, the loaded binding may be the
1304 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1305 XSETCDR (current_alist_element
, newval
);
1311 /* Access or set a buffer-local symbol's default value. */
1313 /* Return the default value of SYMBOL, but don't check for voidness.
1314 Return Qunbound if it is void. */
1317 default_value (symbol
)
1320 register Lisp_Object valcontents
;
1322 CHECK_SYMBOL (symbol
);
1323 valcontents
= SYMBOL_VALUE (symbol
);
1325 /* For a built-in buffer-local variable, get the default value
1326 rather than letting do_symval_forwarding get the current value. */
1327 if (BUFFER_OBJFWDP (valcontents
))
1329 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1330 if (PER_BUFFER_IDX (offset
) != 0)
1331 return PER_BUFFER_DEFAULT (offset
);
1334 /* Handle user-created local variables. */
1335 if (BUFFER_LOCAL_VALUEP (valcontents
)
1336 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1338 /* If var is set up for a buffer that lacks a local value for it,
1339 the current value is nominally the default value.
1340 But the `realvalue' slot may be more up to date, since
1341 ordinary setq stores just that slot. So use that. */
1342 Lisp_Object current_alist_element
, alist_element_car
;
1343 current_alist_element
1344 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1345 alist_element_car
= XCAR (current_alist_element
);
1346 if (EQ (alist_element_car
, current_alist_element
))
1347 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1349 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1351 /* For other variables, get the current value. */
1352 return do_symval_forwarding (valcontents
);
1355 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1356 doc
: /* Return t if SYMBOL has a non-void default value.
1357 This is the value that is seen in buffers that do not have their own values
1358 for this variable. */)
1362 register Lisp_Object value
;
1364 value
= default_value (symbol
);
1365 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1368 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1369 doc
: /* Return SYMBOL's default value.
1370 This is the value that is seen in buffers that do not have their own values
1371 for this variable. The default value is meaningful for variables with
1372 local bindings in certain buffers. */)
1376 register Lisp_Object value
;
1378 value
= default_value (symbol
);
1379 if (!EQ (value
, Qunbound
))
1382 xsignal1 (Qvoid_variable
, symbol
);
1385 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1386 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1387 The default value is seen in buffers that do not have their own values
1388 for this variable. */)
1390 Lisp_Object symbol
, value
;
1392 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1394 CHECK_SYMBOL (symbol
);
1395 valcontents
= SYMBOL_VALUE (symbol
);
1397 /* Handle variables like case-fold-search that have special slots
1398 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1400 if (BUFFER_OBJFWDP (valcontents
))
1402 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1403 int idx
= PER_BUFFER_IDX (offset
);
1405 PER_BUFFER_DEFAULT (offset
) = value
;
1407 /* If this variable is not always local in all buffers,
1408 set it in the buffers that don't nominally have a local value. */
1413 for (b
= all_buffers
; b
; b
= b
->next
)
1414 if (!PER_BUFFER_VALUE_P (b
, idx
))
1415 PER_BUFFER_VALUE (b
, offset
) = value
;
1420 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1421 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1422 return Fset (symbol
, value
);
1424 /* Store new value into the DEFAULT-VALUE slot. */
1425 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1427 /* If the default binding is now loaded, set the REALVALUE slot too. */
1428 current_alist_element
1429 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1430 alist_element_buffer
= Fcar (current_alist_element
);
1431 if (EQ (alist_element_buffer
, current_alist_element
))
1432 store_symval_forwarding (symbol
,
1433 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1439 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1440 doc
: /* Set the default value of variable VAR to VALUE.
1441 VAR, the variable name, is literal (not evaluated);
1442 VALUE is an expression: it is evaluated and its value returned.
1443 The default value of a variable is seen in buffers
1444 that do not have their own values for the variable.
1446 More generally, you can use multiple variables and values, as in
1447 (setq-default VAR VALUE VAR VALUE...)
1448 This sets each VAR's default value to the corresponding VALUE.
1449 The VALUE for the Nth VAR can refer to the new default values
1451 usage: (setq-default [VAR VALUE]...) */)
1455 register Lisp_Object args_left
;
1456 register Lisp_Object val
, symbol
;
1457 struct gcpro gcpro1
;
1467 val
= Feval (Fcar (Fcdr (args_left
)));
1468 symbol
= XCAR (args_left
);
1469 Fset_default (symbol
, val
);
1470 args_left
= Fcdr (XCDR (args_left
));
1472 while (!NILP (args_left
));
1478 /* Lisp functions for creating and removing buffer-local variables. */
1480 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1481 1, 1, "vMake Variable Buffer Local: ",
1482 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1483 At any time, the value for the current buffer is in effect,
1484 unless the variable has never been set in this buffer,
1485 in which case the default value is in effect.
1486 Note that binding the variable with `let', or setting it while
1487 a `let'-style binding made in this buffer is in effect,
1488 does not make the variable buffer-local. Return VARIABLE.
1490 In most cases it is better to use `make-local-variable',
1491 which makes a variable local in just one buffer.
1493 The function `default-value' gets the default value and `set-default' sets it. */)
1495 register Lisp_Object variable
;
1497 register Lisp_Object tem
, valcontents
, newval
;
1499 CHECK_SYMBOL (variable
);
1500 variable
= indirect_variable (variable
);
1502 valcontents
= SYMBOL_VALUE (variable
);
1503 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1504 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1506 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1508 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1510 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1513 if (EQ (valcontents
, Qunbound
))
1514 SET_SYMBOL_VALUE (variable
, Qnil
);
1515 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1517 newval
= allocate_misc ();
1518 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1519 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1520 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1521 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1522 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1523 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1524 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1525 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1526 SET_SYMBOL_VALUE (variable
, newval
);
1530 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1531 1, 1, "vMake Local Variable: ",
1532 doc
: /* Make VARIABLE have a separate value in the current buffer.
1533 Other buffers will continue to share a common default value.
1534 \(The buffer-local value of VARIABLE starts out as the same value
1535 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1538 If the variable is already arranged to become local when set,
1539 this function causes a local value to exist for this buffer,
1540 just as setting the variable would do.
1542 This function returns VARIABLE, and therefore
1543 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1546 See also `make-variable-buffer-local'.
1548 Do not use `make-local-variable' to make a hook variable buffer-local.
1549 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1551 register Lisp_Object variable
;
1553 register Lisp_Object tem
, valcontents
;
1555 CHECK_SYMBOL (variable
);
1556 variable
= indirect_variable (variable
);
1558 valcontents
= SYMBOL_VALUE (variable
);
1559 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1560 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1562 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1564 tem
= Fboundp (variable
);
1566 /* Make sure the symbol has a local value in this particular buffer,
1567 by setting it to the same value it already has. */
1568 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1571 /* Make sure symbol is set up to hold per-buffer values. */
1572 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1575 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1577 newval
= allocate_misc ();
1578 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1579 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1580 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1581 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1582 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1583 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1584 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1585 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1586 SET_SYMBOL_VALUE (variable
, newval
);
1588 /* Make sure this buffer has its own value of symbol. */
1589 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1592 /* Swap out any local binding for some other buffer, and make
1593 sure the current value is permanently recorded, if it's the
1595 find_symbol_value (variable
);
1597 current_buffer
->local_var_alist
1598 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1599 current_buffer
->local_var_alist
);
1601 /* Make sure symbol does not think it is set up for this buffer;
1602 force it to look once again for this buffer's value. */
1604 Lisp_Object
*pvalbuf
;
1606 valcontents
= SYMBOL_VALUE (variable
);
1608 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1609 if (current_buffer
== XBUFFER (*pvalbuf
))
1611 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1615 /* If the symbol forwards into a C variable, then load the binding
1616 for this buffer now. If C code modifies the variable before we
1617 load the binding in, then that new value will clobber the default
1618 binding the next time we unload it. */
1619 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1620 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1621 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1626 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1627 1, 1, "vKill Local Variable: ",
1628 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1629 From now on the default value will apply in this buffer. Return VARIABLE. */)
1631 register Lisp_Object variable
;
1633 register Lisp_Object tem
, valcontents
;
1635 CHECK_SYMBOL (variable
);
1636 variable
= indirect_variable (variable
);
1638 valcontents
= SYMBOL_VALUE (variable
);
1640 if (BUFFER_OBJFWDP (valcontents
))
1642 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1643 int idx
= PER_BUFFER_IDX (offset
);
1647 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1648 PER_BUFFER_VALUE (current_buffer
, offset
)
1649 = PER_BUFFER_DEFAULT (offset
);
1654 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1655 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1658 /* Get rid of this buffer's alist element, if any. */
1660 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1662 current_buffer
->local_var_alist
1663 = Fdelq (tem
, current_buffer
->local_var_alist
);
1665 /* If the symbol is set up with the current buffer's binding
1666 loaded, recompute its value. We have to do it now, or else
1667 forwarded objects won't work right. */
1669 Lisp_Object
*pvalbuf
, buf
;
1670 valcontents
= SYMBOL_VALUE (variable
);
1671 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1672 XSETBUFFER (buf
, current_buffer
);
1673 if (EQ (buf
, *pvalbuf
))
1676 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1677 find_symbol_value (variable
);
1684 /* Lisp functions for creating and removing buffer-local variables. */
1686 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1687 1, 1, "vMake Variable Frame Local: ",
1688 doc
: /* Enable VARIABLE to have frame-local bindings.
1689 This does not create any frame-local bindings for VARIABLE,
1690 it just makes them possible.
1692 A frame-local binding is actually a frame parameter value.
1693 If a frame F has a value for the frame parameter named VARIABLE,
1694 that also acts as a frame-local binding for VARIABLE in F--
1695 provided this function has been called to enable VARIABLE
1696 to have frame-local bindings at all.
1698 The only way to create a frame-local binding for VARIABLE in a frame
1699 is to set the VARIABLE frame parameter of that frame. See
1700 `modify-frame-parameters' for how to set frame parameters.
1702 Buffer-local bindings take precedence over frame-local bindings. */)
1704 register Lisp_Object variable
;
1706 register Lisp_Object tem
, valcontents
, newval
;
1708 CHECK_SYMBOL (variable
);
1709 variable
= indirect_variable (variable
);
1711 valcontents
= SYMBOL_VALUE (variable
);
1712 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1713 || BUFFER_OBJFWDP (valcontents
))
1714 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1716 if (BUFFER_LOCAL_VALUEP (valcontents
)
1717 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1719 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1723 if (EQ (valcontents
, Qunbound
))
1724 SET_SYMBOL_VALUE (variable
, Qnil
);
1725 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1727 newval
= allocate_misc ();
1728 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1729 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1730 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1731 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1732 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1733 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1734 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1735 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1736 SET_SYMBOL_VALUE (variable
, newval
);
1740 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1742 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1743 BUFFER defaults to the current buffer. */)
1745 register Lisp_Object variable
, buffer
;
1747 Lisp_Object valcontents
;
1748 register struct buffer
*buf
;
1751 buf
= current_buffer
;
1754 CHECK_BUFFER (buffer
);
1755 buf
= XBUFFER (buffer
);
1758 CHECK_SYMBOL (variable
);
1759 variable
= indirect_variable (variable
);
1761 valcontents
= SYMBOL_VALUE (variable
);
1762 if (BUFFER_LOCAL_VALUEP (valcontents
)
1763 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1765 Lisp_Object tail
, elt
;
1767 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1770 if (EQ (variable
, XCAR (elt
)))
1774 if (BUFFER_OBJFWDP (valcontents
))
1776 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1777 int idx
= PER_BUFFER_IDX (offset
);
1778 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1784 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1786 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1787 More precisely, this means that setting the variable \(with `set' or`setq'),
1788 while it does not have a `let'-style binding that was made in BUFFER,
1789 will produce a buffer local binding. See Info node
1790 `(elisp)Creating Buffer-Local'.
1791 BUFFER defaults to the current buffer. */)
1793 register Lisp_Object variable
, buffer
;
1795 Lisp_Object valcontents
;
1796 register struct buffer
*buf
;
1799 buf
= current_buffer
;
1802 CHECK_BUFFER (buffer
);
1803 buf
= XBUFFER (buffer
);
1806 CHECK_SYMBOL (variable
);
1807 variable
= indirect_variable (variable
);
1809 valcontents
= SYMBOL_VALUE (variable
);
1811 /* This means that make-variable-buffer-local was done. */
1812 if (BUFFER_LOCAL_VALUEP (valcontents
))
1814 /* All these slots become local if they are set. */
1815 if (BUFFER_OBJFWDP (valcontents
))
1817 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1819 Lisp_Object tail
, elt
;
1820 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1823 if (EQ (variable
, XCAR (elt
)))
1830 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1832 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1833 If the current binding is buffer-local, the value is the current buffer.
1834 If the current binding is frame-local, the value is the selected frame.
1835 If the current binding is global (the default), the value is nil. */)
1837 register Lisp_Object variable
;
1839 Lisp_Object valcontents
;
1841 CHECK_SYMBOL (variable
);
1842 variable
= indirect_variable (variable
);
1844 /* Make sure the current binding is actually swapped in. */
1845 find_symbol_value (variable
);
1847 valcontents
= XSYMBOL (variable
)->value
;
1849 if (BUFFER_LOCAL_VALUEP (valcontents
)
1850 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1851 || BUFFER_OBJFWDP (valcontents
))
1853 /* For a local variable, record both the symbol and which
1854 buffer's or frame's value we are saving. */
1855 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1856 return Fcurrent_buffer ();
1857 else if (!BUFFER_OBJFWDP (valcontents
)
1858 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1859 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1865 /* Find the function at the end of a chain of symbol function indirections. */
1867 /* If OBJECT is a symbol, find the end of its function chain and
1868 return the value found there. If OBJECT is not a symbol, just
1869 return it. If there is a cycle in the function chain, signal a
1870 cyclic-function-indirection error.
1872 This is like Findirect_function, except that it doesn't signal an
1873 error if the chain ends up unbound. */
1875 indirect_function (object
)
1876 register Lisp_Object object
;
1878 Lisp_Object tortoise
, hare
;
1880 hare
= tortoise
= object
;
1884 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1886 hare
= XSYMBOL (hare
)->function
;
1887 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1889 hare
= XSYMBOL (hare
)->function
;
1891 tortoise
= XSYMBOL (tortoise
)->function
;
1893 if (EQ (hare
, tortoise
))
1894 xsignal1 (Qcyclic_function_indirection
, object
);
1900 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1901 doc
: /* Return the function at the end of OBJECT's function chain.
1902 If OBJECT is not a symbol, just return it. Otherwise, follow all
1903 function indirections to find the final function binding and return it.
1904 If the final symbol in the chain is unbound, signal a void-function error.
1905 Optional arg NOERROR non-nil means to return nil instead of signalling.
1906 Signal a cyclic-function-indirection error if there is a loop in the
1907 function chain of symbols. */)
1909 register Lisp_Object object
;
1910 Lisp_Object noerror
;
1914 /* Optimize for no indirection. */
1916 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1917 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1918 result
= indirect_function (result
);
1919 if (!EQ (result
, Qunbound
))
1923 xsignal1 (Qvoid_function
, object
);
1928 /* Extract and set vector and string elements */
1930 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1931 doc
: /* Return the element of ARRAY at index IDX.
1932 ARRAY may be a vector, a string, a char-table, a bool-vector,
1933 or a byte-code object. IDX starts at 0. */)
1935 register Lisp_Object array
;
1938 register int idxval
;
1941 idxval
= XINT (idx
);
1942 if (STRINGP (array
))
1946 if (idxval
< 0 || idxval
>= SCHARS (array
))
1947 args_out_of_range (array
, idx
);
1948 if (! STRING_MULTIBYTE (array
))
1949 return make_number ((unsigned char) SREF (array
, idxval
));
1950 idxval_byte
= string_char_to_byte (array
, idxval
);
1952 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1953 SBYTES (array
) - idxval_byte
);
1954 return make_number (c
);
1956 else if (BOOL_VECTOR_P (array
))
1960 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1961 args_out_of_range (array
, idx
);
1963 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1964 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1966 else if (CHAR_TABLE_P (array
))
1973 args_out_of_range (array
, idx
);
1974 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1976 if (! SINGLE_BYTE_CHAR_P (idxval
))
1977 args_out_of_range (array
, idx
);
1978 /* For ASCII and 8-bit European characters, the element is
1979 stored in the top table. */
1980 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1984 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
1985 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
1986 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
1987 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
1990 val
= XCHAR_TABLE (array
)->defalt
;
1991 while (NILP (val
)) /* Follow parents until we find some value. */
1993 array
= XCHAR_TABLE (array
)->parent
;
1996 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1998 val
= XCHAR_TABLE (array
)->defalt
;
2005 Lisp_Object sub_table
;
2006 Lisp_Object current_default
;
2008 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2009 if (code
[1] < 32) code
[1] = -1;
2010 else if (code
[2] < 32) code
[2] = -1;
2012 /* Here, the possible range of CODE[0] (== charset ID) is
2013 128..MAX_CHARSET. Since the top level char table contains
2014 data for multibyte characters after 256th element, we must
2015 increment CODE[0] by 128 to get a correct index. */
2017 code
[3] = -1; /* anchor */
2019 try_parent_char_table
:
2020 current_default
= XCHAR_TABLE (array
)->defalt
;
2022 for (i
= 0; code
[i
] >= 0; i
++)
2024 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2025 if (SUB_CHAR_TABLE_P (val
))
2028 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2029 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2034 val
= current_default
;
2037 array
= XCHAR_TABLE (array
)->parent
;
2039 goto try_parent_char_table
;
2044 /* Reaching here means IDXVAL is a generic character in
2045 which each character or a group has independent value.
2046 Essentially it's nonsense to get a value for such a
2047 generic character, but for backward compatibility, we try
2048 the default value and parent. */
2049 val
= current_default
;
2052 array
= XCHAR_TABLE (array
)->parent
;
2054 goto try_parent_char_table
;
2062 if (VECTORP (array
))
2063 size
= XVECTOR (array
)->size
;
2064 else if (COMPILEDP (array
))
2065 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2067 wrong_type_argument (Qarrayp
, array
);
2069 if (idxval
< 0 || idxval
>= size
)
2070 args_out_of_range (array
, idx
);
2071 return XVECTOR (array
)->contents
[idxval
];
2075 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2076 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2077 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2078 bool-vector. IDX starts at 0. */)
2079 (array
, idx
, newelt
)
2080 register Lisp_Object array
;
2081 Lisp_Object idx
, newelt
;
2083 register int idxval
;
2086 idxval
= XINT (idx
);
2087 CHECK_ARRAY (array
, Qarrayp
);
2088 CHECK_IMPURE (array
);
2090 if (VECTORP (array
))
2092 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2093 args_out_of_range (array
, idx
);
2094 XVECTOR (array
)->contents
[idxval
] = newelt
;
2096 else if (BOOL_VECTOR_P (array
))
2100 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2101 args_out_of_range (array
, idx
);
2103 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2105 if (! NILP (newelt
))
2106 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2108 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2109 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2111 else if (CHAR_TABLE_P (array
))
2114 args_out_of_range (array
, idx
);
2115 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2117 if (! SINGLE_BYTE_CHAR_P (idxval
))
2118 args_out_of_range (array
, idx
);
2119 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2126 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2127 if (code
[1] < 32) code
[1] = -1;
2128 else if (code
[2] < 32) code
[2] = -1;
2130 /* See the comment of the corresponding part in Faref. */
2132 code
[3] = -1; /* anchor */
2133 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2135 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2136 if (SUB_CHAR_TABLE_P (val
))
2142 /* VAL is a leaf. Create a sub char table with the
2143 initial value VAL and look into it. */
2145 temp
= make_sub_char_table (val
);
2146 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2150 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2153 else if (STRING_MULTIBYTE (array
))
2155 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2156 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2158 if (idxval
< 0 || idxval
>= SCHARS (array
))
2159 args_out_of_range (array
, idx
);
2160 CHECK_NUMBER (newelt
);
2162 nbytes
= SBYTES (array
);
2164 idxval_byte
= string_char_to_byte (array
, idxval
);
2165 p1
= SDATA (array
) + idxval_byte
;
2166 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2167 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2168 if (prev_bytes
!= new_bytes
)
2170 /* We must relocate the string data. */
2171 int nchars
= SCHARS (array
);
2175 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2176 bcopy (SDATA (array
), str
, nbytes
);
2177 allocate_string_data (XSTRING (array
), nchars
,
2178 nbytes
+ new_bytes
- prev_bytes
);
2179 bcopy (str
, SDATA (array
), idxval_byte
);
2180 p1
= SDATA (array
) + idxval_byte
;
2181 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2182 nbytes
- (idxval_byte
+ prev_bytes
));
2184 clear_string_char_byte_cache ();
2191 if (idxval
< 0 || idxval
>= SCHARS (array
))
2192 args_out_of_range (array
, idx
);
2193 CHECK_NUMBER (newelt
);
2195 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2196 SSET (array
, idxval
, XINT (newelt
));
2199 /* We must relocate the string data while converting it to
2201 int idxval_byte
, prev_bytes
, new_bytes
;
2202 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2203 unsigned char *origstr
= SDATA (array
), *str
;
2207 nchars
= SCHARS (array
);
2208 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2209 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2211 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2212 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2213 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2215 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2216 allocate_string_data (XSTRING (array
), nchars
,
2217 nbytes
+ new_bytes
- prev_bytes
);
2218 bcopy (str
, SDATA (array
), idxval_byte
);
2219 p1
= SDATA (array
) + idxval_byte
;
2222 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2223 nbytes
- (idxval_byte
+ prev_bytes
));
2225 clear_string_char_byte_cache ();
2232 /* Arithmetic functions */
2234 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2237 arithcompare (num1
, num2
, comparison
)
2238 Lisp_Object num1
, num2
;
2239 enum comparison comparison
;
2241 double f1
= 0, f2
= 0;
2244 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2245 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2247 if (FLOATP (num1
) || FLOATP (num2
))
2250 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2251 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2257 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2262 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2267 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2272 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2277 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2282 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2291 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2292 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2294 register Lisp_Object num1
, num2
;
2296 return arithcompare (num1
, num2
, equal
);
2299 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2300 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2302 register Lisp_Object num1
, num2
;
2304 return arithcompare (num1
, num2
, less
);
2307 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2308 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2310 register Lisp_Object num1
, num2
;
2312 return arithcompare (num1
, num2
, grtr
);
2315 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2316 doc
: /* Return t if first arg is less than or equal to second arg.
2317 Both must be numbers or markers. */)
2319 register Lisp_Object num1
, num2
;
2321 return arithcompare (num1
, num2
, less_or_equal
);
2324 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2325 doc
: /* Return t if first arg is greater than or equal to second arg.
2326 Both must be numbers or markers. */)
2328 register Lisp_Object num1
, num2
;
2330 return arithcompare (num1
, num2
, grtr_or_equal
);
2333 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2334 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2336 register Lisp_Object num1
, num2
;
2338 return arithcompare (num1
, num2
, notequal
);
2341 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2342 doc
: /* Return t if NUMBER is zero. */)
2344 register Lisp_Object number
;
2346 CHECK_NUMBER_OR_FLOAT (number
);
2348 if (FLOATP (number
))
2350 if (XFLOAT_DATA (number
) == 0.0)
2360 /* Convert between long values and pairs of Lisp integers.
2361 Note that long_to_cons returns a single Lisp integer
2362 when the value fits in one. */
2368 unsigned long top
= i
>> 16;
2369 unsigned int bot
= i
& 0xFFFF;
2371 return make_number (bot
);
2372 if (top
== (unsigned long)-1 >> 16)
2373 return Fcons (make_number (-1), make_number (bot
));
2374 return Fcons (make_number (top
), make_number (bot
));
2381 Lisp_Object top
, bot
;
2388 return ((XINT (top
) << 16) | XINT (bot
));
2391 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2392 doc
: /* Return the decimal representation of NUMBER as a string.
2393 Uses a minus sign if negative.
2394 NUMBER may be an integer or a floating point number. */)
2398 char buffer
[VALBITS
];
2400 CHECK_NUMBER_OR_FLOAT (number
);
2402 if (FLOATP (number
))
2404 char pigbuf
[350]; /* see comments in float_to_string */
2406 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2407 return build_string (pigbuf
);
2410 if (sizeof (int) == sizeof (EMACS_INT
))
2411 sprintf (buffer
, "%d", XINT (number
));
2412 else if (sizeof (long) == sizeof (EMACS_INT
))
2413 sprintf (buffer
, "%ld", (long) XINT (number
));
2416 return build_string (buffer
);
2420 digit_to_number (character
, base
)
2421 int character
, base
;
2425 if (character
>= '0' && character
<= '9')
2426 digit
= character
- '0';
2427 else if (character
>= 'a' && character
<= 'z')
2428 digit
= character
- 'a' + 10;
2429 else if (character
>= 'A' && character
<= 'Z')
2430 digit
= character
- 'A' + 10;
2440 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2441 doc
: /* Parse STRING as a decimal number and return the number.
2442 This parses both integers and floating point numbers.
2443 It ignores leading spaces and tabs.
2445 If BASE, interpret STRING as a number in that base. If BASE isn't
2446 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2447 If the base used is not 10, floating point is not recognized. */)
2449 register Lisp_Object string
, base
;
2451 register unsigned char *p
;
2456 CHECK_STRING (string
);
2462 CHECK_NUMBER (base
);
2464 if (b
< 2 || b
> 16)
2465 xsignal1 (Qargs_out_of_range
, base
);
2468 /* Skip any whitespace at the front of the number. Some versions of
2469 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2471 while (*p
== ' ' || *p
== '\t')
2482 if (isfloat_string (p
) && b
== 10)
2483 val
= make_float (sign
* atof (p
));
2490 int digit
= digit_to_number (*p
++, b
);
2496 val
= make_fixnum_or_float (sign
* v
);
2516 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2517 int, Lisp_Object
*));
2518 extern Lisp_Object
fmod_float ();
2521 arith_driver (code
, nargs
, args
)
2524 register Lisp_Object
*args
;
2526 register Lisp_Object val
;
2527 register int argnum
;
2528 register EMACS_INT accum
= 0;
2529 register EMACS_INT next
;
2531 switch (SWITCH_ENUM_CAST (code
))
2549 for (argnum
= 0; argnum
< nargs
; argnum
++)
2551 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2553 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2556 return float_arith_driver ((double) accum
, argnum
, code
,
2559 next
= XINT (args
[argnum
]);
2560 switch (SWITCH_ENUM_CAST (code
))
2566 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2577 xsignal0 (Qarith_error
);
2591 if (!argnum
|| next
> accum
)
2595 if (!argnum
|| next
< accum
)
2601 XSETINT (val
, accum
);
2606 #define isnan(x) ((x) != (x))
2609 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2611 register int argnum
;
2614 register Lisp_Object
*args
;
2616 register Lisp_Object val
;
2619 for (; argnum
< nargs
; argnum
++)
2621 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2622 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2626 next
= XFLOAT_DATA (val
);
2630 args
[argnum
] = val
; /* runs into a compiler bug. */
2631 next
= XINT (args
[argnum
]);
2633 switch (SWITCH_ENUM_CAST (code
))
2639 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2649 if (! IEEE_FLOATING_POINT
&& next
== 0)
2650 xsignal0 (Qarith_error
);
2657 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2659 if (!argnum
|| isnan (next
) || next
> accum
)
2663 if (!argnum
|| isnan (next
) || next
< accum
)
2669 return make_float (accum
);
2673 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2674 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2675 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2680 return arith_driver (Aadd
, nargs
, args
);
2683 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2684 doc
: /* Negate number or subtract numbers or markers and return the result.
2685 With one arg, negates it. With more than one arg,
2686 subtracts all but the first from the first.
2687 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2692 return arith_driver (Asub
, nargs
, args
);
2695 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2696 doc
: /* Return product of any number of arguments, which are numbers or markers.
2697 usage: (* &rest NUMBERS-OR-MARKERS) */)
2702 return arith_driver (Amult
, nargs
, args
);
2705 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2706 doc
: /* Return first argument divided by all the remaining arguments.
2707 The arguments must be numbers or markers.
2708 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2714 for (argnum
= 2; argnum
< nargs
; argnum
++)
2715 if (FLOATP (args
[argnum
]))
2716 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2717 return arith_driver (Adiv
, nargs
, args
);
2720 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2721 doc
: /* Return remainder of X divided by Y.
2722 Both must be integers or markers. */)
2724 register Lisp_Object x
, y
;
2728 CHECK_NUMBER_COERCE_MARKER (x
);
2729 CHECK_NUMBER_COERCE_MARKER (y
);
2731 if (XFASTINT (y
) == 0)
2732 xsignal0 (Qarith_error
);
2734 XSETINT (val
, XINT (x
) % XINT (y
));
2748 /* If the magnitude of the result exceeds that of the divisor, or
2749 the sign of the result does not agree with that of the dividend,
2750 iterate with the reduced value. This does not yield a
2751 particularly accurate result, but at least it will be in the
2752 range promised by fmod. */
2754 r
-= f2
* floor (r
/ f2
);
2755 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2759 #endif /* ! HAVE_FMOD */
2761 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2762 doc
: /* Return X modulo Y.
2763 The result falls between zero (inclusive) and Y (exclusive).
2764 Both X and Y must be numbers or markers. */)
2766 register Lisp_Object x
, y
;
2771 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2772 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2774 if (FLOATP (x
) || FLOATP (y
))
2775 return fmod_float (x
, y
);
2781 xsignal0 (Qarith_error
);
2785 /* If the "remainder" comes out with the wrong sign, fix it. */
2786 if (i2
< 0 ? i1
> 0 : i1
< 0)
2793 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2794 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2795 The value is always a number; markers are converted to numbers.
2796 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2801 return arith_driver (Amax
, nargs
, args
);
2804 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2805 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2806 The value is always a number; markers are converted to numbers.
2807 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2812 return arith_driver (Amin
, nargs
, args
);
2815 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2816 doc
: /* Return bitwise-and of all the arguments.
2817 Arguments may be integers, or markers converted to integers.
2818 usage: (logand &rest INTS-OR-MARKERS) */)
2823 return arith_driver (Alogand
, nargs
, args
);
2826 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2827 doc
: /* Return bitwise-or of all the arguments.
2828 Arguments may be integers, or markers converted to integers.
2829 usage: (logior &rest INTS-OR-MARKERS) */)
2834 return arith_driver (Alogior
, nargs
, args
);
2837 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2838 doc
: /* Return bitwise-exclusive-or of all the arguments.
2839 Arguments may be integers, or markers converted to integers.
2840 usage: (logxor &rest INTS-OR-MARKERS) */)
2845 return arith_driver (Alogxor
, nargs
, args
);
2848 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2849 doc
: /* Return VALUE with its bits shifted left by COUNT.
2850 If COUNT is negative, shifting is actually to the right.
2851 In this case, the sign bit is duplicated. */)
2853 register Lisp_Object value
, count
;
2855 register Lisp_Object val
;
2857 CHECK_NUMBER (value
);
2858 CHECK_NUMBER (count
);
2860 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2862 else if (XINT (count
) > 0)
2863 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2864 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2865 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2867 XSETINT (val
, XINT (value
) >> -XINT (count
));
2871 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2872 doc
: /* Return VALUE with its bits shifted left by COUNT.
2873 If COUNT is negative, shifting is actually to the right.
2874 In this case, zeros are shifted in on the left. */)
2876 register Lisp_Object value
, count
;
2878 register Lisp_Object val
;
2880 CHECK_NUMBER (value
);
2881 CHECK_NUMBER (count
);
2883 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2885 else if (XINT (count
) > 0)
2886 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2887 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2890 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2894 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2895 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2896 Markers are converted to integers. */)
2898 register Lisp_Object number
;
2900 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2902 if (FLOATP (number
))
2903 return (make_float (1.0 + XFLOAT_DATA (number
)));
2905 XSETINT (number
, XINT (number
) + 1);
2909 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2910 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2911 Markers are converted to integers. */)
2913 register Lisp_Object number
;
2915 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2917 if (FLOATP (number
))
2918 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2920 XSETINT (number
, XINT (number
) - 1);
2924 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2925 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2927 register Lisp_Object number
;
2929 CHECK_NUMBER (number
);
2930 XSETINT (number
, ~XINT (number
));
2934 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2935 doc
: /* Return the byteorder for the machine.
2936 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2937 lowercase l) for small endian machines. */)
2940 unsigned i
= 0x04030201;
2941 int order
= *(char *)&i
== 1 ? 108 : 66;
2943 return make_number (order
);
2951 Lisp_Object error_tail
, arith_tail
;
2953 Qquote
= intern ("quote");
2954 Qlambda
= intern ("lambda");
2955 Qsubr
= intern ("subr");
2956 Qerror_conditions
= intern ("error-conditions");
2957 Qerror_message
= intern ("error-message");
2958 Qtop_level
= intern ("top-level");
2960 Qerror
= intern ("error");
2961 Qquit
= intern ("quit");
2962 Qwrong_type_argument
= intern ("wrong-type-argument");
2963 Qargs_out_of_range
= intern ("args-out-of-range");
2964 Qvoid_function
= intern ("void-function");
2965 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2966 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2967 Qvoid_variable
= intern ("void-variable");
2968 Qsetting_constant
= intern ("setting-constant");
2969 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2971 Qinvalid_function
= intern ("invalid-function");
2972 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2973 Qno_catch
= intern ("no-catch");
2974 Qend_of_file
= intern ("end-of-file");
2975 Qarith_error
= intern ("arith-error");
2976 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2977 Qend_of_buffer
= intern ("end-of-buffer");
2978 Qbuffer_read_only
= intern ("buffer-read-only");
2979 Qtext_read_only
= intern ("text-read-only");
2980 Qmark_inactive
= intern ("mark-inactive");
2982 Qlistp
= intern ("listp");
2983 Qconsp
= intern ("consp");
2984 Qsymbolp
= intern ("symbolp");
2985 Qkeywordp
= intern ("keywordp");
2986 Qintegerp
= intern ("integerp");
2987 Qnatnump
= intern ("natnump");
2988 Qwholenump
= intern ("wholenump");
2989 Qstringp
= intern ("stringp");
2990 Qarrayp
= intern ("arrayp");
2991 Qsequencep
= intern ("sequencep");
2992 Qbufferp
= intern ("bufferp");
2993 Qvectorp
= intern ("vectorp");
2994 Qchar_or_string_p
= intern ("char-or-string-p");
2995 Qmarkerp
= intern ("markerp");
2996 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2997 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2998 Qboundp
= intern ("boundp");
2999 Qfboundp
= intern ("fboundp");
3001 Qfloatp
= intern ("floatp");
3002 Qnumberp
= intern ("numberp");
3003 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3005 Qchar_table_p
= intern ("char-table-p");
3006 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3008 Qsubrp
= intern ("subrp");
3009 Qunevalled
= intern ("unevalled");
3010 Qmany
= intern ("many");
3012 Qcdr
= intern ("cdr");
3014 /* Handle automatic advice activation */
3015 Qad_advice_info
= intern ("ad-advice-info");
3016 Qad_activate_internal
= intern ("ad-activate-internal");
3018 error_tail
= Fcons (Qerror
, Qnil
);
3020 /* ERROR is used as a signaler for random errors for which nothing else is right */
3022 Fput (Qerror
, Qerror_conditions
,
3024 Fput (Qerror
, Qerror_message
,
3025 build_string ("error"));
3027 Fput (Qquit
, Qerror_conditions
,
3028 Fcons (Qquit
, Qnil
));
3029 Fput (Qquit
, Qerror_message
,
3030 build_string ("Quit"));
3032 Fput (Qwrong_type_argument
, Qerror_conditions
,
3033 Fcons (Qwrong_type_argument
, error_tail
));
3034 Fput (Qwrong_type_argument
, Qerror_message
,
3035 build_string ("Wrong type argument"));
3037 Fput (Qargs_out_of_range
, Qerror_conditions
,
3038 Fcons (Qargs_out_of_range
, error_tail
));
3039 Fput (Qargs_out_of_range
, Qerror_message
,
3040 build_string ("Args out of range"));
3042 Fput (Qvoid_function
, Qerror_conditions
,
3043 Fcons (Qvoid_function
, error_tail
));
3044 Fput (Qvoid_function
, Qerror_message
,
3045 build_string ("Symbol's function definition is void"));
3047 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3048 Fcons (Qcyclic_function_indirection
, error_tail
));
3049 Fput (Qcyclic_function_indirection
, Qerror_message
,
3050 build_string ("Symbol's chain of function indirections contains a loop"));
3052 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3053 Fcons (Qcyclic_variable_indirection
, error_tail
));
3054 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3055 build_string ("Symbol's chain of variable indirections contains a loop"));
3057 Qcircular_list
= intern ("circular-list");
3058 staticpro (&Qcircular_list
);
3059 Fput (Qcircular_list
, Qerror_conditions
,
3060 Fcons (Qcircular_list
, error_tail
));
3061 Fput (Qcircular_list
, Qerror_message
,
3062 build_string ("List contains a loop"));
3064 Fput (Qvoid_variable
, Qerror_conditions
,
3065 Fcons (Qvoid_variable
, error_tail
));
3066 Fput (Qvoid_variable
, Qerror_message
,
3067 build_string ("Symbol's value as variable is void"));
3069 Fput (Qsetting_constant
, Qerror_conditions
,
3070 Fcons (Qsetting_constant
, error_tail
));
3071 Fput (Qsetting_constant
, Qerror_message
,
3072 build_string ("Attempt to set a constant symbol"));
3074 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3075 Fcons (Qinvalid_read_syntax
, error_tail
));
3076 Fput (Qinvalid_read_syntax
, Qerror_message
,
3077 build_string ("Invalid read syntax"));
3079 Fput (Qinvalid_function
, Qerror_conditions
,
3080 Fcons (Qinvalid_function
, error_tail
));
3081 Fput (Qinvalid_function
, Qerror_message
,
3082 build_string ("Invalid function"));
3084 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3085 Fcons (Qwrong_number_of_arguments
, error_tail
));
3086 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3087 build_string ("Wrong number of arguments"));
3089 Fput (Qno_catch
, Qerror_conditions
,
3090 Fcons (Qno_catch
, error_tail
));
3091 Fput (Qno_catch
, Qerror_message
,
3092 build_string ("No catch for tag"));
3094 Fput (Qend_of_file
, Qerror_conditions
,
3095 Fcons (Qend_of_file
, error_tail
));
3096 Fput (Qend_of_file
, Qerror_message
,
3097 build_string ("End of file during parsing"));
3099 arith_tail
= Fcons (Qarith_error
, error_tail
);
3100 Fput (Qarith_error
, Qerror_conditions
,
3102 Fput (Qarith_error
, Qerror_message
,
3103 build_string ("Arithmetic error"));
3105 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3106 Fcons (Qbeginning_of_buffer
, error_tail
));
3107 Fput (Qbeginning_of_buffer
, Qerror_message
,
3108 build_string ("Beginning of buffer"));
3110 Fput (Qend_of_buffer
, Qerror_conditions
,
3111 Fcons (Qend_of_buffer
, error_tail
));
3112 Fput (Qend_of_buffer
, Qerror_message
,
3113 build_string ("End of buffer"));
3115 Fput (Qbuffer_read_only
, Qerror_conditions
,
3116 Fcons (Qbuffer_read_only
, error_tail
));
3117 Fput (Qbuffer_read_only
, Qerror_message
,
3118 build_string ("Buffer is read-only"));
3120 Fput (Qtext_read_only
, Qerror_conditions
,
3121 Fcons (Qtext_read_only
, error_tail
));
3122 Fput (Qtext_read_only
, Qerror_message
,
3123 build_string ("Text is read-only"));
3125 Qrange_error
= intern ("range-error");
3126 Qdomain_error
= intern ("domain-error");
3127 Qsingularity_error
= intern ("singularity-error");
3128 Qoverflow_error
= intern ("overflow-error");
3129 Qunderflow_error
= intern ("underflow-error");
3131 Fput (Qdomain_error
, Qerror_conditions
,
3132 Fcons (Qdomain_error
, arith_tail
));
3133 Fput (Qdomain_error
, Qerror_message
,
3134 build_string ("Arithmetic domain error"));
3136 Fput (Qrange_error
, Qerror_conditions
,
3137 Fcons (Qrange_error
, arith_tail
));
3138 Fput (Qrange_error
, Qerror_message
,
3139 build_string ("Arithmetic range error"));
3141 Fput (Qsingularity_error
, Qerror_conditions
,
3142 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3143 Fput (Qsingularity_error
, Qerror_message
,
3144 build_string ("Arithmetic singularity error"));
3146 Fput (Qoverflow_error
, Qerror_conditions
,
3147 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3148 Fput (Qoverflow_error
, Qerror_message
,
3149 build_string ("Arithmetic overflow error"));
3151 Fput (Qunderflow_error
, Qerror_conditions
,
3152 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3153 Fput (Qunderflow_error
, Qerror_message
,
3154 build_string ("Arithmetic underflow error"));
3156 staticpro (&Qrange_error
);
3157 staticpro (&Qdomain_error
);
3158 staticpro (&Qsingularity_error
);
3159 staticpro (&Qoverflow_error
);
3160 staticpro (&Qunderflow_error
);
3164 staticpro (&Qquote
);
3165 staticpro (&Qlambda
);
3167 staticpro (&Qunbound
);
3168 staticpro (&Qerror_conditions
);
3169 staticpro (&Qerror_message
);
3170 staticpro (&Qtop_level
);
3172 staticpro (&Qerror
);
3174 staticpro (&Qwrong_type_argument
);
3175 staticpro (&Qargs_out_of_range
);
3176 staticpro (&Qvoid_function
);
3177 staticpro (&Qcyclic_function_indirection
);
3178 staticpro (&Qcyclic_variable_indirection
);
3179 staticpro (&Qvoid_variable
);
3180 staticpro (&Qsetting_constant
);
3181 staticpro (&Qinvalid_read_syntax
);
3182 staticpro (&Qwrong_number_of_arguments
);
3183 staticpro (&Qinvalid_function
);
3184 staticpro (&Qno_catch
);
3185 staticpro (&Qend_of_file
);
3186 staticpro (&Qarith_error
);
3187 staticpro (&Qbeginning_of_buffer
);
3188 staticpro (&Qend_of_buffer
);
3189 staticpro (&Qbuffer_read_only
);
3190 staticpro (&Qtext_read_only
);
3191 staticpro (&Qmark_inactive
);
3193 staticpro (&Qlistp
);
3194 staticpro (&Qconsp
);
3195 staticpro (&Qsymbolp
);
3196 staticpro (&Qkeywordp
);
3197 staticpro (&Qintegerp
);
3198 staticpro (&Qnatnump
);
3199 staticpro (&Qwholenump
);
3200 staticpro (&Qstringp
);
3201 staticpro (&Qarrayp
);
3202 staticpro (&Qsequencep
);
3203 staticpro (&Qbufferp
);
3204 staticpro (&Qvectorp
);
3205 staticpro (&Qchar_or_string_p
);
3206 staticpro (&Qmarkerp
);
3207 staticpro (&Qbuffer_or_string_p
);
3208 staticpro (&Qinteger_or_marker_p
);
3209 staticpro (&Qfloatp
);
3210 staticpro (&Qnumberp
);
3211 staticpro (&Qnumber_or_marker_p
);
3212 staticpro (&Qchar_table_p
);
3213 staticpro (&Qvector_or_char_table_p
);
3214 staticpro (&Qsubrp
);
3216 staticpro (&Qunevalled
);
3218 staticpro (&Qboundp
);
3219 staticpro (&Qfboundp
);
3221 staticpro (&Qad_advice_info
);
3222 staticpro (&Qad_activate_internal
);
3224 /* Types that type-of returns. */
3225 Qinteger
= intern ("integer");
3226 Qsymbol
= intern ("symbol");
3227 Qstring
= intern ("string");
3228 Qcons
= intern ("cons");
3229 Qmarker
= intern ("marker");
3230 Qoverlay
= intern ("overlay");
3231 Qfloat
= intern ("float");
3232 Qwindow_configuration
= intern ("window-configuration");
3233 Qprocess
= intern ("process");
3234 Qwindow
= intern ("window");
3235 /* Qsubr = intern ("subr"); */
3236 Qcompiled_function
= intern ("compiled-function");
3237 Qbuffer
= intern ("buffer");
3238 Qframe
= intern ("frame");
3239 Qvector
= intern ("vector");
3240 Qchar_table
= intern ("char-table");
3241 Qbool_vector
= intern ("bool-vector");
3242 Qhash_table
= intern ("hash-table");
3244 staticpro (&Qinteger
);
3245 staticpro (&Qsymbol
);
3246 staticpro (&Qstring
);
3248 staticpro (&Qmarker
);
3249 staticpro (&Qoverlay
);
3250 staticpro (&Qfloat
);
3251 staticpro (&Qwindow_configuration
);
3252 staticpro (&Qprocess
);
3253 staticpro (&Qwindow
);
3254 /* staticpro (&Qsubr); */
3255 staticpro (&Qcompiled_function
);
3256 staticpro (&Qbuffer
);
3257 staticpro (&Qframe
);
3258 staticpro (&Qvector
);
3259 staticpro (&Qchar_table
);
3260 staticpro (&Qbool_vector
);
3261 staticpro (&Qhash_table
);
3263 defsubr (&Sindirect_variable
);
3264 defsubr (&Sinteractive_form
);
3267 defsubr (&Stype_of
);
3272 defsubr (&Sintegerp
);
3273 defsubr (&Sinteger_or_marker_p
);
3274 defsubr (&Snumberp
);
3275 defsubr (&Snumber_or_marker_p
);
3277 defsubr (&Snatnump
);
3278 defsubr (&Ssymbolp
);
3279 defsubr (&Skeywordp
);
3280 defsubr (&Sstringp
);
3281 defsubr (&Smultibyte_string_p
);
3282 defsubr (&Svectorp
);
3283 defsubr (&Schar_table_p
);
3284 defsubr (&Svector_or_char_table_p
);
3285 defsubr (&Sbool_vector_p
);
3287 defsubr (&Ssequencep
);
3288 defsubr (&Sbufferp
);
3289 defsubr (&Smarkerp
);
3291 defsubr (&Sbyte_code_function_p
);
3292 defsubr (&Schar_or_string_p
);
3295 defsubr (&Scar_safe
);
3296 defsubr (&Scdr_safe
);
3299 defsubr (&Ssymbol_function
);
3300 defsubr (&Sindirect_function
);
3301 defsubr (&Ssymbol_plist
);
3302 defsubr (&Ssymbol_name
);
3303 defsubr (&Smakunbound
);
3304 defsubr (&Sfmakunbound
);
3306 defsubr (&Sfboundp
);
3308 defsubr (&Sdefalias
);
3309 defsubr (&Ssetplist
);
3310 defsubr (&Ssymbol_value
);
3312 defsubr (&Sdefault_boundp
);
3313 defsubr (&Sdefault_value
);
3314 defsubr (&Sset_default
);
3315 defsubr (&Ssetq_default
);
3316 defsubr (&Smake_variable_buffer_local
);
3317 defsubr (&Smake_local_variable
);
3318 defsubr (&Skill_local_variable
);
3319 defsubr (&Smake_variable_frame_local
);
3320 defsubr (&Slocal_variable_p
);
3321 defsubr (&Slocal_variable_if_set_p
);
3322 defsubr (&Svariable_binding_locus
);
3325 defsubr (&Snumber_to_string
);
3326 defsubr (&Sstring_to_number
);
3327 defsubr (&Seqlsign
);
3350 defsubr (&Sbyteorder
);
3351 defsubr (&Ssubr_arity
);
3352 defsubr (&Ssubr_name
);
3354 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3356 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3357 doc
: /* The largest value that is representable in a Lisp integer. */);
3358 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3360 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3361 doc
: /* The smallest value that is representable in a Lisp integer. */);
3362 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3369 #if defined(USG) && !defined(POSIX_SIGNALS)
3370 /* USG systems forget handlers when they are used;
3371 must reestablish each time */
3372 signal (signo
, arith_error
);
3375 /* VMS systems are like USG. */
3376 signal (signo
, arith_error
);
3380 #else /* not BSD4_1 */
3381 sigsetmask (SIGEMPTYMASK
);
3382 #endif /* not BSD4_1 */
3384 SIGNAL_THREAD_CHECK (signo
);
3385 xsignal0 (Qarith_error
);
3391 /* Don't do this if just dumping out.
3392 We don't want to call `signal' in this case
3393 so that we don't have trouble with dumping
3394 signal-delivering routines in an inconsistent state. */
3398 #endif /* CANNOT_DUMP */
3399 signal (SIGFPE
, arith_error
);
3402 signal (SIGEMT
, arith_error
);
3406 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3407 (do not change this comment) */