1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99, 2000, 2001, 03, 2004
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, 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 Fsignal (Qcircular_list
, list
);
113 wrong_type_argument (predicate
, value
)
114 register Lisp_Object predicate
, value
;
116 register Lisp_Object tem
;
119 /* If VALUE is not even a valid Lisp object, abort here
120 where we can get a backtrace showing where it came from. */
121 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
124 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
125 tem
= call1 (predicate
, value
);
134 error ("Attempt to modify read-only object");
138 args_out_of_range (a1
, a2
)
142 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
146 args_out_of_range_3 (a1
, a2
, a3
)
147 Lisp_Object a1
, a2
, a3
;
150 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
153 /* On some machines, XINT needs a temporary location.
154 Here it is, in case it is needed. */
156 int sign_extend_temp
;
158 /* On a few machines, XINT can only be done by calling this. */
161 sign_extend_lisp_int (num
)
164 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
165 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
167 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
170 /* Data type predicates */
172 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
173 doc
: /* Return t if the two args are the same Lisp object. */)
175 Lisp_Object obj1
, obj2
;
182 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
183 doc
: /* Return t if OBJECT is nil. */)
192 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
193 doc
: /* Return a symbol representing the type of OBJECT.
194 The symbol returned names the object's basic type;
195 for example, (type-of 1) returns `integer'. */)
199 switch (XGCTYPE (object
))
214 switch (XMISCTYPE (object
))
216 case Lisp_Misc_Marker
:
218 case Lisp_Misc_Overlay
:
220 case Lisp_Misc_Float
:
225 case Lisp_Vectorlike
:
226 if (GC_WINDOW_CONFIGURATIONP (object
))
227 return Qwindow_configuration
;
228 if (GC_PROCESSP (object
))
230 if (GC_WINDOWP (object
))
232 if (GC_SUBRP (object
))
234 if (GC_COMPILEDP (object
))
235 return Qcompiled_function
;
236 if (GC_BUFFERP (object
))
238 if (GC_CHAR_TABLE_P (object
))
240 if (GC_BOOL_VECTOR_P (object
))
242 if (GC_FRAMEP (object
))
244 if (GC_HASH_TABLE_P (object
))
256 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
257 doc
: /* Return t if OBJECT is a cons cell. */)
266 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
267 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
276 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
277 doc
: /* Return t if OBJECT is a list. This includes nil. */)
281 if (CONSP (object
) || NILP (object
))
286 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
287 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
291 if (CONSP (object
) || NILP (object
))
296 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
297 doc
: /* Return t if OBJECT is a symbol. */)
301 if (SYMBOLP (object
))
306 /* Define this in C to avoid unnecessarily consing up the symbol
308 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
309 doc
: /* Return t if OBJECT is a keyword.
310 This means that it is a symbol with a print name beginning with `:'
311 interned in the initial obarray. */)
316 && SREF (SYMBOL_NAME (object
), 0) == ':'
317 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
322 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
323 doc
: /* Return t if OBJECT is a vector. */)
327 if (VECTORP (object
))
332 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
333 doc
: /* Return t if OBJECT is a string. */)
337 if (STRINGP (object
))
342 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
344 doc
: /* Return t if OBJECT is a multibyte string. */)
348 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
353 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
354 doc
: /* Return t if OBJECT is a char-table. */)
358 if (CHAR_TABLE_P (object
))
363 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
364 Svector_or_char_table_p
, 1, 1, 0,
365 doc
: /* Return t if OBJECT is a char-table or vector. */)
369 if (VECTORP (object
) || CHAR_TABLE_P (object
))
374 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
375 doc
: /* Return t if OBJECT is a bool-vector. */)
379 if (BOOL_VECTOR_P (object
))
384 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
385 doc
: /* Return t if OBJECT is an array (string or vector). */)
389 if (VECTORP (object
) || STRINGP (object
)
390 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
395 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
396 doc
: /* Return t if OBJECT is a sequence (list or array). */)
398 register Lisp_Object object
;
400 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
401 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
406 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is an editor buffer. */)
411 if (BUFFERP (object
))
416 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
417 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
421 if (MARKERP (object
))
426 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
427 doc
: /* Return t if OBJECT is a built-in function. */)
436 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
438 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
442 if (COMPILEDP (object
))
447 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
448 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
450 register Lisp_Object object
;
452 if (INTEGERP (object
) || STRINGP (object
))
457 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
458 doc
: /* Return t if OBJECT is an integer. */)
462 if (INTEGERP (object
))
467 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
468 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
470 register Lisp_Object object
;
472 if (MARKERP (object
) || INTEGERP (object
))
477 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
478 doc
: /* Return t if OBJECT is a nonnegative integer. */)
482 if (NATNUMP (object
))
487 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
488 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
492 if (NUMBERP (object
))
498 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
499 Snumber_or_marker_p
, 1, 1, 0,
500 doc
: /* Return t if OBJECT is a number or a marker. */)
504 if (NUMBERP (object
) || MARKERP (object
))
509 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
510 doc
: /* Return t if OBJECT is a floating point number. */)
520 /* Extract and set components of lists */
522 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
523 doc
: /* Return the car of LIST. If arg is nil, return nil.
524 Error if arg is not nil and not a cons cell. See also `car-safe'. */)
526 register Lisp_Object list
;
532 else if (EQ (list
, Qnil
))
535 list
= wrong_type_argument (Qlistp
, list
);
539 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
540 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
545 return XCAR (object
);
550 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
551 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
552 Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
554 register Lisp_Object list
;
560 else if (EQ (list
, Qnil
))
563 list
= wrong_type_argument (Qlistp
, list
);
567 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
568 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
573 return XCDR (object
);
578 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
579 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
581 register Lisp_Object cell
, newcar
;
584 cell
= wrong_type_argument (Qconsp
, cell
);
587 XSETCAR (cell
, newcar
);
591 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
592 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
594 register Lisp_Object cell
, newcdr
;
597 cell
= wrong_type_argument (Qconsp
, cell
);
600 XSETCDR (cell
, newcdr
);
604 /* Extract and set components of symbols */
606 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
607 doc
: /* Return t if SYMBOL's value is not void. */)
609 register Lisp_Object symbol
;
611 Lisp_Object valcontents
;
612 CHECK_SYMBOL (symbol
);
614 valcontents
= SYMBOL_VALUE (symbol
);
616 if (BUFFER_LOCAL_VALUEP (valcontents
)
617 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
618 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
620 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
623 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
624 doc
: /* Return t if SYMBOL's function definition is not void. */)
626 register Lisp_Object symbol
;
628 CHECK_SYMBOL (symbol
);
629 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
632 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
633 doc
: /* Make SYMBOL's value be void.
636 register Lisp_Object symbol
;
638 CHECK_SYMBOL (symbol
);
639 if (XSYMBOL (symbol
)->constant
)
640 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
641 Fset (symbol
, Qunbound
);
645 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
646 doc
: /* Make SYMBOL's function definition be void.
649 register Lisp_Object symbol
;
651 CHECK_SYMBOL (symbol
);
652 if (NILP (symbol
) || EQ (symbol
, Qt
))
653 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
654 XSYMBOL (symbol
)->function
= Qunbound
;
658 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
659 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
661 register Lisp_Object symbol
;
663 CHECK_SYMBOL (symbol
);
664 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
665 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
666 return XSYMBOL (symbol
)->function
;
669 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
670 doc
: /* Return SYMBOL's property list. */)
672 register Lisp_Object symbol
;
674 CHECK_SYMBOL (symbol
);
675 return XSYMBOL (symbol
)->plist
;
678 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
679 doc
: /* Return SYMBOL's name, a string. */)
681 register Lisp_Object symbol
;
683 register Lisp_Object name
;
685 CHECK_SYMBOL (symbol
);
686 name
= SYMBOL_NAME (symbol
);
690 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
691 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
693 register Lisp_Object symbol
, definition
;
695 CHECK_SYMBOL (symbol
);
696 if (NILP (symbol
) || EQ (symbol
, Qt
))
697 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
698 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
699 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
701 XSYMBOL (symbol
)->function
= definition
;
702 /* Handle automatic advice activation */
703 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
705 call2 (Qad_activate_internal
, symbol
, Qnil
);
706 definition
= XSYMBOL (symbol
)->function
;
711 extern Lisp_Object Qfunction_documentation
;
713 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
714 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
715 Associates the function with the current load file, if any.
716 The optional third argument DOCSTRING specifies the documentation string
717 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
718 determined by DEFINITION. */)
719 (symbol
, definition
, docstring
)
720 register Lisp_Object symbol
, definition
, docstring
;
722 if (CONSP (XSYMBOL (symbol
)->function
)
723 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
724 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
725 definition
= Ffset (symbol
, definition
);
726 LOADHIST_ATTACH (symbol
);
727 if (!NILP (docstring
))
728 Fput (symbol
, Qfunction_documentation
, docstring
);
732 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
733 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
735 register Lisp_Object symbol
, newplist
;
737 CHECK_SYMBOL (symbol
);
738 XSYMBOL (symbol
)->plist
= newplist
;
742 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
743 doc
: /* Return minimum and maximum number of args allowed for SUBR.
744 SUBR must be a built-in function.
745 The returned value is a pair (MIN . MAX). MIN is the minimum number
746 of args. MAX is the maximum number or the symbol `many', for a
747 function with `&rest' args, or `unevalled' for a special form. */)
751 short minargs
, maxargs
;
753 wrong_type_argument (Qsubrp
, subr
);
754 minargs
= XSUBR (subr
)->min_args
;
755 maxargs
= XSUBR (subr
)->max_args
;
757 return Fcons (make_number (minargs
), Qmany
);
758 else if (maxargs
== UNEVALLED
)
759 return Fcons (make_number (minargs
), Qunevalled
);
761 return Fcons (make_number (minargs
), make_number (maxargs
));
764 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
765 doc
: /* Return name of subroutine SUBR.
766 SUBR must be a built-in function. */)
772 wrong_type_argument (Qsubrp
, subr
);
773 name
= XSUBR (subr
)->symbol_name
;
774 return make_string (name
, strlen (name
));
777 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
778 doc
: /* Return the interactive form of CMD or nil if none.
779 CMD must be a command. Value, if non-nil, is a list
780 \(interactive SPEC). */)
784 Lisp_Object fun
= indirect_function (cmd
);
788 if (XSUBR (fun
)->prompt
)
789 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
791 else if (COMPILEDP (fun
))
793 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
794 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
796 else if (CONSP (fun
))
798 Lisp_Object funcar
= XCAR (fun
);
799 if (EQ (funcar
, Qlambda
))
800 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
801 else if (EQ (funcar
, Qautoload
))
805 do_autoload (fun
, cmd
);
807 return Finteractive_form (cmd
);
814 /***********************************************************************
815 Getting and Setting Values of Symbols
816 ***********************************************************************/
818 /* Return the symbol holding SYMBOL's value. Signal
819 `cyclic-variable-indirection' if SYMBOL's chain of variable
820 indirections contains a loop. */
823 indirect_variable (symbol
)
826 Lisp_Object tortoise
, hare
;
828 hare
= tortoise
= symbol
;
830 while (XSYMBOL (hare
)->indirect_variable
)
832 hare
= XSYMBOL (hare
)->value
;
833 if (!XSYMBOL (hare
)->indirect_variable
)
836 hare
= XSYMBOL (hare
)->value
;
837 tortoise
= XSYMBOL (tortoise
)->value
;
839 if (EQ (hare
, tortoise
))
840 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
847 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
848 doc
: /* Return the variable at the end of OBJECT's variable chain.
849 If OBJECT is a symbol, follow all variable indirections and return the final
850 variable. If OBJECT is not a symbol, just return it.
851 Signal a cyclic-variable-indirection error if there is a loop in the
852 variable chain of symbols. */)
856 if (SYMBOLP (object
))
857 object
= indirect_variable (object
);
862 /* Given the raw contents of a symbol value cell,
863 return the Lisp value of the symbol.
864 This does not handle buffer-local variables; use
865 swap_in_symval_forwarding for that. */
868 do_symval_forwarding (valcontents
)
869 register Lisp_Object valcontents
;
871 register Lisp_Object val
;
873 if (MISCP (valcontents
))
874 switch (XMISCTYPE (valcontents
))
876 case Lisp_Misc_Intfwd
:
877 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
880 case Lisp_Misc_Boolfwd
:
881 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
883 case Lisp_Misc_Objfwd
:
884 return *XOBJFWD (valcontents
)->objvar
;
886 case Lisp_Misc_Buffer_Objfwd
:
887 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
888 return PER_BUFFER_VALUE (current_buffer
, offset
);
890 case Lisp_Misc_Kboard_Objfwd
:
891 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
892 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
897 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
898 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
899 buffer-independent contents of the value cell: forwarded just one
900 step past the buffer-localness.
902 BUF non-zero means set the value in buffer BUF instead of the
903 current buffer. This only plays a role for per-buffer variables. */
906 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
908 register Lisp_Object valcontents
, newval
;
913 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
916 switch (XMISCTYPE (valcontents
))
918 case Lisp_Misc_Intfwd
:
919 CHECK_NUMBER (newval
);
920 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
921 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
922 error ("Value out of range for variable `%s'",
923 SDATA (SYMBOL_NAME (symbol
)));
926 case Lisp_Misc_Boolfwd
:
927 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
930 case Lisp_Misc_Objfwd
:
931 *XOBJFWD (valcontents
)->objvar
= newval
;
933 /* If this variable is a default for something stored
934 in the buffer itself, such as default-fill-column,
935 find the buffers that don't have local values for it
937 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
938 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
940 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
941 - (char *) &buffer_defaults
);
942 int idx
= PER_BUFFER_IDX (offset
);
944 Lisp_Object tail
, buf
;
949 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
954 buf
= Fcdr (XCAR (tail
));
955 if (!BUFFERP (buf
)) continue;
958 if (! PER_BUFFER_VALUE_P (b
, idx
))
959 PER_BUFFER_VALUE (b
, offset
) = newval
;
964 case Lisp_Misc_Buffer_Objfwd
:
966 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
969 type
= PER_BUFFER_TYPE (offset
);
970 if (! NILP (type
) && ! NILP (newval
)
971 && XTYPE (newval
) != XINT (type
))
972 buffer_slot_type_mismatch (offset
);
975 buf
= current_buffer
;
976 PER_BUFFER_VALUE (buf
, offset
) = newval
;
980 case Lisp_Misc_Kboard_Objfwd
:
982 char *base
= (char *) current_kboard
;
983 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
984 *(Lisp_Object
*) p
= newval
;
995 valcontents
= SYMBOL_VALUE (symbol
);
996 if (BUFFER_LOCAL_VALUEP (valcontents
)
997 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
998 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1000 SET_SYMBOL_VALUE (symbol
, newval
);
1004 /* Set up SYMBOL to refer to its global binding.
1005 This makes it safe to alter the status of other bindings. */
1008 swap_in_global_binding (symbol
)
1011 Lisp_Object valcontents
, cdr
;
1013 valcontents
= SYMBOL_VALUE (symbol
);
1014 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1015 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1017 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1019 /* Unload the previously loaded binding. */
1020 Fsetcdr (XCAR (cdr
),
1021 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1023 /* Select the global binding in the symbol. */
1025 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1027 /* Indicate that the global binding is set up now. */
1028 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1029 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1030 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1031 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1034 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1035 VALCONTENTS is the contents of its value cell,
1036 which points to a struct Lisp_Buffer_Local_Value.
1038 Return the value forwarded one step past the buffer-local stage.
1039 This could be another forwarding pointer. */
1042 swap_in_symval_forwarding (symbol
, valcontents
)
1043 Lisp_Object symbol
, valcontents
;
1045 register Lisp_Object tem1
;
1047 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1050 || current_buffer
!= XBUFFER (tem1
)
1051 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1052 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1054 if (XSYMBOL (symbol
)->indirect_variable
)
1055 symbol
= indirect_variable (symbol
);
1057 /* Unload the previously loaded binding. */
1058 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1060 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1061 /* Choose the new binding. */
1062 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1063 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1064 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1067 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1068 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1070 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1072 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1075 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1077 /* Load the new binding. */
1078 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1079 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1080 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1081 store_symval_forwarding (symbol
,
1082 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1085 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1088 /* Find the value of a symbol, returning Qunbound if it's not bound.
1089 This is helpful for code which just wants to get a variable's value
1090 if it has one, without signaling an error.
1091 Note that it must not be possible to quit
1092 within this function. Great care is required for this. */
1095 find_symbol_value (symbol
)
1098 register Lisp_Object valcontents
;
1099 register Lisp_Object val
;
1101 CHECK_SYMBOL (symbol
);
1102 valcontents
= SYMBOL_VALUE (symbol
);
1104 if (BUFFER_LOCAL_VALUEP (valcontents
)
1105 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1106 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1108 if (MISCP (valcontents
))
1110 switch (XMISCTYPE (valcontents
))
1112 case Lisp_Misc_Intfwd
:
1113 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1116 case Lisp_Misc_Boolfwd
:
1117 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1119 case Lisp_Misc_Objfwd
:
1120 return *XOBJFWD (valcontents
)->objvar
;
1122 case Lisp_Misc_Buffer_Objfwd
:
1123 return PER_BUFFER_VALUE (current_buffer
,
1124 XBUFFER_OBJFWD (valcontents
)->offset
);
1126 case Lisp_Misc_Kboard_Objfwd
:
1127 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1128 + (char *)current_kboard
);
1135 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1136 doc
: /* Return SYMBOL's value. Error if that is void. */)
1142 val
= find_symbol_value (symbol
);
1143 if (EQ (val
, Qunbound
))
1144 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1149 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1150 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1152 register Lisp_Object symbol
, newval
;
1154 return set_internal (symbol
, newval
, current_buffer
, 0);
1157 /* Return 1 if SYMBOL currently has a let-binding
1158 which was made in the buffer that is now current. */
1161 let_shadows_buffer_binding_p (symbol
)
1164 volatile struct specbinding
*p
;
1166 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1168 && CONSP (p
->symbol
))
1170 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1171 if ((EQ (symbol
, let_bound_symbol
)
1172 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1173 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1174 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1178 return p
>= specpdl
;
1181 /* Store the value NEWVAL into SYMBOL.
1182 If buffer-locality is an issue, BUF specifies which buffer to use.
1183 (0 stands for the current buffer.)
1185 If BINDFLAG is zero, then if this symbol is supposed to become
1186 local in every buffer where it is set, then we make it local.
1187 If BINDFLAG is nonzero, we don't do that. */
1190 set_internal (symbol
, newval
, buf
, bindflag
)
1191 register Lisp_Object symbol
, newval
;
1195 int voide
= EQ (newval
, Qunbound
);
1197 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1200 buf
= current_buffer
;
1202 /* If restoring in a dead buffer, do nothing. */
1203 if (NILP (buf
->name
))
1206 CHECK_SYMBOL (symbol
);
1207 if (SYMBOL_CONSTANT_P (symbol
)
1208 && (NILP (Fkeywordp (symbol
))
1209 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1210 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1212 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1214 if (BUFFER_OBJFWDP (valcontents
))
1216 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1217 int idx
= PER_BUFFER_IDX (offset
);
1220 && !let_shadows_buffer_binding_p (symbol
))
1221 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1223 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1224 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1226 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1227 if (XSYMBOL (symbol
)->indirect_variable
)
1228 symbol
= indirect_variable (symbol
);
1230 /* What binding is loaded right now? */
1231 current_alist_element
1232 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1234 /* If the current buffer is not the buffer whose binding is
1235 loaded, or if there may be frame-local bindings and the frame
1236 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1237 the default binding is loaded, the loaded binding may be the
1239 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1240 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1241 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1242 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1243 || (BUFFER_LOCAL_VALUEP (valcontents
)
1244 && EQ (XCAR (current_alist_element
),
1245 current_alist_element
)))
1247 /* The currently loaded binding is not necessarily valid.
1248 We need to unload it, and choose a new binding. */
1250 /* Write out `realvalue' to the old loaded binding. */
1251 Fsetcdr (current_alist_element
,
1252 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1254 /* Find the new binding. */
1255 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1256 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1257 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1261 /* This buffer still sees the default value. */
1263 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1264 or if this is `let' rather than `set',
1265 make CURRENT-ALIST-ELEMENT point to itself,
1266 indicating that we're seeing the default value.
1267 Likewise if the variable has been let-bound
1268 in the current buffer. */
1269 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1270 || let_shadows_buffer_binding_p (symbol
))
1272 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1274 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1275 tem1
= Fassq (symbol
,
1276 XFRAME (selected_frame
)->param_alist
);
1279 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1281 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1283 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1284 and we're not within a let that was made for this buffer,
1285 create a new buffer-local binding for the variable.
1286 That means, give this buffer a new assoc for a local value
1287 and load that binding. */
1290 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1291 buf
->local_var_alist
1292 = Fcons (tem1
, buf
->local_var_alist
);
1296 /* Record which binding is now loaded. */
1297 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1300 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1301 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1302 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1304 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1307 /* If storing void (making the symbol void), forward only through
1308 buffer-local indicator, not through Lisp_Objfwd, etc. */
1310 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1312 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1314 /* If we just set a variable whose current binding is frame-local,
1315 store the new value in the frame parameter too. */
1317 if (BUFFER_LOCAL_VALUEP (valcontents
)
1318 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1320 /* What binding is loaded right now? */
1321 current_alist_element
1322 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1324 /* If the current buffer is not the buffer whose binding is
1325 loaded, or if there may be frame-local bindings and the frame
1326 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1327 the default binding is loaded, the loaded binding may be the
1329 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1330 XSETCDR (current_alist_element
, newval
);
1336 /* Access or set a buffer-local symbol's default value. */
1338 /* Return the default value of SYMBOL, but don't check for voidness.
1339 Return Qunbound if it is void. */
1342 default_value (symbol
)
1345 register Lisp_Object valcontents
;
1347 CHECK_SYMBOL (symbol
);
1348 valcontents
= SYMBOL_VALUE (symbol
);
1350 /* For a built-in buffer-local variable, get the default value
1351 rather than letting do_symval_forwarding get the current value. */
1352 if (BUFFER_OBJFWDP (valcontents
))
1354 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1355 if (PER_BUFFER_IDX (offset
) != 0)
1356 return PER_BUFFER_DEFAULT (offset
);
1359 /* Handle user-created local variables. */
1360 if (BUFFER_LOCAL_VALUEP (valcontents
)
1361 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1363 /* If var is set up for a buffer that lacks a local value for it,
1364 the current value is nominally the default value.
1365 But the `realvalue' slot may be more up to date, since
1366 ordinary setq stores just that slot. So use that. */
1367 Lisp_Object current_alist_element
, alist_element_car
;
1368 current_alist_element
1369 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1370 alist_element_car
= XCAR (current_alist_element
);
1371 if (EQ (alist_element_car
, current_alist_element
))
1372 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1374 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1376 /* For other variables, get the current value. */
1377 return do_symval_forwarding (valcontents
);
1380 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1381 doc
: /* Return t if SYMBOL has a non-void default value.
1382 This is the value that is seen in buffers that do not have their own values
1383 for this variable. */)
1387 register Lisp_Object value
;
1389 value
= default_value (symbol
);
1390 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1393 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1394 doc
: /* Return SYMBOL's default value.
1395 This is the value that is seen in buffers that do not have their own values
1396 for this variable. The default value is meaningful for variables with
1397 local bindings in certain buffers. */)
1401 register Lisp_Object value
;
1403 value
= default_value (symbol
);
1404 if (EQ (value
, Qunbound
))
1405 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1409 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1410 doc
: /* Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.
1411 The default value is seen in buffers that do not have their own values
1412 for this variable. */)
1414 Lisp_Object symbol
, value
;
1416 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1418 CHECK_SYMBOL (symbol
);
1419 valcontents
= SYMBOL_VALUE (symbol
);
1421 /* Handle variables like case-fold-search that have special slots
1422 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1424 if (BUFFER_OBJFWDP (valcontents
))
1426 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1427 int idx
= PER_BUFFER_IDX (offset
);
1429 PER_BUFFER_DEFAULT (offset
) = value
;
1431 /* If this variable is not always local in all buffers,
1432 set it in the buffers that don't nominally have a local value. */
1437 for (b
= all_buffers
; b
; b
= b
->next
)
1438 if (!PER_BUFFER_VALUE_P (b
, idx
))
1439 PER_BUFFER_VALUE (b
, offset
) = value
;
1444 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1445 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1446 return Fset (symbol
, value
);
1448 /* Store new value into the DEFAULT-VALUE slot. */
1449 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1451 /* If the default binding is now loaded, set the REALVALUE slot too. */
1452 current_alist_element
1453 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1454 alist_element_buffer
= Fcar (current_alist_element
);
1455 if (EQ (alist_element_buffer
, current_alist_element
))
1456 store_symval_forwarding (symbol
,
1457 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1463 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1464 doc
: /* Set the default value of variable VAR to VALUE.
1465 VAR, the variable name, is literal (not evaluated);
1466 VALUE is an expression: it is evaluated and its value returned.
1467 The default value of a variable is seen in buffers
1468 that do not have their own values for the variable.
1470 More generally, you can use multiple variables and values, as in
1471 (setq-default VAR VALUE VAR VALUE...)
1472 This sets each VAR's default value to the corresponding VALUE.
1473 The VALUE for the Nth VAR can refer to the new default values
1475 usage: (setq-default VAR VALUE [VAR VALUE...]) */)
1479 register Lisp_Object args_left
;
1480 register Lisp_Object val
, symbol
;
1481 struct gcpro gcpro1
;
1491 val
= Feval (Fcar (Fcdr (args_left
)));
1492 symbol
= XCAR (args_left
);
1493 Fset_default (symbol
, val
);
1494 args_left
= Fcdr (XCDR (args_left
));
1496 while (!NILP (args_left
));
1502 /* Lisp functions for creating and removing buffer-local variables. */
1504 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1505 1, 1, "vMake Variable Buffer Local: ",
1506 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1507 At any time, the value for the current buffer is in effect,
1508 unless the variable has never been set in this buffer,
1509 in which case the default value is in effect.
1510 Note that binding the variable with `let', or setting it while
1511 a `let'-style binding made in this buffer is in effect,
1512 does not make the variable buffer-local. Return VARIABLE.
1514 The function `default-value' gets the default value and `set-default' sets it. */)
1516 register Lisp_Object variable
;
1518 register Lisp_Object tem
, valcontents
, newval
;
1520 CHECK_SYMBOL (variable
);
1521 variable
= indirect_variable (variable
);
1523 valcontents
= SYMBOL_VALUE (variable
);
1524 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1525 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1527 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1529 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1531 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1534 if (EQ (valcontents
, Qunbound
))
1535 SET_SYMBOL_VALUE (variable
, Qnil
);
1536 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1538 newval
= allocate_misc ();
1539 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1540 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1541 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1542 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1543 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1544 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1545 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1546 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1547 SET_SYMBOL_VALUE (variable
, newval
);
1551 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1552 1, 1, "vMake Local Variable: ",
1553 doc
: /* Make VARIABLE have a separate value in the current buffer.
1554 Other buffers will continue to share a common default value.
1555 \(The buffer-local value of VARIABLE starts out as the same value
1556 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1557 See also `make-variable-buffer-local'. Return VARIABLE.
1559 If the variable is already arranged to become local when set,
1560 this function causes a local value to exist for this buffer,
1561 just as setting the variable would do.
1563 This function returns VARIABLE, and therefore
1564 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1567 Do not use `make-local-variable' to make a hook variable buffer-local.
1568 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1570 register Lisp_Object variable
;
1572 register Lisp_Object tem
, valcontents
;
1574 CHECK_SYMBOL (variable
);
1575 variable
= indirect_variable (variable
);
1577 valcontents
= SYMBOL_VALUE (variable
);
1578 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1579 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1581 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1583 tem
= Fboundp (variable
);
1585 /* Make sure the symbol has a local value in this particular buffer,
1586 by setting it to the same value it already has. */
1587 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1590 /* Make sure symbol is set up to hold per-buffer values. */
1591 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1594 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1596 newval
= allocate_misc ();
1597 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1598 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1599 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1600 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1601 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1602 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1603 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1604 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1605 SET_SYMBOL_VALUE (variable
, newval
);;
1607 /* Make sure this buffer has its own value of symbol. */
1608 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1611 /* Swap out any local binding for some other buffer, and make
1612 sure the current value is permanently recorded, if it's the
1614 find_symbol_value (variable
);
1616 current_buffer
->local_var_alist
1617 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1618 current_buffer
->local_var_alist
);
1620 /* Make sure symbol does not think it is set up for this buffer;
1621 force it to look once again for this buffer's value. */
1623 Lisp_Object
*pvalbuf
;
1625 valcontents
= SYMBOL_VALUE (variable
);
1627 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1628 if (current_buffer
== XBUFFER (*pvalbuf
))
1630 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1634 /* If the symbol forwards into a C variable, then load the binding
1635 for this buffer now. If C code modifies the variable before we
1636 load the binding in, then that new value will clobber the default
1637 binding the next time we unload it. */
1638 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1639 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1640 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1645 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1646 1, 1, "vKill Local Variable: ",
1647 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1648 From now on the default value will apply in this buffer. Return VARIABLE. */)
1650 register Lisp_Object variable
;
1652 register Lisp_Object tem
, valcontents
;
1654 CHECK_SYMBOL (variable
);
1655 variable
= indirect_variable (variable
);
1657 valcontents
= SYMBOL_VALUE (variable
);
1659 if (BUFFER_OBJFWDP (valcontents
))
1661 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1662 int idx
= PER_BUFFER_IDX (offset
);
1666 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1667 PER_BUFFER_VALUE (current_buffer
, offset
)
1668 = PER_BUFFER_DEFAULT (offset
);
1673 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1674 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1677 /* Get rid of this buffer's alist element, if any. */
1679 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1681 current_buffer
->local_var_alist
1682 = Fdelq (tem
, current_buffer
->local_var_alist
);
1684 /* If the symbol is set up with the current buffer's binding
1685 loaded, recompute its value. We have to do it now, or else
1686 forwarded objects won't work right. */
1688 Lisp_Object
*pvalbuf
, buf
;
1689 valcontents
= SYMBOL_VALUE (variable
);
1690 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1691 XSETBUFFER (buf
, current_buffer
);
1692 if (EQ (buf
, *pvalbuf
))
1695 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1696 find_symbol_value (variable
);
1703 /* Lisp functions for creating and removing buffer-local variables. */
1705 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1706 1, 1, "vMake Variable Frame Local: ",
1707 doc
: /* Enable VARIABLE to have frame-local bindings.
1708 When a frame-local binding exists in the current frame,
1709 it is in effect whenever the current buffer has no buffer-local binding.
1710 A frame-local binding is actually a frame parameter value;
1711 thus, any given frame has a local binding for VARIABLE if it has
1712 a value for the frame parameter named VARIABLE. Return VARIABLE.
1713 See `modify-frame-parameters' for how to set frame parameters. */)
1715 register Lisp_Object variable
;
1717 register Lisp_Object tem
, valcontents
, newval
;
1719 CHECK_SYMBOL (variable
);
1720 variable
= indirect_variable (variable
);
1722 valcontents
= SYMBOL_VALUE (variable
);
1723 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1724 || BUFFER_OBJFWDP (valcontents
))
1725 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1727 if (BUFFER_LOCAL_VALUEP (valcontents
)
1728 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1730 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1734 if (EQ (valcontents
, Qunbound
))
1735 SET_SYMBOL_VALUE (variable
, Qnil
);
1736 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1738 newval
= allocate_misc ();
1739 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1740 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1741 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1742 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1743 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1744 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1745 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1746 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1747 SET_SYMBOL_VALUE (variable
, newval
);
1751 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1753 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1754 BUFFER defaults to the current buffer. */)
1756 register Lisp_Object variable
, buffer
;
1758 Lisp_Object valcontents
;
1759 register struct buffer
*buf
;
1762 buf
= current_buffer
;
1765 CHECK_BUFFER (buffer
);
1766 buf
= XBUFFER (buffer
);
1769 CHECK_SYMBOL (variable
);
1770 variable
= indirect_variable (variable
);
1772 valcontents
= SYMBOL_VALUE (variable
);
1773 if (BUFFER_LOCAL_VALUEP (valcontents
)
1774 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1776 Lisp_Object tail
, elt
;
1778 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1781 if (EQ (variable
, XCAR (elt
)))
1785 if (BUFFER_OBJFWDP (valcontents
))
1787 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1788 int idx
= PER_BUFFER_IDX (offset
);
1789 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1795 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1797 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
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 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1907 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1908 doc
: /* Return the function at the end of OBJECT's function chain.
1909 If OBJECT is a symbol, follow all function indirections and return the final
1911 If OBJECT is not a symbol, just return it.
1912 Signal a void-function error if the final symbol is unbound.
1913 Signal a cyclic-function-indirection error if there is a loop in the
1914 function chain of symbols. */)
1916 register Lisp_Object object
;
1920 result
= indirect_function (object
);
1922 if (EQ (result
, Qunbound
))
1923 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1927 /* Extract and set vector and string elements */
1929 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1930 doc
: /* Return the element of ARRAY at index IDX.
1931 ARRAY may be a vector, a string, a char-table, a bool-vector,
1932 or a byte-code object. IDX starts at 0. */)
1934 register Lisp_Object array
;
1937 register int idxval
;
1940 idxval
= XINT (idx
);
1941 if (STRINGP (array
))
1945 if (idxval
< 0 || idxval
>= SCHARS (array
))
1946 args_out_of_range (array
, idx
);
1947 if (! STRING_MULTIBYTE (array
))
1948 return make_number ((unsigned char) SREF (array
, idxval
));
1949 idxval_byte
= string_char_to_byte (array
, idxval
);
1951 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1952 SBYTES (array
) - idxval_byte
);
1953 return make_number (c
);
1955 else if (BOOL_VECTOR_P (array
))
1959 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1960 args_out_of_range (array
, idx
);
1962 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1963 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1965 else if (CHAR_TABLE_P (array
))
1972 args_out_of_range (array
, idx
);
1973 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1975 /* For ASCII and 8-bit European characters, the element is
1976 stored in the top table. */
1977 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1979 val
= XCHAR_TABLE (array
)->defalt
;
1980 while (NILP (val
)) /* Follow parents until we find some value. */
1982 array
= XCHAR_TABLE (array
)->parent
;
1985 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1987 val
= XCHAR_TABLE (array
)->defalt
;
1994 Lisp_Object sub_table
;
1996 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1997 if (code
[1] < 32) code
[1] = -1;
1998 else if (code
[2] < 32) code
[2] = -1;
2000 /* Here, the possible range of CODE[0] (== charset ID) is
2001 128..MAX_CHARSET. Since the top level char table contains
2002 data for multibyte characters after 256th element, we must
2003 increment CODE[0] by 128 to get a correct index. */
2005 code
[3] = -1; /* anchor */
2007 try_parent_char_table
:
2009 for (i
= 0; code
[i
] >= 0; i
++)
2011 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2012 if (SUB_CHAR_TABLE_P (val
))
2017 val
= XCHAR_TABLE (sub_table
)->defalt
;
2020 array
= XCHAR_TABLE (array
)->parent
;
2022 goto try_parent_char_table
;
2027 /* Here, VAL is a sub char table. We try the default value
2029 val
= XCHAR_TABLE (val
)->defalt
;
2032 array
= XCHAR_TABLE (array
)->parent
;
2034 goto try_parent_char_table
;
2042 if (VECTORP (array
))
2043 size
= XVECTOR (array
)->size
;
2044 else if (COMPILEDP (array
))
2045 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2047 wrong_type_argument (Qarrayp
, array
);
2049 if (idxval
< 0 || idxval
>= size
)
2050 args_out_of_range (array
, idx
);
2051 return XVECTOR (array
)->contents
[idxval
];
2055 /* Don't use alloca for relocating string data larger than this, lest
2056 we overflow their stack. The value is the same as what used in
2057 fns.c for base64 handling. */
2058 #define MAX_ALLOCA 16*1024
2060 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2061 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2062 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2063 bool-vector. IDX starts at 0. */)
2064 (array
, idx
, newelt
)
2065 register Lisp_Object array
;
2066 Lisp_Object idx
, newelt
;
2068 register int idxval
;
2071 idxval
= XINT (idx
);
2072 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2073 && ! CHAR_TABLE_P (array
))
2074 array
= wrong_type_argument (Qarrayp
, array
);
2075 CHECK_IMPURE (array
);
2077 if (VECTORP (array
))
2079 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2080 args_out_of_range (array
, idx
);
2081 XVECTOR (array
)->contents
[idxval
] = newelt
;
2083 else if (BOOL_VECTOR_P (array
))
2087 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2088 args_out_of_range (array
, idx
);
2090 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2092 if (! NILP (newelt
))
2093 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2095 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2096 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2098 else if (CHAR_TABLE_P (array
))
2101 args_out_of_range (array
, idx
);
2102 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2103 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2109 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2110 if (code
[1] < 32) code
[1] = -1;
2111 else if (code
[2] < 32) code
[2] = -1;
2113 /* See the comment of the corresponding part in Faref. */
2115 code
[3] = -1; /* anchor */
2116 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2118 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2119 if (SUB_CHAR_TABLE_P (val
))
2125 /* VAL is a leaf. Create a sub char table with the
2126 default value VAL or XCHAR_TABLE (array)->defalt
2127 and look into it. */
2129 temp
= make_sub_char_table (NILP (val
)
2130 ? XCHAR_TABLE (array
)->defalt
2132 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2136 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2139 else if (STRING_MULTIBYTE (array
))
2141 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2142 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2144 if (idxval
< 0 || idxval
>= SCHARS (array
))
2145 args_out_of_range (array
, idx
);
2146 CHECK_NUMBER (newelt
);
2148 nbytes
= SBYTES (array
);
2150 idxval_byte
= string_char_to_byte (array
, idxval
);
2151 p1
= SDATA (array
) + idxval_byte
;
2152 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2153 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2154 if (prev_bytes
!= new_bytes
)
2156 /* We must relocate the string data. */
2157 int nchars
= SCHARS (array
);
2160 str
= (nbytes
<= MAX_ALLOCA
2161 ? (unsigned char *) alloca (nbytes
)
2162 : (unsigned char *) xmalloc (nbytes
));
2163 bcopy (SDATA (array
), str
, nbytes
);
2164 allocate_string_data (XSTRING (array
), nchars
,
2165 nbytes
+ new_bytes
- prev_bytes
);
2166 bcopy (str
, SDATA (array
), idxval_byte
);
2167 p1
= SDATA (array
) + idxval_byte
;
2168 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2169 nbytes
- (idxval_byte
+ prev_bytes
));
2170 if (nbytes
> MAX_ALLOCA
)
2172 clear_string_char_byte_cache ();
2179 if (idxval
< 0 || idxval
>= SCHARS (array
))
2180 args_out_of_range (array
, idx
);
2181 CHECK_NUMBER (newelt
);
2183 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2184 SSET (array
, idxval
, XINT (newelt
));
2187 /* We must relocate the string data while converting it to
2189 int idxval_byte
, prev_bytes
, new_bytes
;
2190 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2191 unsigned char *origstr
= SDATA (array
), *str
;
2194 nchars
= SCHARS (array
);
2195 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2196 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2198 str
= (nbytes
<= MAX_ALLOCA
2199 ? (unsigned char *) alloca (nbytes
)
2200 : (unsigned char *) xmalloc (nbytes
));
2201 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2202 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2204 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2205 allocate_string_data (XSTRING (array
), nchars
,
2206 nbytes
+ new_bytes
- prev_bytes
);
2207 bcopy (str
, SDATA (array
), idxval_byte
);
2208 p1
= SDATA (array
) + idxval_byte
;
2211 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2212 nbytes
- (idxval_byte
+ prev_bytes
));
2213 if (nbytes
> MAX_ALLOCA
)
2215 clear_string_char_byte_cache ();
2222 /* Arithmetic functions */
2224 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2227 arithcompare (num1
, num2
, comparison
)
2228 Lisp_Object num1
, num2
;
2229 enum comparison comparison
;
2231 double f1
= 0, f2
= 0;
2234 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2235 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2237 if (FLOATP (num1
) || FLOATP (num2
))
2240 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2241 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2247 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2252 if (floatp
? f1
!= f2
: XINT (num1
) != 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
))
2281 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2282 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2284 register Lisp_Object num1
, num2
;
2286 return arithcompare (num1
, num2
, equal
);
2289 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2290 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2292 register Lisp_Object num1
, num2
;
2294 return arithcompare (num1
, num2
, less
);
2297 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2298 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2300 register Lisp_Object num1
, num2
;
2302 return arithcompare (num1
, num2
, grtr
);
2305 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2306 doc
: /* Return t if first arg is less than or equal to second arg.
2307 Both must be numbers or markers. */)
2309 register Lisp_Object num1
, num2
;
2311 return arithcompare (num1
, num2
, less_or_equal
);
2314 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2315 doc
: /* Return t if first arg is greater than or equal to second arg.
2316 Both must be numbers or markers. */)
2318 register Lisp_Object num1
, num2
;
2320 return arithcompare (num1
, num2
, grtr_or_equal
);
2323 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2324 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2326 register Lisp_Object num1
, num2
;
2328 return arithcompare (num1
, num2
, notequal
);
2331 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2332 doc
: /* Return t if NUMBER is zero. */)
2334 register Lisp_Object number
;
2336 CHECK_NUMBER_OR_FLOAT (number
);
2338 if (FLOATP (number
))
2340 if (XFLOAT_DATA (number
) == 0.0)
2350 /* Convert between long values and pairs of Lisp integers. */
2356 unsigned long top
= i
>> 16;
2357 unsigned int bot
= i
& 0xFFFF;
2359 return make_number (bot
);
2360 if (top
== (unsigned long)-1 >> 16)
2361 return Fcons (make_number (-1), make_number (bot
));
2362 return Fcons (make_number (top
), make_number (bot
));
2369 Lisp_Object top
, bot
;
2376 return ((XINT (top
) << 16) | XINT (bot
));
2379 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2380 doc
: /* Return the decimal representation of NUMBER as a string.
2381 Uses a minus sign if negative.
2382 NUMBER may be an integer or a floating point number. */)
2386 char buffer
[VALBITS
];
2388 CHECK_NUMBER_OR_FLOAT (number
);
2390 if (FLOATP (number
))
2392 char pigbuf
[350]; /* see comments in float_to_string */
2394 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2395 return build_string (pigbuf
);
2398 if (sizeof (int) == sizeof (EMACS_INT
))
2399 sprintf (buffer
, "%d", XINT (number
));
2400 else if (sizeof (long) == sizeof (EMACS_INT
))
2401 sprintf (buffer
, "%ld", (long) XINT (number
));
2404 return build_string (buffer
);
2408 digit_to_number (character
, base
)
2409 int character
, base
;
2413 if (character
>= '0' && character
<= '9')
2414 digit
= character
- '0';
2415 else if (character
>= 'a' && character
<= 'z')
2416 digit
= character
- 'a' + 10;
2417 else if (character
>= 'A' && character
<= 'Z')
2418 digit
= character
- 'A' + 10;
2428 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2429 doc
: /* Parse STRING as a decimal number and return the number.
2430 This parses both integers and floating point numbers.
2431 It ignores leading spaces and tabs.
2433 If BASE, interpret STRING as a number in that base. If BASE isn't
2434 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2435 If the base used is not 10, floating point is not recognized. */)
2437 register Lisp_Object string
, base
;
2439 register unsigned char *p
;
2444 CHECK_STRING (string
);
2450 CHECK_NUMBER (base
);
2452 if (b
< 2 || b
> 16)
2453 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2456 /* Skip any whitespace at the front of the number. Some versions of
2457 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2459 while (*p
== ' ' || *p
== '\t')
2470 if (isfloat_string (p
) && b
== 10)
2471 val
= make_float (sign
* atof (p
));
2478 int digit
= digit_to_number (*p
++, b
);
2484 val
= make_fixnum_or_float (sign
* v
);
2504 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2505 int, Lisp_Object
*));
2506 extern Lisp_Object
fmod_float ();
2509 arith_driver (code
, nargs
, args
)
2512 register Lisp_Object
*args
;
2514 register Lisp_Object val
;
2515 register int argnum
;
2516 register EMACS_INT accum
= 0;
2517 register EMACS_INT next
;
2519 switch (SWITCH_ENUM_CAST (code
))
2537 for (argnum
= 0; argnum
< nargs
; argnum
++)
2539 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2541 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2544 return float_arith_driver ((double) accum
, argnum
, code
,
2547 next
= XINT (args
[argnum
]);
2548 switch (SWITCH_ENUM_CAST (code
))
2554 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2565 Fsignal (Qarith_error
, Qnil
);
2579 if (!argnum
|| next
> accum
)
2583 if (!argnum
|| next
< accum
)
2589 XSETINT (val
, accum
);
2594 #define isnan(x) ((x) != (x))
2597 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2599 register int argnum
;
2602 register Lisp_Object
*args
;
2604 register Lisp_Object val
;
2607 for (; argnum
< nargs
; argnum
++)
2609 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2610 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2614 next
= XFLOAT_DATA (val
);
2618 args
[argnum
] = val
; /* runs into a compiler bug. */
2619 next
= XINT (args
[argnum
]);
2621 switch (SWITCH_ENUM_CAST (code
))
2627 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2637 if (! IEEE_FLOATING_POINT
&& next
== 0)
2638 Fsignal (Qarith_error
, Qnil
);
2645 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2647 if (!argnum
|| isnan (next
) || next
> accum
)
2651 if (!argnum
|| isnan (next
) || next
< accum
)
2657 return make_float (accum
);
2661 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2662 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2663 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2668 return arith_driver (Aadd
, nargs
, args
);
2671 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2672 doc
: /* Negate number or subtract numbers or markers and return the result.
2673 With one arg, negates it. With more than one arg,
2674 subtracts all but the first from the first.
2675 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2680 return arith_driver (Asub
, nargs
, args
);
2683 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2684 doc
: /* Return product of any number of arguments, which are numbers or markers.
2685 usage: (* &rest NUMBERS-OR-MARKERS) */)
2690 return arith_driver (Amult
, nargs
, args
);
2693 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2694 doc
: /* Return first argument divided by all the remaining arguments.
2695 The arguments must be numbers or markers.
2696 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2703 return arith_driver (Adiv
, nargs
, args
);
2704 for (argnum
= 0; argnum
< nargs
; argnum
++)
2705 if (FLOATP (args
[argnum
]))
2706 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2707 return arith_driver (Adiv
, nargs
, args
);
2710 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2711 doc
: /* Return remainder of X divided by Y.
2712 Both must be integers or markers. */)
2714 register Lisp_Object x
, y
;
2718 CHECK_NUMBER_COERCE_MARKER (x
);
2719 CHECK_NUMBER_COERCE_MARKER (y
);
2721 if (XFASTINT (y
) == 0)
2722 Fsignal (Qarith_error
, Qnil
);
2724 XSETINT (val
, XINT (x
) % XINT (y
));
2738 /* If the magnitude of the result exceeds that of the divisor, or
2739 the sign of the result does not agree with that of the dividend,
2740 iterate with the reduced value. This does not yield a
2741 particularly accurate result, but at least it will be in the
2742 range promised by fmod. */
2744 r
-= f2
* floor (r
/ f2
);
2745 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2749 #endif /* ! HAVE_FMOD */
2751 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2752 doc
: /* Return X modulo Y.
2753 The result falls between zero (inclusive) and Y (exclusive).
2754 Both X and Y must be numbers or markers. */)
2756 register Lisp_Object x
, y
;
2761 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2762 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2764 if (FLOATP (x
) || FLOATP (y
))
2765 return fmod_float (x
, y
);
2771 Fsignal (Qarith_error
, Qnil
);
2775 /* If the "remainder" comes out with the wrong sign, fix it. */
2776 if (i2
< 0 ? i1
> 0 : i1
< 0)
2783 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2784 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2785 The value is always a number; markers are converted to numbers.
2786 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2791 return arith_driver (Amax
, nargs
, args
);
2794 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2795 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2796 The value is always a number; markers are converted to numbers.
2797 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2802 return arith_driver (Amin
, nargs
, args
);
2805 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2806 doc
: /* Return bitwise-and of all the arguments.
2807 Arguments may be integers, or markers converted to integers.
2808 usage: (logand &rest INTS-OR-MARKERS) */)
2813 return arith_driver (Alogand
, nargs
, args
);
2816 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2817 doc
: /* Return bitwise-or of all the arguments.
2818 Arguments may be integers, or markers converted to integers.
2819 usage: (logior &rest INTS-OR-MARKERS) */)
2824 return arith_driver (Alogior
, nargs
, args
);
2827 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2828 doc
: /* Return bitwise-exclusive-or of all the arguments.
2829 Arguments may be integers, or markers converted to integers.
2830 usage: (logxor &rest INTS-OR-MARKERS) */)
2835 return arith_driver (Alogxor
, nargs
, args
);
2838 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2839 doc
: /* Return VALUE with its bits shifted left by COUNT.
2840 If COUNT is negative, shifting is actually to the right.
2841 In this case, the sign bit is duplicated. */)
2843 register Lisp_Object value
, count
;
2845 register Lisp_Object val
;
2847 CHECK_NUMBER (value
);
2848 CHECK_NUMBER (count
);
2850 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2852 else if (XINT (count
) > 0)
2853 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2854 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2855 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2857 XSETINT (val
, XINT (value
) >> -XINT (count
));
2861 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2862 doc
: /* Return VALUE with its bits shifted left by COUNT.
2863 If COUNT is negative, shifting is actually to the right.
2864 In this case, zeros are shifted in on the left. */)
2866 register Lisp_Object value
, count
;
2868 register Lisp_Object val
;
2870 CHECK_NUMBER (value
);
2871 CHECK_NUMBER (count
);
2873 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2875 else if (XINT (count
) > 0)
2876 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2877 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2880 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2884 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2885 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2886 Markers are converted to integers. */)
2888 register Lisp_Object number
;
2890 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2892 if (FLOATP (number
))
2893 return (make_float (1.0 + XFLOAT_DATA (number
)));
2895 XSETINT (number
, XINT (number
) + 1);
2899 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2900 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2901 Markers are converted to integers. */)
2903 register Lisp_Object number
;
2905 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2907 if (FLOATP (number
))
2908 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2910 XSETINT (number
, XINT (number
) - 1);
2914 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2915 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2917 register Lisp_Object number
;
2919 CHECK_NUMBER (number
);
2920 XSETINT (number
, ~XINT (number
));
2924 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2925 doc
: /* Return the byteorder for the machine.
2926 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2927 lowercase l) for small endian machines. */)
2930 unsigned i
= 0x04030201;
2931 int order
= *(char *)&i
== 1 ? 108 : 66;
2933 return make_number (order
);
2941 Lisp_Object error_tail
, arith_tail
;
2943 Qquote
= intern ("quote");
2944 Qlambda
= intern ("lambda");
2945 Qsubr
= intern ("subr");
2946 Qerror_conditions
= intern ("error-conditions");
2947 Qerror_message
= intern ("error-message");
2948 Qtop_level
= intern ("top-level");
2950 Qerror
= intern ("error");
2951 Qquit
= intern ("quit");
2952 Qwrong_type_argument
= intern ("wrong-type-argument");
2953 Qargs_out_of_range
= intern ("args-out-of-range");
2954 Qvoid_function
= intern ("void-function");
2955 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2956 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2957 Qvoid_variable
= intern ("void-variable");
2958 Qsetting_constant
= intern ("setting-constant");
2959 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2961 Qinvalid_function
= intern ("invalid-function");
2962 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2963 Qno_catch
= intern ("no-catch");
2964 Qend_of_file
= intern ("end-of-file");
2965 Qarith_error
= intern ("arith-error");
2966 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2967 Qend_of_buffer
= intern ("end-of-buffer");
2968 Qbuffer_read_only
= intern ("buffer-read-only");
2969 Qtext_read_only
= intern ("text-read-only");
2970 Qmark_inactive
= intern ("mark-inactive");
2972 Qlistp
= intern ("listp");
2973 Qconsp
= intern ("consp");
2974 Qsymbolp
= intern ("symbolp");
2975 Qkeywordp
= intern ("keywordp");
2976 Qintegerp
= intern ("integerp");
2977 Qnatnump
= intern ("natnump");
2978 Qwholenump
= intern ("wholenump");
2979 Qstringp
= intern ("stringp");
2980 Qarrayp
= intern ("arrayp");
2981 Qsequencep
= intern ("sequencep");
2982 Qbufferp
= intern ("bufferp");
2983 Qvectorp
= intern ("vectorp");
2984 Qchar_or_string_p
= intern ("char-or-string-p");
2985 Qmarkerp
= intern ("markerp");
2986 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2987 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2988 Qboundp
= intern ("boundp");
2989 Qfboundp
= intern ("fboundp");
2991 Qfloatp
= intern ("floatp");
2992 Qnumberp
= intern ("numberp");
2993 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2995 Qchar_table_p
= intern ("char-table-p");
2996 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2998 Qsubrp
= intern ("subrp");
2999 Qunevalled
= intern ("unevalled");
3000 Qmany
= intern ("many");
3002 Qcdr
= intern ("cdr");
3004 /* Handle automatic advice activation */
3005 Qad_advice_info
= intern ("ad-advice-info");
3006 Qad_activate_internal
= intern ("ad-activate-internal");
3008 error_tail
= Fcons (Qerror
, Qnil
);
3010 /* ERROR is used as a signaler for random errors for which nothing else is right */
3012 Fput (Qerror
, Qerror_conditions
,
3014 Fput (Qerror
, Qerror_message
,
3015 build_string ("error"));
3017 Fput (Qquit
, Qerror_conditions
,
3018 Fcons (Qquit
, Qnil
));
3019 Fput (Qquit
, Qerror_message
,
3020 build_string ("Quit"));
3022 Fput (Qwrong_type_argument
, Qerror_conditions
,
3023 Fcons (Qwrong_type_argument
, error_tail
));
3024 Fput (Qwrong_type_argument
, Qerror_message
,
3025 build_string ("Wrong type argument"));
3027 Fput (Qargs_out_of_range
, Qerror_conditions
,
3028 Fcons (Qargs_out_of_range
, error_tail
));
3029 Fput (Qargs_out_of_range
, Qerror_message
,
3030 build_string ("Args out of range"));
3032 Fput (Qvoid_function
, Qerror_conditions
,
3033 Fcons (Qvoid_function
, error_tail
));
3034 Fput (Qvoid_function
, Qerror_message
,
3035 build_string ("Symbol's function definition is void"));
3037 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3038 Fcons (Qcyclic_function_indirection
, error_tail
));
3039 Fput (Qcyclic_function_indirection
, Qerror_message
,
3040 build_string ("Symbol's chain of function indirections contains a loop"));
3042 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3043 Fcons (Qcyclic_variable_indirection
, error_tail
));
3044 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3045 build_string ("Symbol's chain of variable indirections contains a loop"));
3047 Qcircular_list
= intern ("circular-list");
3048 staticpro (&Qcircular_list
);
3049 Fput (Qcircular_list
, Qerror_conditions
,
3050 Fcons (Qcircular_list
, error_tail
));
3051 Fput (Qcircular_list
, Qerror_message
,
3052 build_string ("List contains a loop"));
3054 Fput (Qvoid_variable
, Qerror_conditions
,
3055 Fcons (Qvoid_variable
, error_tail
));
3056 Fput (Qvoid_variable
, Qerror_message
,
3057 build_string ("Symbol's value as variable is void"));
3059 Fput (Qsetting_constant
, Qerror_conditions
,
3060 Fcons (Qsetting_constant
, error_tail
));
3061 Fput (Qsetting_constant
, Qerror_message
,
3062 build_string ("Attempt to set a constant symbol"));
3064 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3065 Fcons (Qinvalid_read_syntax
, error_tail
));
3066 Fput (Qinvalid_read_syntax
, Qerror_message
,
3067 build_string ("Invalid read syntax"));
3069 Fput (Qinvalid_function
, Qerror_conditions
,
3070 Fcons (Qinvalid_function
, error_tail
));
3071 Fput (Qinvalid_function
, Qerror_message
,
3072 build_string ("Invalid function"));
3074 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3075 Fcons (Qwrong_number_of_arguments
, error_tail
));
3076 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3077 build_string ("Wrong number of arguments"));
3079 Fput (Qno_catch
, Qerror_conditions
,
3080 Fcons (Qno_catch
, error_tail
));
3081 Fput (Qno_catch
, Qerror_message
,
3082 build_string ("No catch for tag"));
3084 Fput (Qend_of_file
, Qerror_conditions
,
3085 Fcons (Qend_of_file
, error_tail
));
3086 Fput (Qend_of_file
, Qerror_message
,
3087 build_string ("End of file during parsing"));
3089 arith_tail
= Fcons (Qarith_error
, error_tail
);
3090 Fput (Qarith_error
, Qerror_conditions
,
3092 Fput (Qarith_error
, Qerror_message
,
3093 build_string ("Arithmetic error"));
3095 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3096 Fcons (Qbeginning_of_buffer
, error_tail
));
3097 Fput (Qbeginning_of_buffer
, Qerror_message
,
3098 build_string ("Beginning of buffer"));
3100 Fput (Qend_of_buffer
, Qerror_conditions
,
3101 Fcons (Qend_of_buffer
, error_tail
));
3102 Fput (Qend_of_buffer
, Qerror_message
,
3103 build_string ("End of buffer"));
3105 Fput (Qbuffer_read_only
, Qerror_conditions
,
3106 Fcons (Qbuffer_read_only
, error_tail
));
3107 Fput (Qbuffer_read_only
, Qerror_message
,
3108 build_string ("Buffer is read-only"));
3110 Fput (Qtext_read_only
, Qerror_conditions
,
3111 Fcons (Qtext_read_only
, error_tail
));
3112 Fput (Qtext_read_only
, Qerror_message
,
3113 build_string ("Text is read-only"));
3115 Qrange_error
= intern ("range-error");
3116 Qdomain_error
= intern ("domain-error");
3117 Qsingularity_error
= intern ("singularity-error");
3118 Qoverflow_error
= intern ("overflow-error");
3119 Qunderflow_error
= intern ("underflow-error");
3121 Fput (Qdomain_error
, Qerror_conditions
,
3122 Fcons (Qdomain_error
, arith_tail
));
3123 Fput (Qdomain_error
, Qerror_message
,
3124 build_string ("Arithmetic domain error"));
3126 Fput (Qrange_error
, Qerror_conditions
,
3127 Fcons (Qrange_error
, arith_tail
));
3128 Fput (Qrange_error
, Qerror_message
,
3129 build_string ("Arithmetic range error"));
3131 Fput (Qsingularity_error
, Qerror_conditions
,
3132 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3133 Fput (Qsingularity_error
, Qerror_message
,
3134 build_string ("Arithmetic singularity error"));
3136 Fput (Qoverflow_error
, Qerror_conditions
,
3137 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3138 Fput (Qoverflow_error
, Qerror_message
,
3139 build_string ("Arithmetic overflow error"));
3141 Fput (Qunderflow_error
, Qerror_conditions
,
3142 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3143 Fput (Qunderflow_error
, Qerror_message
,
3144 build_string ("Arithmetic underflow error"));
3146 staticpro (&Qrange_error
);
3147 staticpro (&Qdomain_error
);
3148 staticpro (&Qsingularity_error
);
3149 staticpro (&Qoverflow_error
);
3150 staticpro (&Qunderflow_error
);
3154 staticpro (&Qquote
);
3155 staticpro (&Qlambda
);
3157 staticpro (&Qunbound
);
3158 staticpro (&Qerror_conditions
);
3159 staticpro (&Qerror_message
);
3160 staticpro (&Qtop_level
);
3162 staticpro (&Qerror
);
3164 staticpro (&Qwrong_type_argument
);
3165 staticpro (&Qargs_out_of_range
);
3166 staticpro (&Qvoid_function
);
3167 staticpro (&Qcyclic_function_indirection
);
3168 staticpro (&Qvoid_variable
);
3169 staticpro (&Qsetting_constant
);
3170 staticpro (&Qinvalid_read_syntax
);
3171 staticpro (&Qwrong_number_of_arguments
);
3172 staticpro (&Qinvalid_function
);
3173 staticpro (&Qno_catch
);
3174 staticpro (&Qend_of_file
);
3175 staticpro (&Qarith_error
);
3176 staticpro (&Qbeginning_of_buffer
);
3177 staticpro (&Qend_of_buffer
);
3178 staticpro (&Qbuffer_read_only
);
3179 staticpro (&Qtext_read_only
);
3180 staticpro (&Qmark_inactive
);
3182 staticpro (&Qlistp
);
3183 staticpro (&Qconsp
);
3184 staticpro (&Qsymbolp
);
3185 staticpro (&Qkeywordp
);
3186 staticpro (&Qintegerp
);
3187 staticpro (&Qnatnump
);
3188 staticpro (&Qwholenump
);
3189 staticpro (&Qstringp
);
3190 staticpro (&Qarrayp
);
3191 staticpro (&Qsequencep
);
3192 staticpro (&Qbufferp
);
3193 staticpro (&Qvectorp
);
3194 staticpro (&Qchar_or_string_p
);
3195 staticpro (&Qmarkerp
);
3196 staticpro (&Qbuffer_or_string_p
);
3197 staticpro (&Qinteger_or_marker_p
);
3198 staticpro (&Qfloatp
);
3199 staticpro (&Qnumberp
);
3200 staticpro (&Qnumber_or_marker_p
);
3201 staticpro (&Qchar_table_p
);
3202 staticpro (&Qvector_or_char_table_p
);
3203 staticpro (&Qsubrp
);
3205 staticpro (&Qunevalled
);
3207 staticpro (&Qboundp
);
3208 staticpro (&Qfboundp
);
3210 staticpro (&Qad_advice_info
);
3211 staticpro (&Qad_activate_internal
);
3213 /* Types that type-of returns. */
3214 Qinteger
= intern ("integer");
3215 Qsymbol
= intern ("symbol");
3216 Qstring
= intern ("string");
3217 Qcons
= intern ("cons");
3218 Qmarker
= intern ("marker");
3219 Qoverlay
= intern ("overlay");
3220 Qfloat
= intern ("float");
3221 Qwindow_configuration
= intern ("window-configuration");
3222 Qprocess
= intern ("process");
3223 Qwindow
= intern ("window");
3224 /* Qsubr = intern ("subr"); */
3225 Qcompiled_function
= intern ("compiled-function");
3226 Qbuffer
= intern ("buffer");
3227 Qframe
= intern ("frame");
3228 Qvector
= intern ("vector");
3229 Qchar_table
= intern ("char-table");
3230 Qbool_vector
= intern ("bool-vector");
3231 Qhash_table
= intern ("hash-table");
3233 staticpro (&Qinteger
);
3234 staticpro (&Qsymbol
);
3235 staticpro (&Qstring
);
3237 staticpro (&Qmarker
);
3238 staticpro (&Qoverlay
);
3239 staticpro (&Qfloat
);
3240 staticpro (&Qwindow_configuration
);
3241 staticpro (&Qprocess
);
3242 staticpro (&Qwindow
);
3243 /* staticpro (&Qsubr); */
3244 staticpro (&Qcompiled_function
);
3245 staticpro (&Qbuffer
);
3246 staticpro (&Qframe
);
3247 staticpro (&Qvector
);
3248 staticpro (&Qchar_table
);
3249 staticpro (&Qbool_vector
);
3250 staticpro (&Qhash_table
);
3252 defsubr (&Sindirect_variable
);
3253 defsubr (&Sinteractive_form
);
3256 defsubr (&Stype_of
);
3261 defsubr (&Sintegerp
);
3262 defsubr (&Sinteger_or_marker_p
);
3263 defsubr (&Snumberp
);
3264 defsubr (&Snumber_or_marker_p
);
3266 defsubr (&Snatnump
);
3267 defsubr (&Ssymbolp
);
3268 defsubr (&Skeywordp
);
3269 defsubr (&Sstringp
);
3270 defsubr (&Smultibyte_string_p
);
3271 defsubr (&Svectorp
);
3272 defsubr (&Schar_table_p
);
3273 defsubr (&Svector_or_char_table_p
);
3274 defsubr (&Sbool_vector_p
);
3276 defsubr (&Ssequencep
);
3277 defsubr (&Sbufferp
);
3278 defsubr (&Smarkerp
);
3280 defsubr (&Sbyte_code_function_p
);
3281 defsubr (&Schar_or_string_p
);
3284 defsubr (&Scar_safe
);
3285 defsubr (&Scdr_safe
);
3288 defsubr (&Ssymbol_function
);
3289 defsubr (&Sindirect_function
);
3290 defsubr (&Ssymbol_plist
);
3291 defsubr (&Ssymbol_name
);
3292 defsubr (&Smakunbound
);
3293 defsubr (&Sfmakunbound
);
3295 defsubr (&Sfboundp
);
3297 defsubr (&Sdefalias
);
3298 defsubr (&Ssetplist
);
3299 defsubr (&Ssymbol_value
);
3301 defsubr (&Sdefault_boundp
);
3302 defsubr (&Sdefault_value
);
3303 defsubr (&Sset_default
);
3304 defsubr (&Ssetq_default
);
3305 defsubr (&Smake_variable_buffer_local
);
3306 defsubr (&Smake_local_variable
);
3307 defsubr (&Skill_local_variable
);
3308 defsubr (&Smake_variable_frame_local
);
3309 defsubr (&Slocal_variable_p
);
3310 defsubr (&Slocal_variable_if_set_p
);
3311 defsubr (&Svariable_binding_locus
);
3314 defsubr (&Snumber_to_string
);
3315 defsubr (&Sstring_to_number
);
3316 defsubr (&Seqlsign
);
3339 defsubr (&Sbyteorder
);
3340 defsubr (&Ssubr_arity
);
3341 defsubr (&Ssubr_name
);
3343 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3345 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3346 doc
: /* The largest value that is representable in a Lisp integer. */);
3347 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3349 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3350 doc
: /* The smallest value that is representable in a Lisp integer. */);
3351 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3358 #if defined(USG) && !defined(POSIX_SIGNALS)
3359 /* USG systems forget handlers when they are used;
3360 must reestablish each time */
3361 signal (signo
, arith_error
);
3364 /* VMS systems are like USG. */
3365 signal (signo
, arith_error
);
3369 #else /* not BSD4_1 */
3370 sigsetmask (SIGEMPTYMASK
);
3371 #endif /* not BSD4_1 */
3373 Fsignal (Qarith_error
, Qnil
);
3379 /* Don't do this if just dumping out.
3380 We don't want to call `signal' in this case
3381 so that we don't have trouble with dumping
3382 signal-delivering routines in an inconsistent state. */
3386 #endif /* CANNOT_DUMP */
3387 signal (SIGFPE
, arith_error
);
3390 signal (SIGEMT
, arith_error
);
3394 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3395 (do not change this comment) */