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 If CMD is not a command, the return value is nil.
780 Value, if non-nil, is a list \(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
;
911 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
914 switch (XMISCTYPE (valcontents
))
916 case Lisp_Misc_Intfwd
:
917 CHECK_NUMBER (newval
);
918 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
919 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
920 error ("Value out of range for variable `%s'",
921 SDATA (SYMBOL_NAME (symbol
)));
924 case Lisp_Misc_Boolfwd
:
925 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
928 case Lisp_Misc_Objfwd
:
929 *XOBJFWD (valcontents
)->objvar
= newval
;
931 /* If this variable is a default for something stored
932 in the buffer itself, such as default-fill-column,
933 find the buffers that don't have local values for it
935 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
936 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
938 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
939 - (char *) &buffer_defaults
);
940 int idx
= PER_BUFFER_IDX (offset
);
947 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
952 buf
= Fcdr (XCAR (tail
));
953 if (!BUFFERP (buf
)) continue;
956 if (! PER_BUFFER_VALUE_P (b
, idx
))
957 PER_BUFFER_VALUE (b
, offset
) = newval
;
962 case Lisp_Misc_Buffer_Objfwd
:
964 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
967 type
= PER_BUFFER_TYPE (offset
);
968 if (! NILP (type
) && ! NILP (newval
)
969 && XTYPE (newval
) != XINT (type
))
970 buffer_slot_type_mismatch (offset
);
973 buf
= current_buffer
;
974 PER_BUFFER_VALUE (buf
, offset
) = newval
;
978 case Lisp_Misc_Kboard_Objfwd
:
980 char *base
= (char *) current_kboard
;
981 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
982 *(Lisp_Object
*) p
= newval
;
993 valcontents
= SYMBOL_VALUE (symbol
);
994 if (BUFFER_LOCAL_VALUEP (valcontents
)
995 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
996 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
998 SET_SYMBOL_VALUE (symbol
, newval
);
1002 /* Set up SYMBOL to refer to its global binding.
1003 This makes it safe to alter the status of other bindings. */
1006 swap_in_global_binding (symbol
)
1009 Lisp_Object valcontents
, cdr
;
1011 valcontents
= SYMBOL_VALUE (symbol
);
1012 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1013 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1015 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1017 /* Unload the previously loaded binding. */
1018 Fsetcdr (XCAR (cdr
),
1019 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1021 /* Select the global binding in the symbol. */
1023 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1025 /* Indicate that the global binding is set up now. */
1026 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1027 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1028 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1029 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1032 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1033 VALCONTENTS is the contents of its value cell,
1034 which points to a struct Lisp_Buffer_Local_Value.
1036 Return the value forwarded one step past the buffer-local stage.
1037 This could be another forwarding pointer. */
1040 swap_in_symval_forwarding (symbol
, valcontents
)
1041 Lisp_Object symbol
, valcontents
;
1043 register Lisp_Object tem1
;
1045 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1048 || current_buffer
!= XBUFFER (tem1
)
1049 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1050 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1052 if (XSYMBOL (symbol
)->indirect_variable
)
1053 symbol
= indirect_variable (symbol
);
1055 /* Unload the previously loaded binding. */
1056 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1058 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1059 /* Choose the new binding. */
1060 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1061 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1062 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1065 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1066 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1068 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1070 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1073 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1075 /* Load the new binding. */
1076 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1077 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1078 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1079 store_symval_forwarding (symbol
,
1080 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1083 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1086 /* Find the value of a symbol, returning Qunbound if it's not bound.
1087 This is helpful for code which just wants to get a variable's value
1088 if it has one, without signaling an error.
1089 Note that it must not be possible to quit
1090 within this function. Great care is required for this. */
1093 find_symbol_value (symbol
)
1096 register Lisp_Object valcontents
;
1097 register Lisp_Object val
;
1099 CHECK_SYMBOL (symbol
);
1100 valcontents
= SYMBOL_VALUE (symbol
);
1102 if (BUFFER_LOCAL_VALUEP (valcontents
)
1103 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1104 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1106 if (MISCP (valcontents
))
1108 switch (XMISCTYPE (valcontents
))
1110 case Lisp_Misc_Intfwd
:
1111 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1114 case Lisp_Misc_Boolfwd
:
1115 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1117 case Lisp_Misc_Objfwd
:
1118 return *XOBJFWD (valcontents
)->objvar
;
1120 case Lisp_Misc_Buffer_Objfwd
:
1121 return PER_BUFFER_VALUE (current_buffer
,
1122 XBUFFER_OBJFWD (valcontents
)->offset
);
1124 case Lisp_Misc_Kboard_Objfwd
:
1125 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1126 + (char *)current_kboard
);
1133 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1134 doc
: /* Return SYMBOL's value. Error if that is void. */)
1140 val
= find_symbol_value (symbol
);
1141 if (EQ (val
, Qunbound
))
1142 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1147 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1148 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1150 register Lisp_Object symbol
, newval
;
1152 return set_internal (symbol
, newval
, current_buffer
, 0);
1155 /* Return 1 if SYMBOL currently has a let-binding
1156 which was made in the buffer that is now current. */
1159 let_shadows_buffer_binding_p (symbol
)
1162 volatile struct specbinding
*p
;
1164 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1166 && CONSP (p
->symbol
))
1168 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1169 if ((EQ (symbol
, let_bound_symbol
)
1170 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1171 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1172 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1176 return p
>= specpdl
;
1179 /* Store the value NEWVAL into SYMBOL.
1180 If buffer-locality is an issue, BUF specifies which buffer to use.
1181 (0 stands for the current buffer.)
1183 If BINDFLAG is zero, then if this symbol is supposed to become
1184 local in every buffer where it is set, then we make it local.
1185 If BINDFLAG is nonzero, we don't do that. */
1188 set_internal (symbol
, newval
, buf
, bindflag
)
1189 register Lisp_Object symbol
, newval
;
1193 int voide
= EQ (newval
, Qunbound
);
1195 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1198 buf
= current_buffer
;
1200 /* If restoring in a dead buffer, do nothing. */
1201 if (NILP (buf
->name
))
1204 CHECK_SYMBOL (symbol
);
1205 if (SYMBOL_CONSTANT_P (symbol
)
1206 && (NILP (Fkeywordp (symbol
))
1207 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1208 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1210 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1212 if (BUFFER_OBJFWDP (valcontents
))
1214 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1215 int idx
= PER_BUFFER_IDX (offset
);
1218 && !let_shadows_buffer_binding_p (symbol
))
1219 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1221 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1222 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1224 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1225 if (XSYMBOL (symbol
)->indirect_variable
)
1226 symbol
= indirect_variable (symbol
);
1228 /* What binding is loaded right now? */
1229 current_alist_element
1230 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1232 /* If the current buffer is not the buffer whose binding is
1233 loaded, or if there may be frame-local bindings and the frame
1234 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1235 the default binding is loaded, the loaded binding may be the
1237 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1238 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1239 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1240 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1241 || (BUFFER_LOCAL_VALUEP (valcontents
)
1242 && EQ (XCAR (current_alist_element
),
1243 current_alist_element
)))
1245 /* The currently loaded binding is not necessarily valid.
1246 We need to unload it, and choose a new binding. */
1248 /* Write out `realvalue' to the old loaded binding. */
1249 Fsetcdr (current_alist_element
,
1250 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1252 /* Find the new binding. */
1253 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1254 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1255 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1259 /* This buffer still sees the default value. */
1261 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1262 or if this is `let' rather than `set',
1263 make CURRENT-ALIST-ELEMENT point to itself,
1264 indicating that we're seeing the default value.
1265 Likewise if the variable has been let-bound
1266 in the current buffer. */
1267 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1268 || let_shadows_buffer_binding_p (symbol
))
1270 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1272 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1273 tem1
= Fassq (symbol
,
1274 XFRAME (selected_frame
)->param_alist
);
1277 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1279 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1281 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1282 and we're not within a let that was made for this buffer,
1283 create a new buffer-local binding for the variable.
1284 That means, give this buffer a new assoc for a local value
1285 and load that binding. */
1288 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1289 buf
->local_var_alist
1290 = Fcons (tem1
, buf
->local_var_alist
);
1294 /* Record which binding is now loaded. */
1295 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1298 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1299 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1300 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1302 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1305 /* If storing void (making the symbol void), forward only through
1306 buffer-local indicator, not through Lisp_Objfwd, etc. */
1308 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1310 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1312 /* If we just set a variable whose current binding is frame-local,
1313 store the new value in the frame parameter too. */
1315 if (BUFFER_LOCAL_VALUEP (valcontents
)
1316 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1318 /* What binding is loaded right now? */
1319 current_alist_element
1320 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1322 /* If the current buffer is not the buffer whose binding is
1323 loaded, or if there may be frame-local bindings and the frame
1324 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1325 the default binding is loaded, the loaded binding may be the
1327 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1328 XSETCDR (current_alist_element
, newval
);
1334 /* Access or set a buffer-local symbol's default value. */
1336 /* Return the default value of SYMBOL, but don't check for voidness.
1337 Return Qunbound if it is void. */
1340 default_value (symbol
)
1343 register Lisp_Object valcontents
;
1345 CHECK_SYMBOL (symbol
);
1346 valcontents
= SYMBOL_VALUE (symbol
);
1348 /* For a built-in buffer-local variable, get the default value
1349 rather than letting do_symval_forwarding get the current value. */
1350 if (BUFFER_OBJFWDP (valcontents
))
1352 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1353 if (PER_BUFFER_IDX (offset
) != 0)
1354 return PER_BUFFER_DEFAULT (offset
);
1357 /* Handle user-created local variables. */
1358 if (BUFFER_LOCAL_VALUEP (valcontents
)
1359 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1361 /* If var is set up for a buffer that lacks a local value for it,
1362 the current value is nominally the default value.
1363 But the `realvalue' slot may be more up to date, since
1364 ordinary setq stores just that slot. So use that. */
1365 Lisp_Object current_alist_element
, alist_element_car
;
1366 current_alist_element
1367 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1368 alist_element_car
= XCAR (current_alist_element
);
1369 if (EQ (alist_element_car
, current_alist_element
))
1370 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1372 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1374 /* For other variables, get the current value. */
1375 return do_symval_forwarding (valcontents
);
1378 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1379 doc
: /* Return t if SYMBOL has a non-void default value.
1380 This is the value that is seen in buffers that do not have their own values
1381 for this variable. */)
1385 register Lisp_Object value
;
1387 value
= default_value (symbol
);
1388 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1391 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1392 doc
: /* Return SYMBOL's default value.
1393 This is the value that is seen in buffers that do not have their own values
1394 for this variable. The default value is meaningful for variables with
1395 local bindings in certain buffers. */)
1399 register Lisp_Object value
;
1401 value
= default_value (symbol
);
1402 if (EQ (value
, Qunbound
))
1403 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1407 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1408 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1409 The default value is seen in buffers that do not have their own values
1410 for this variable. */)
1412 Lisp_Object symbol
, value
;
1414 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1416 CHECK_SYMBOL (symbol
);
1417 valcontents
= SYMBOL_VALUE (symbol
);
1419 /* Handle variables like case-fold-search that have special slots
1420 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1422 if (BUFFER_OBJFWDP (valcontents
))
1424 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1425 int idx
= PER_BUFFER_IDX (offset
);
1427 PER_BUFFER_DEFAULT (offset
) = value
;
1429 /* If this variable is not always local in all buffers,
1430 set it in the buffers that don't nominally have a local value. */
1435 for (b
= all_buffers
; b
; b
= b
->next
)
1436 if (!PER_BUFFER_VALUE_P (b
, idx
))
1437 PER_BUFFER_VALUE (b
, offset
) = value
;
1442 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1443 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1444 return Fset (symbol
, value
);
1446 /* Store new value into the DEFAULT-VALUE slot. */
1447 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1449 /* If the default binding is now loaded, set the REALVALUE slot too. */
1450 current_alist_element
1451 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1452 alist_element_buffer
= Fcar (current_alist_element
);
1453 if (EQ (alist_element_buffer
, current_alist_element
))
1454 store_symval_forwarding (symbol
,
1455 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1461 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1462 doc
: /* Set the default value of variable VAR to VALUE.
1463 VAR, the variable name, is literal (not evaluated);
1464 VALUE is an expression: it is evaluated and its value returned.
1465 The default value of a variable is seen in buffers
1466 that do not have their own values for the variable.
1468 More generally, you can use multiple variables and values, as in
1469 (setq-default VAR VALUE VAR VALUE...)
1470 This sets each VAR's default value to the corresponding VALUE.
1471 The VALUE for the Nth VAR can refer to the new default values
1473 usage: (setq-default VAR VALUE [VAR VALUE...]) */)
1477 register Lisp_Object args_left
;
1478 register Lisp_Object val
, symbol
;
1479 struct gcpro gcpro1
;
1489 val
= Feval (Fcar (Fcdr (args_left
)));
1490 symbol
= XCAR (args_left
);
1491 Fset_default (symbol
, val
);
1492 args_left
= Fcdr (XCDR (args_left
));
1494 while (!NILP (args_left
));
1500 /* Lisp functions for creating and removing buffer-local variables. */
1502 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1503 1, 1, "vMake Variable Buffer Local: ",
1504 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1505 At any time, the value for the current buffer is in effect,
1506 unless the variable has never been set in this buffer,
1507 in which case the default value is in effect.
1508 Note that binding the variable with `let', or setting it while
1509 a `let'-style binding made in this buffer is in effect,
1510 does not make the variable buffer-local. Return VARIABLE.
1512 The function `default-value' gets the default value and `set-default' sets it. */)
1514 register Lisp_Object variable
;
1516 register Lisp_Object tem
, valcontents
, newval
;
1518 CHECK_SYMBOL (variable
);
1519 variable
= indirect_variable (variable
);
1521 valcontents
= SYMBOL_VALUE (variable
);
1522 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1523 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1525 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1527 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1529 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1532 if (EQ (valcontents
, Qunbound
))
1533 SET_SYMBOL_VALUE (variable
, Qnil
);
1534 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1536 newval
= allocate_misc ();
1537 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1538 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1539 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1540 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1541 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1542 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1543 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1544 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1545 SET_SYMBOL_VALUE (variable
, newval
);
1549 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1550 1, 1, "vMake Local Variable: ",
1551 doc
: /* Make VARIABLE have a separate value in the current buffer.
1552 Other buffers will continue to share a common default value.
1553 \(The buffer-local value of VARIABLE starts out as the same value
1554 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1555 See also `make-variable-buffer-local'. Return VARIABLE.
1557 If the variable is already arranged to become local when set,
1558 this function causes a local value to exist for this buffer,
1559 just as setting the variable would do.
1561 This function returns VARIABLE, and therefore
1562 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1565 Do not use `make-local-variable' to make a hook variable buffer-local.
1566 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1568 register Lisp_Object variable
;
1570 register Lisp_Object tem
, valcontents
;
1572 CHECK_SYMBOL (variable
);
1573 variable
= indirect_variable (variable
);
1575 valcontents
= SYMBOL_VALUE (variable
);
1576 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1577 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1579 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1581 tem
= Fboundp (variable
);
1583 /* Make sure the symbol has a local value in this particular buffer,
1584 by setting it to the same value it already has. */
1585 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1588 /* Make sure symbol is set up to hold per-buffer values. */
1589 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1592 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1594 newval
= allocate_misc ();
1595 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1596 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1597 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1598 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1599 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1600 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1601 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1602 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1603 SET_SYMBOL_VALUE (variable
, newval
);;
1605 /* Make sure this buffer has its own value of symbol. */
1606 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1609 /* Swap out any local binding for some other buffer, and make
1610 sure the current value is permanently recorded, if it's the
1612 find_symbol_value (variable
);
1614 current_buffer
->local_var_alist
1615 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1616 current_buffer
->local_var_alist
);
1618 /* Make sure symbol does not think it is set up for this buffer;
1619 force it to look once again for this buffer's value. */
1621 Lisp_Object
*pvalbuf
;
1623 valcontents
= SYMBOL_VALUE (variable
);
1625 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1626 if (current_buffer
== XBUFFER (*pvalbuf
))
1628 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1632 /* If the symbol forwards into a C variable, then load the binding
1633 for this buffer now. If C code modifies the variable before we
1634 load the binding in, then that new value will clobber the default
1635 binding the next time we unload it. */
1636 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1637 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1638 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1643 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1644 1, 1, "vKill Local Variable: ",
1645 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1646 From now on the default value will apply in this buffer. Return VARIABLE. */)
1648 register Lisp_Object variable
;
1650 register Lisp_Object tem
, valcontents
;
1652 CHECK_SYMBOL (variable
);
1653 variable
= indirect_variable (variable
);
1655 valcontents
= SYMBOL_VALUE (variable
);
1657 if (BUFFER_OBJFWDP (valcontents
))
1659 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1660 int idx
= PER_BUFFER_IDX (offset
);
1664 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1665 PER_BUFFER_VALUE (current_buffer
, offset
)
1666 = PER_BUFFER_DEFAULT (offset
);
1671 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1672 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1675 /* Get rid of this buffer's alist element, if any. */
1677 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1679 current_buffer
->local_var_alist
1680 = Fdelq (tem
, current_buffer
->local_var_alist
);
1682 /* If the symbol is set up with the current buffer's binding
1683 loaded, recompute its value. We have to do it now, or else
1684 forwarded objects won't work right. */
1686 Lisp_Object
*pvalbuf
, buf
;
1687 valcontents
= SYMBOL_VALUE (variable
);
1688 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1689 XSETBUFFER (buf
, current_buffer
);
1690 if (EQ (buf
, *pvalbuf
))
1693 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1694 find_symbol_value (variable
);
1701 /* Lisp functions for creating and removing buffer-local variables. */
1703 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1704 1, 1, "vMake Variable Frame Local: ",
1705 doc
: /* Enable VARIABLE to have frame-local bindings.
1706 When a frame-local binding exists in the current frame,
1707 it is in effect whenever the current buffer has no buffer-local binding.
1708 A frame-local binding is actually a frame parameter value;
1709 thus, any given frame has a local binding for VARIABLE if it has
1710 a value for the frame parameter named VARIABLE. Return VARIABLE.
1711 See `modify-frame-parameters' for how to set frame parameters. */)
1713 register Lisp_Object variable
;
1715 register Lisp_Object tem
, valcontents
, newval
;
1717 CHECK_SYMBOL (variable
);
1718 variable
= indirect_variable (variable
);
1720 valcontents
= SYMBOL_VALUE (variable
);
1721 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1722 || BUFFER_OBJFWDP (valcontents
))
1723 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1725 if (BUFFER_LOCAL_VALUEP (valcontents
)
1726 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1728 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1732 if (EQ (valcontents
, Qunbound
))
1733 SET_SYMBOL_VALUE (variable
, Qnil
);
1734 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1736 newval
= allocate_misc ();
1737 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1738 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1739 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1740 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1741 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1742 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1743 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1744 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1745 SET_SYMBOL_VALUE (variable
, newval
);
1749 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1751 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1752 BUFFER defaults to the current buffer. */)
1754 register Lisp_Object variable
, buffer
;
1756 Lisp_Object valcontents
;
1757 register struct buffer
*buf
;
1760 buf
= current_buffer
;
1763 CHECK_BUFFER (buffer
);
1764 buf
= XBUFFER (buffer
);
1767 CHECK_SYMBOL (variable
);
1768 variable
= indirect_variable (variable
);
1770 valcontents
= SYMBOL_VALUE (variable
);
1771 if (BUFFER_LOCAL_VALUEP (valcontents
)
1772 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1774 Lisp_Object tail
, elt
;
1776 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1779 if (EQ (variable
, XCAR (elt
)))
1783 if (BUFFER_OBJFWDP (valcontents
))
1785 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1786 int idx
= PER_BUFFER_IDX (offset
);
1787 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1793 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1795 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1796 More precisely, this means that setting the variable \(with `set' or`setq'),
1797 while it does not have a `let'-style binding that was made in BUFFER,
1798 will produce a buffer local binding. See Info node
1799 `(elisp)Creating Buffer-Local'.
1800 BUFFER defaults to the current buffer. */)
1802 register Lisp_Object variable
, buffer
;
1804 Lisp_Object valcontents
;
1805 register struct buffer
*buf
;
1808 buf
= current_buffer
;
1811 CHECK_BUFFER (buffer
);
1812 buf
= XBUFFER (buffer
);
1815 CHECK_SYMBOL (variable
);
1816 variable
= indirect_variable (variable
);
1818 valcontents
= SYMBOL_VALUE (variable
);
1820 /* This means that make-variable-buffer-local was done. */
1821 if (BUFFER_LOCAL_VALUEP (valcontents
))
1823 /* All these slots become local if they are set. */
1824 if (BUFFER_OBJFWDP (valcontents
))
1826 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1828 Lisp_Object tail
, elt
;
1829 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1832 if (EQ (variable
, XCAR (elt
)))
1839 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1841 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1842 If the current binding is buffer-local, the value is the current buffer.
1843 If the current binding is frame-local, the value is the selected frame.
1844 If the current binding is global (the default), the value is nil. */)
1846 register Lisp_Object variable
;
1848 Lisp_Object valcontents
;
1850 CHECK_SYMBOL (variable
);
1851 variable
= indirect_variable (variable
);
1853 /* Make sure the current binding is actually swapped in. */
1854 find_symbol_value (variable
);
1856 valcontents
= XSYMBOL (variable
)->value
;
1858 if (BUFFER_LOCAL_VALUEP (valcontents
)
1859 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1860 || BUFFER_OBJFWDP (valcontents
))
1862 /* For a local variable, record both the symbol and which
1863 buffer's or frame's value we are saving. */
1864 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1865 return Fcurrent_buffer ();
1866 else if (!BUFFER_OBJFWDP (valcontents
)
1867 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1868 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1874 /* Find the function at the end of a chain of symbol function indirections. */
1876 /* If OBJECT is a symbol, find the end of its function chain and
1877 return the value found there. If OBJECT is not a symbol, just
1878 return it. If there is a cycle in the function chain, signal a
1879 cyclic-function-indirection error.
1881 This is like Findirect_function, except that it doesn't signal an
1882 error if the chain ends up unbound. */
1884 indirect_function (object
)
1885 register Lisp_Object object
;
1887 Lisp_Object tortoise
, hare
;
1889 hare
= tortoise
= object
;
1893 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1895 hare
= XSYMBOL (hare
)->function
;
1896 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1898 hare
= XSYMBOL (hare
)->function
;
1900 tortoise
= XSYMBOL (tortoise
)->function
;
1902 if (EQ (hare
, tortoise
))
1903 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1909 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1910 doc
: /* Return the function at the end of OBJECT's function chain.
1911 If OBJECT is a symbol, follow all function indirections and return the final
1913 If OBJECT is not a symbol, just return it.
1914 Signal a void-function error if the final symbol is unbound.
1915 Signal a cyclic-function-indirection error if there is a loop in the
1916 function chain of symbols. */)
1918 register Lisp_Object object
;
1922 result
= indirect_function (object
);
1924 if (EQ (result
, Qunbound
))
1925 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1929 /* Extract and set vector and string elements */
1931 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1932 doc
: /* Return the element of ARRAY at index IDX.
1933 ARRAY may be a vector, a string, a char-table, a bool-vector,
1934 or a byte-code object. IDX starts at 0. */)
1936 register Lisp_Object array
;
1939 register int idxval
;
1942 idxval
= XINT (idx
);
1943 if (STRINGP (array
))
1947 if (idxval
< 0 || idxval
>= SCHARS (array
))
1948 args_out_of_range (array
, idx
);
1949 if (! STRING_MULTIBYTE (array
))
1950 return make_number ((unsigned char) SREF (array
, idxval
));
1951 idxval_byte
= string_char_to_byte (array
, idxval
);
1953 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1954 SBYTES (array
) - idxval_byte
);
1955 return make_number (c
);
1957 else if (BOOL_VECTOR_P (array
))
1961 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1962 args_out_of_range (array
, idx
);
1964 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1965 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1967 else if (CHAR_TABLE_P (array
))
1974 args_out_of_range (array
, idx
);
1975 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1977 /* For ASCII and 8-bit European characters, the element is
1978 stored in the top table. */
1979 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1981 val
= XCHAR_TABLE (array
)->defalt
;
1982 while (NILP (val
)) /* Follow parents until we find some value. */
1984 array
= XCHAR_TABLE (array
)->parent
;
1987 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1989 val
= XCHAR_TABLE (array
)->defalt
;
1996 Lisp_Object sub_table
;
1998 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
1999 if (code
[1] < 32) code
[1] = -1;
2000 else if (code
[2] < 32) code
[2] = -1;
2002 /* Here, the possible range of CODE[0] (== charset ID) is
2003 128..MAX_CHARSET. Since the top level char table contains
2004 data for multibyte characters after 256th element, we must
2005 increment CODE[0] by 128 to get a correct index. */
2007 code
[3] = -1; /* anchor */
2009 try_parent_char_table
:
2011 for (i
= 0; code
[i
] >= 0; i
++)
2013 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2014 if (SUB_CHAR_TABLE_P (val
))
2019 val
= XCHAR_TABLE (sub_table
)->defalt
;
2022 array
= XCHAR_TABLE (array
)->parent
;
2024 goto try_parent_char_table
;
2029 /* Here, VAL is a sub char table. We try the default value
2031 val
= XCHAR_TABLE (val
)->defalt
;
2034 array
= XCHAR_TABLE (array
)->parent
;
2036 goto try_parent_char_table
;
2044 if (VECTORP (array
))
2045 size
= XVECTOR (array
)->size
;
2046 else if (COMPILEDP (array
))
2047 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2049 wrong_type_argument (Qarrayp
, array
);
2051 if (idxval
< 0 || idxval
>= size
)
2052 args_out_of_range (array
, idx
);
2053 return XVECTOR (array
)->contents
[idxval
];
2057 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2058 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2059 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2060 bool-vector. IDX starts at 0. */)
2061 (array
, idx
, newelt
)
2062 register Lisp_Object array
;
2063 Lisp_Object idx
, newelt
;
2065 register int idxval
;
2068 idxval
= XINT (idx
);
2069 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2070 && ! CHAR_TABLE_P (array
))
2071 array
= wrong_type_argument (Qarrayp
, array
);
2072 CHECK_IMPURE (array
);
2074 if (VECTORP (array
))
2076 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2077 args_out_of_range (array
, idx
);
2078 XVECTOR (array
)->contents
[idxval
] = newelt
;
2080 else if (BOOL_VECTOR_P (array
))
2084 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2085 args_out_of_range (array
, idx
);
2087 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2089 if (! NILP (newelt
))
2090 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2092 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2093 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2095 else if (CHAR_TABLE_P (array
))
2098 args_out_of_range (array
, idx
);
2099 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2100 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2106 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2107 if (code
[1] < 32) code
[1] = -1;
2108 else if (code
[2] < 32) code
[2] = -1;
2110 /* See the comment of the corresponding part in Faref. */
2112 code
[3] = -1; /* anchor */
2113 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2115 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2116 if (SUB_CHAR_TABLE_P (val
))
2122 /* VAL is a leaf. Create a sub char table with the
2123 default value VAL or XCHAR_TABLE (array)->defalt
2124 and look into it. */
2126 temp
= make_sub_char_table (NILP (val
)
2127 ? XCHAR_TABLE (array
)->defalt
2129 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2133 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2136 else if (STRING_MULTIBYTE (array
))
2138 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2139 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2141 if (idxval
< 0 || idxval
>= SCHARS (array
))
2142 args_out_of_range (array
, idx
);
2143 CHECK_NUMBER (newelt
);
2145 nbytes
= SBYTES (array
);
2147 idxval_byte
= string_char_to_byte (array
, idxval
);
2148 p1
= SDATA (array
) + idxval_byte
;
2149 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2150 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2151 if (prev_bytes
!= new_bytes
)
2153 /* We must relocate the string data. */
2154 int nchars
= SCHARS (array
);
2158 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2159 bcopy (SDATA (array
), str
, nbytes
);
2160 allocate_string_data (XSTRING (array
), nchars
,
2161 nbytes
+ new_bytes
- prev_bytes
);
2162 bcopy (str
, SDATA (array
), idxval_byte
);
2163 p1
= SDATA (array
) + idxval_byte
;
2164 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2165 nbytes
- (idxval_byte
+ prev_bytes
));
2167 clear_string_char_byte_cache ();
2174 if (idxval
< 0 || idxval
>= SCHARS (array
))
2175 args_out_of_range (array
, idx
);
2176 CHECK_NUMBER (newelt
);
2178 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2179 SSET (array
, idxval
, XINT (newelt
));
2182 /* We must relocate the string data while converting it to
2184 int idxval_byte
, prev_bytes
, new_bytes
;
2185 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2186 unsigned char *origstr
= SDATA (array
), *str
;
2190 nchars
= SCHARS (array
);
2191 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2192 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2194 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2195 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2196 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2198 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2199 allocate_string_data (XSTRING (array
), nchars
,
2200 nbytes
+ new_bytes
- prev_bytes
);
2201 bcopy (str
, SDATA (array
), idxval_byte
);
2202 p1
= SDATA (array
) + idxval_byte
;
2205 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2206 nbytes
- (idxval_byte
+ prev_bytes
));
2208 clear_string_char_byte_cache ();
2215 /* Arithmetic functions */
2217 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2220 arithcompare (num1
, num2
, comparison
)
2221 Lisp_Object num1
, num2
;
2222 enum comparison comparison
;
2224 double f1
= 0, f2
= 0;
2227 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2228 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2230 if (FLOATP (num1
) || FLOATP (num2
))
2233 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2234 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2240 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2245 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2250 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2255 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2260 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2265 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2274 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2275 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2277 register Lisp_Object num1
, num2
;
2279 return arithcompare (num1
, num2
, equal
);
2282 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2283 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2285 register Lisp_Object num1
, num2
;
2287 return arithcompare (num1
, num2
, less
);
2290 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2291 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2293 register Lisp_Object num1
, num2
;
2295 return arithcompare (num1
, num2
, grtr
);
2298 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2299 doc
: /* Return t if first arg is less than or equal to second arg.
2300 Both must be numbers or markers. */)
2302 register Lisp_Object num1
, num2
;
2304 return arithcompare (num1
, num2
, less_or_equal
);
2307 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2308 doc
: /* Return t if first arg is greater than or equal to second arg.
2309 Both must be numbers or markers. */)
2311 register Lisp_Object num1
, num2
;
2313 return arithcompare (num1
, num2
, grtr_or_equal
);
2316 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2317 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2319 register Lisp_Object num1
, num2
;
2321 return arithcompare (num1
, num2
, notequal
);
2324 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2325 doc
: /* Return t if NUMBER is zero. */)
2327 register Lisp_Object number
;
2329 CHECK_NUMBER_OR_FLOAT (number
);
2331 if (FLOATP (number
))
2333 if (XFLOAT_DATA (number
) == 0.0)
2343 /* Convert between long values and pairs of Lisp integers. */
2349 unsigned long top
= i
>> 16;
2350 unsigned int bot
= i
& 0xFFFF;
2352 return make_number (bot
);
2353 if (top
== (unsigned long)-1 >> 16)
2354 return Fcons (make_number (-1), make_number (bot
));
2355 return Fcons (make_number (top
), make_number (bot
));
2362 Lisp_Object top
, bot
;
2369 return ((XINT (top
) << 16) | XINT (bot
));
2372 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2373 doc
: /* Return the decimal representation of NUMBER as a string.
2374 Uses a minus sign if negative.
2375 NUMBER may be an integer or a floating point number. */)
2379 char buffer
[VALBITS
];
2381 CHECK_NUMBER_OR_FLOAT (number
);
2383 if (FLOATP (number
))
2385 char pigbuf
[350]; /* see comments in float_to_string */
2387 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2388 return build_string (pigbuf
);
2391 if (sizeof (int) == sizeof (EMACS_INT
))
2392 sprintf (buffer
, "%d", XINT (number
));
2393 else if (sizeof (long) == sizeof (EMACS_INT
))
2394 sprintf (buffer
, "%ld", (long) XINT (number
));
2397 return build_string (buffer
);
2401 digit_to_number (character
, base
)
2402 int character
, base
;
2406 if (character
>= '0' && character
<= '9')
2407 digit
= character
- '0';
2408 else if (character
>= 'a' && character
<= 'z')
2409 digit
= character
- 'a' + 10;
2410 else if (character
>= 'A' && character
<= 'Z')
2411 digit
= character
- 'A' + 10;
2421 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2422 doc
: /* Parse STRING as a decimal number and return the number.
2423 This parses both integers and floating point numbers.
2424 It ignores leading spaces and tabs.
2426 If BASE, interpret STRING as a number in that base. If BASE isn't
2427 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2428 If the base used is not 10, floating point is not recognized. */)
2430 register Lisp_Object string
, base
;
2432 register unsigned char *p
;
2437 CHECK_STRING (string
);
2443 CHECK_NUMBER (base
);
2445 if (b
< 2 || b
> 16)
2446 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2449 /* Skip any whitespace at the front of the number. Some versions of
2450 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2452 while (*p
== ' ' || *p
== '\t')
2463 if (isfloat_string (p
) && b
== 10)
2464 val
= make_float (sign
* atof (p
));
2471 int digit
= digit_to_number (*p
++, b
);
2477 val
= make_fixnum_or_float (sign
* v
);
2497 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2498 int, Lisp_Object
*));
2499 extern Lisp_Object
fmod_float ();
2502 arith_driver (code
, nargs
, args
)
2505 register Lisp_Object
*args
;
2507 register Lisp_Object val
;
2508 register int argnum
;
2509 register EMACS_INT accum
= 0;
2510 register EMACS_INT next
;
2512 switch (SWITCH_ENUM_CAST (code
))
2530 for (argnum
= 0; argnum
< nargs
; argnum
++)
2532 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2534 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2537 return float_arith_driver ((double) accum
, argnum
, code
,
2540 next
= XINT (args
[argnum
]);
2541 switch (SWITCH_ENUM_CAST (code
))
2547 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2558 Fsignal (Qarith_error
, Qnil
);
2572 if (!argnum
|| next
> accum
)
2576 if (!argnum
|| next
< accum
)
2582 XSETINT (val
, accum
);
2587 #define isnan(x) ((x) != (x))
2590 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2592 register int argnum
;
2595 register Lisp_Object
*args
;
2597 register Lisp_Object val
;
2600 for (; argnum
< nargs
; argnum
++)
2602 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2603 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2607 next
= XFLOAT_DATA (val
);
2611 args
[argnum
] = val
; /* runs into a compiler bug. */
2612 next
= XINT (args
[argnum
]);
2614 switch (SWITCH_ENUM_CAST (code
))
2620 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2630 if (! IEEE_FLOATING_POINT
&& next
== 0)
2631 Fsignal (Qarith_error
, Qnil
);
2638 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2640 if (!argnum
|| isnan (next
) || next
> accum
)
2644 if (!argnum
|| isnan (next
) || next
< accum
)
2650 return make_float (accum
);
2654 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2655 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2656 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2661 return arith_driver (Aadd
, nargs
, args
);
2664 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2665 doc
: /* Negate number or subtract numbers or markers and return the result.
2666 With one arg, negates it. With more than one arg,
2667 subtracts all but the first from the first.
2668 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2673 return arith_driver (Asub
, nargs
, args
);
2676 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2677 doc
: /* Return product of any number of arguments, which are numbers or markers.
2678 usage: (* &rest NUMBERS-OR-MARKERS) */)
2683 return arith_driver (Amult
, nargs
, args
);
2686 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2687 doc
: /* Return first argument divided by all the remaining arguments.
2688 The arguments must be numbers or markers.
2689 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2695 for (argnum
= 2; argnum
< nargs
; argnum
++)
2696 if (FLOATP (args
[argnum
]))
2697 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2698 return arith_driver (Adiv
, nargs
, args
);
2701 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2702 doc
: /* Return remainder of X divided by Y.
2703 Both must be integers or markers. */)
2705 register Lisp_Object x
, y
;
2709 CHECK_NUMBER_COERCE_MARKER (x
);
2710 CHECK_NUMBER_COERCE_MARKER (y
);
2712 if (XFASTINT (y
) == 0)
2713 Fsignal (Qarith_error
, Qnil
);
2715 XSETINT (val
, XINT (x
) % XINT (y
));
2729 /* If the magnitude of the result exceeds that of the divisor, or
2730 the sign of the result does not agree with that of the dividend,
2731 iterate with the reduced value. This does not yield a
2732 particularly accurate result, but at least it will be in the
2733 range promised by fmod. */
2735 r
-= f2
* floor (r
/ f2
);
2736 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2740 #endif /* ! HAVE_FMOD */
2742 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2743 doc
: /* Return X modulo Y.
2744 The result falls between zero (inclusive) and Y (exclusive).
2745 Both X and Y must be numbers or markers. */)
2747 register Lisp_Object x
, y
;
2752 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2753 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2755 if (FLOATP (x
) || FLOATP (y
))
2756 return fmod_float (x
, y
);
2762 Fsignal (Qarith_error
, Qnil
);
2766 /* If the "remainder" comes out with the wrong sign, fix it. */
2767 if (i2
< 0 ? i1
> 0 : i1
< 0)
2774 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2775 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2776 The value is always a number; markers are converted to numbers.
2777 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2782 return arith_driver (Amax
, nargs
, args
);
2785 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2786 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2787 The value is always a number; markers are converted to numbers.
2788 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2793 return arith_driver (Amin
, nargs
, args
);
2796 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2797 doc
: /* Return bitwise-and of all the arguments.
2798 Arguments may be integers, or markers converted to integers.
2799 usage: (logand &rest INTS-OR-MARKERS) */)
2804 return arith_driver (Alogand
, nargs
, args
);
2807 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2808 doc
: /* Return bitwise-or of all the arguments.
2809 Arguments may be integers, or markers converted to integers.
2810 usage: (logior &rest INTS-OR-MARKERS) */)
2815 return arith_driver (Alogior
, nargs
, args
);
2818 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2819 doc
: /* Return bitwise-exclusive-or of all the arguments.
2820 Arguments may be integers, or markers converted to integers.
2821 usage: (logxor &rest INTS-OR-MARKERS) */)
2826 return arith_driver (Alogxor
, nargs
, args
);
2829 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2830 doc
: /* Return VALUE with its bits shifted left by COUNT.
2831 If COUNT is negative, shifting is actually to the right.
2832 In this case, the sign bit is duplicated. */)
2834 register Lisp_Object value
, count
;
2836 register Lisp_Object val
;
2838 CHECK_NUMBER (value
);
2839 CHECK_NUMBER (count
);
2841 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2843 else if (XINT (count
) > 0)
2844 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2845 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2846 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2848 XSETINT (val
, XINT (value
) >> -XINT (count
));
2852 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2853 doc
: /* Return VALUE with its bits shifted left by COUNT.
2854 If COUNT is negative, shifting is actually to the right.
2855 In this case, zeros are shifted in on the left. */)
2857 register Lisp_Object value
, count
;
2859 register Lisp_Object val
;
2861 CHECK_NUMBER (value
);
2862 CHECK_NUMBER (count
);
2864 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2866 else if (XINT (count
) > 0)
2867 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2868 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2871 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2875 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2876 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2877 Markers are converted to integers. */)
2879 register Lisp_Object number
;
2881 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2883 if (FLOATP (number
))
2884 return (make_float (1.0 + XFLOAT_DATA (number
)));
2886 XSETINT (number
, XINT (number
) + 1);
2890 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2891 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2892 Markers are converted to integers. */)
2894 register Lisp_Object number
;
2896 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2898 if (FLOATP (number
))
2899 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2901 XSETINT (number
, XINT (number
) - 1);
2905 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2906 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2908 register Lisp_Object number
;
2910 CHECK_NUMBER (number
);
2911 XSETINT (number
, ~XINT (number
));
2915 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2916 doc
: /* Return the byteorder for the machine.
2917 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2918 lowercase l) for small endian machines. */)
2921 unsigned i
= 0x04030201;
2922 int order
= *(char *)&i
== 1 ? 108 : 66;
2924 return make_number (order
);
2932 Lisp_Object error_tail
, arith_tail
;
2934 Qquote
= intern ("quote");
2935 Qlambda
= intern ("lambda");
2936 Qsubr
= intern ("subr");
2937 Qerror_conditions
= intern ("error-conditions");
2938 Qerror_message
= intern ("error-message");
2939 Qtop_level
= intern ("top-level");
2941 Qerror
= intern ("error");
2942 Qquit
= intern ("quit");
2943 Qwrong_type_argument
= intern ("wrong-type-argument");
2944 Qargs_out_of_range
= intern ("args-out-of-range");
2945 Qvoid_function
= intern ("void-function");
2946 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2947 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2948 Qvoid_variable
= intern ("void-variable");
2949 Qsetting_constant
= intern ("setting-constant");
2950 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2952 Qinvalid_function
= intern ("invalid-function");
2953 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2954 Qno_catch
= intern ("no-catch");
2955 Qend_of_file
= intern ("end-of-file");
2956 Qarith_error
= intern ("arith-error");
2957 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2958 Qend_of_buffer
= intern ("end-of-buffer");
2959 Qbuffer_read_only
= intern ("buffer-read-only");
2960 Qtext_read_only
= intern ("text-read-only");
2961 Qmark_inactive
= intern ("mark-inactive");
2963 Qlistp
= intern ("listp");
2964 Qconsp
= intern ("consp");
2965 Qsymbolp
= intern ("symbolp");
2966 Qkeywordp
= intern ("keywordp");
2967 Qintegerp
= intern ("integerp");
2968 Qnatnump
= intern ("natnump");
2969 Qwholenump
= intern ("wholenump");
2970 Qstringp
= intern ("stringp");
2971 Qarrayp
= intern ("arrayp");
2972 Qsequencep
= intern ("sequencep");
2973 Qbufferp
= intern ("bufferp");
2974 Qvectorp
= intern ("vectorp");
2975 Qchar_or_string_p
= intern ("char-or-string-p");
2976 Qmarkerp
= intern ("markerp");
2977 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2978 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2979 Qboundp
= intern ("boundp");
2980 Qfboundp
= intern ("fboundp");
2982 Qfloatp
= intern ("floatp");
2983 Qnumberp
= intern ("numberp");
2984 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2986 Qchar_table_p
= intern ("char-table-p");
2987 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2989 Qsubrp
= intern ("subrp");
2990 Qunevalled
= intern ("unevalled");
2991 Qmany
= intern ("many");
2993 Qcdr
= intern ("cdr");
2995 /* Handle automatic advice activation */
2996 Qad_advice_info
= intern ("ad-advice-info");
2997 Qad_activate_internal
= intern ("ad-activate-internal");
2999 error_tail
= Fcons (Qerror
, Qnil
);
3001 /* ERROR is used as a signaler for random errors for which nothing else is right */
3003 Fput (Qerror
, Qerror_conditions
,
3005 Fput (Qerror
, Qerror_message
,
3006 build_string ("error"));
3008 Fput (Qquit
, Qerror_conditions
,
3009 Fcons (Qquit
, Qnil
));
3010 Fput (Qquit
, Qerror_message
,
3011 build_string ("Quit"));
3013 Fput (Qwrong_type_argument
, Qerror_conditions
,
3014 Fcons (Qwrong_type_argument
, error_tail
));
3015 Fput (Qwrong_type_argument
, Qerror_message
,
3016 build_string ("Wrong type argument"));
3018 Fput (Qargs_out_of_range
, Qerror_conditions
,
3019 Fcons (Qargs_out_of_range
, error_tail
));
3020 Fput (Qargs_out_of_range
, Qerror_message
,
3021 build_string ("Args out of range"));
3023 Fput (Qvoid_function
, Qerror_conditions
,
3024 Fcons (Qvoid_function
, error_tail
));
3025 Fput (Qvoid_function
, Qerror_message
,
3026 build_string ("Symbol's function definition is void"));
3028 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3029 Fcons (Qcyclic_function_indirection
, error_tail
));
3030 Fput (Qcyclic_function_indirection
, Qerror_message
,
3031 build_string ("Symbol's chain of function indirections contains a loop"));
3033 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3034 Fcons (Qcyclic_variable_indirection
, error_tail
));
3035 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3036 build_string ("Symbol's chain of variable indirections contains a loop"));
3038 Qcircular_list
= intern ("circular-list");
3039 staticpro (&Qcircular_list
);
3040 Fput (Qcircular_list
, Qerror_conditions
,
3041 Fcons (Qcircular_list
, error_tail
));
3042 Fput (Qcircular_list
, Qerror_message
,
3043 build_string ("List contains a loop"));
3045 Fput (Qvoid_variable
, Qerror_conditions
,
3046 Fcons (Qvoid_variable
, error_tail
));
3047 Fput (Qvoid_variable
, Qerror_message
,
3048 build_string ("Symbol's value as variable is void"));
3050 Fput (Qsetting_constant
, Qerror_conditions
,
3051 Fcons (Qsetting_constant
, error_tail
));
3052 Fput (Qsetting_constant
, Qerror_message
,
3053 build_string ("Attempt to set a constant symbol"));
3055 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3056 Fcons (Qinvalid_read_syntax
, error_tail
));
3057 Fput (Qinvalid_read_syntax
, Qerror_message
,
3058 build_string ("Invalid read syntax"));
3060 Fput (Qinvalid_function
, Qerror_conditions
,
3061 Fcons (Qinvalid_function
, error_tail
));
3062 Fput (Qinvalid_function
, Qerror_message
,
3063 build_string ("Invalid function"));
3065 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3066 Fcons (Qwrong_number_of_arguments
, error_tail
));
3067 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3068 build_string ("Wrong number of arguments"));
3070 Fput (Qno_catch
, Qerror_conditions
,
3071 Fcons (Qno_catch
, error_tail
));
3072 Fput (Qno_catch
, Qerror_message
,
3073 build_string ("No catch for tag"));
3075 Fput (Qend_of_file
, Qerror_conditions
,
3076 Fcons (Qend_of_file
, error_tail
));
3077 Fput (Qend_of_file
, Qerror_message
,
3078 build_string ("End of file during parsing"));
3080 arith_tail
= Fcons (Qarith_error
, error_tail
);
3081 Fput (Qarith_error
, Qerror_conditions
,
3083 Fput (Qarith_error
, Qerror_message
,
3084 build_string ("Arithmetic error"));
3086 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3087 Fcons (Qbeginning_of_buffer
, error_tail
));
3088 Fput (Qbeginning_of_buffer
, Qerror_message
,
3089 build_string ("Beginning of buffer"));
3091 Fput (Qend_of_buffer
, Qerror_conditions
,
3092 Fcons (Qend_of_buffer
, error_tail
));
3093 Fput (Qend_of_buffer
, Qerror_message
,
3094 build_string ("End of buffer"));
3096 Fput (Qbuffer_read_only
, Qerror_conditions
,
3097 Fcons (Qbuffer_read_only
, error_tail
));
3098 Fput (Qbuffer_read_only
, Qerror_message
,
3099 build_string ("Buffer is read-only"));
3101 Fput (Qtext_read_only
, Qerror_conditions
,
3102 Fcons (Qtext_read_only
, error_tail
));
3103 Fput (Qtext_read_only
, Qerror_message
,
3104 build_string ("Text is read-only"));
3106 Qrange_error
= intern ("range-error");
3107 Qdomain_error
= intern ("domain-error");
3108 Qsingularity_error
= intern ("singularity-error");
3109 Qoverflow_error
= intern ("overflow-error");
3110 Qunderflow_error
= intern ("underflow-error");
3112 Fput (Qdomain_error
, Qerror_conditions
,
3113 Fcons (Qdomain_error
, arith_tail
));
3114 Fput (Qdomain_error
, Qerror_message
,
3115 build_string ("Arithmetic domain error"));
3117 Fput (Qrange_error
, Qerror_conditions
,
3118 Fcons (Qrange_error
, arith_tail
));
3119 Fput (Qrange_error
, Qerror_message
,
3120 build_string ("Arithmetic range error"));
3122 Fput (Qsingularity_error
, Qerror_conditions
,
3123 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3124 Fput (Qsingularity_error
, Qerror_message
,
3125 build_string ("Arithmetic singularity error"));
3127 Fput (Qoverflow_error
, Qerror_conditions
,
3128 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3129 Fput (Qoverflow_error
, Qerror_message
,
3130 build_string ("Arithmetic overflow error"));
3132 Fput (Qunderflow_error
, Qerror_conditions
,
3133 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3134 Fput (Qunderflow_error
, Qerror_message
,
3135 build_string ("Arithmetic underflow error"));
3137 staticpro (&Qrange_error
);
3138 staticpro (&Qdomain_error
);
3139 staticpro (&Qsingularity_error
);
3140 staticpro (&Qoverflow_error
);
3141 staticpro (&Qunderflow_error
);
3145 staticpro (&Qquote
);
3146 staticpro (&Qlambda
);
3148 staticpro (&Qunbound
);
3149 staticpro (&Qerror_conditions
);
3150 staticpro (&Qerror_message
);
3151 staticpro (&Qtop_level
);
3153 staticpro (&Qerror
);
3155 staticpro (&Qwrong_type_argument
);
3156 staticpro (&Qargs_out_of_range
);
3157 staticpro (&Qvoid_function
);
3158 staticpro (&Qcyclic_function_indirection
);
3159 staticpro (&Qvoid_variable
);
3160 staticpro (&Qsetting_constant
);
3161 staticpro (&Qinvalid_read_syntax
);
3162 staticpro (&Qwrong_number_of_arguments
);
3163 staticpro (&Qinvalid_function
);
3164 staticpro (&Qno_catch
);
3165 staticpro (&Qend_of_file
);
3166 staticpro (&Qarith_error
);
3167 staticpro (&Qbeginning_of_buffer
);
3168 staticpro (&Qend_of_buffer
);
3169 staticpro (&Qbuffer_read_only
);
3170 staticpro (&Qtext_read_only
);
3171 staticpro (&Qmark_inactive
);
3173 staticpro (&Qlistp
);
3174 staticpro (&Qconsp
);
3175 staticpro (&Qsymbolp
);
3176 staticpro (&Qkeywordp
);
3177 staticpro (&Qintegerp
);
3178 staticpro (&Qnatnump
);
3179 staticpro (&Qwholenump
);
3180 staticpro (&Qstringp
);
3181 staticpro (&Qarrayp
);
3182 staticpro (&Qsequencep
);
3183 staticpro (&Qbufferp
);
3184 staticpro (&Qvectorp
);
3185 staticpro (&Qchar_or_string_p
);
3186 staticpro (&Qmarkerp
);
3187 staticpro (&Qbuffer_or_string_p
);
3188 staticpro (&Qinteger_or_marker_p
);
3189 staticpro (&Qfloatp
);
3190 staticpro (&Qnumberp
);
3191 staticpro (&Qnumber_or_marker_p
);
3192 staticpro (&Qchar_table_p
);
3193 staticpro (&Qvector_or_char_table_p
);
3194 staticpro (&Qsubrp
);
3196 staticpro (&Qunevalled
);
3198 staticpro (&Qboundp
);
3199 staticpro (&Qfboundp
);
3201 staticpro (&Qad_advice_info
);
3202 staticpro (&Qad_activate_internal
);
3204 /* Types that type-of returns. */
3205 Qinteger
= intern ("integer");
3206 Qsymbol
= intern ("symbol");
3207 Qstring
= intern ("string");
3208 Qcons
= intern ("cons");
3209 Qmarker
= intern ("marker");
3210 Qoverlay
= intern ("overlay");
3211 Qfloat
= intern ("float");
3212 Qwindow_configuration
= intern ("window-configuration");
3213 Qprocess
= intern ("process");
3214 Qwindow
= intern ("window");
3215 /* Qsubr = intern ("subr"); */
3216 Qcompiled_function
= intern ("compiled-function");
3217 Qbuffer
= intern ("buffer");
3218 Qframe
= intern ("frame");
3219 Qvector
= intern ("vector");
3220 Qchar_table
= intern ("char-table");
3221 Qbool_vector
= intern ("bool-vector");
3222 Qhash_table
= intern ("hash-table");
3224 staticpro (&Qinteger
);
3225 staticpro (&Qsymbol
);
3226 staticpro (&Qstring
);
3228 staticpro (&Qmarker
);
3229 staticpro (&Qoverlay
);
3230 staticpro (&Qfloat
);
3231 staticpro (&Qwindow_configuration
);
3232 staticpro (&Qprocess
);
3233 staticpro (&Qwindow
);
3234 /* staticpro (&Qsubr); */
3235 staticpro (&Qcompiled_function
);
3236 staticpro (&Qbuffer
);
3237 staticpro (&Qframe
);
3238 staticpro (&Qvector
);
3239 staticpro (&Qchar_table
);
3240 staticpro (&Qbool_vector
);
3241 staticpro (&Qhash_table
);
3243 defsubr (&Sindirect_variable
);
3244 defsubr (&Sinteractive_form
);
3247 defsubr (&Stype_of
);
3252 defsubr (&Sintegerp
);
3253 defsubr (&Sinteger_or_marker_p
);
3254 defsubr (&Snumberp
);
3255 defsubr (&Snumber_or_marker_p
);
3257 defsubr (&Snatnump
);
3258 defsubr (&Ssymbolp
);
3259 defsubr (&Skeywordp
);
3260 defsubr (&Sstringp
);
3261 defsubr (&Smultibyte_string_p
);
3262 defsubr (&Svectorp
);
3263 defsubr (&Schar_table_p
);
3264 defsubr (&Svector_or_char_table_p
);
3265 defsubr (&Sbool_vector_p
);
3267 defsubr (&Ssequencep
);
3268 defsubr (&Sbufferp
);
3269 defsubr (&Smarkerp
);
3271 defsubr (&Sbyte_code_function_p
);
3272 defsubr (&Schar_or_string_p
);
3275 defsubr (&Scar_safe
);
3276 defsubr (&Scdr_safe
);
3279 defsubr (&Ssymbol_function
);
3280 defsubr (&Sindirect_function
);
3281 defsubr (&Ssymbol_plist
);
3282 defsubr (&Ssymbol_name
);
3283 defsubr (&Smakunbound
);
3284 defsubr (&Sfmakunbound
);
3286 defsubr (&Sfboundp
);
3288 defsubr (&Sdefalias
);
3289 defsubr (&Ssetplist
);
3290 defsubr (&Ssymbol_value
);
3292 defsubr (&Sdefault_boundp
);
3293 defsubr (&Sdefault_value
);
3294 defsubr (&Sset_default
);
3295 defsubr (&Ssetq_default
);
3296 defsubr (&Smake_variable_buffer_local
);
3297 defsubr (&Smake_local_variable
);
3298 defsubr (&Skill_local_variable
);
3299 defsubr (&Smake_variable_frame_local
);
3300 defsubr (&Slocal_variable_p
);
3301 defsubr (&Slocal_variable_if_set_p
);
3302 defsubr (&Svariable_binding_locus
);
3305 defsubr (&Snumber_to_string
);
3306 defsubr (&Sstring_to_number
);
3307 defsubr (&Seqlsign
);
3330 defsubr (&Sbyteorder
);
3331 defsubr (&Ssubr_arity
);
3332 defsubr (&Ssubr_name
);
3334 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3336 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3337 doc
: /* The largest value that is representable in a Lisp integer. */);
3338 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3340 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3341 doc
: /* The smallest value that is representable in a Lisp integer. */);
3342 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3349 #if defined(USG) && !defined(POSIX_SIGNALS)
3350 /* USG systems forget handlers when they are used;
3351 must reestablish each time */
3352 signal (signo
, arith_error
);
3355 /* VMS systems are like USG. */
3356 signal (signo
, arith_error
);
3360 #else /* not BSD4_1 */
3361 sigsetmask (SIGEMPTYMASK
);
3362 #endif /* not BSD4_1 */
3364 Fsignal (Qarith_error
, Qnil
);
3370 /* Don't do this if just dumping out.
3371 We don't want to call `signal' in this case
3372 so that we don't have trouble with dumping
3373 signal-delivering routines in an inconsistent state. */
3377 #endif /* CANNOT_DUMP */
3378 signal (SIGFPE
, arith_error
);
3381 signal (SIGEMT
, arith_error
);
3385 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3386 (do not change this comment) */