1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
49 /* Work around a problem that happens because math.h on hpux 7
50 defines two static variables--which, in Emacs, are not really static,
51 because `static' is defined as nothing. The problem is that they are
52 here, in floatfns.c, and in lread.c.
53 These macros prevent the name conflict. */
54 #if defined (HPUX) && !defined (HPUX8)
55 #define _MAXLDBL data_c_maxldbl
56 #define _NMAXLDBL data_c_nmaxldbl
62 extern double atof ();
65 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
66 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
67 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
68 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
69 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
70 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
71 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
72 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
73 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
74 Lisp_Object Qtext_read_only
;
76 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
77 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
78 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
79 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
80 Lisp_Object Qboundp
, Qfboundp
;
81 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
84 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
86 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
87 Lisp_Object Qoverflow_error
, Qunderflow_error
;
90 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
93 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
94 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
96 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
97 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
98 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
100 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
102 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
106 circular_list_error (list
)
109 Fsignal (Qcircular_list
, list
);
114 wrong_type_argument (predicate
, value
)
115 register Lisp_Object predicate
, value
;
117 register Lisp_Object tem
;
120 /* If VALUE is not even a valid Lisp object, abort here
121 where we can get a backtrace showing where it came from. */
122 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
125 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
126 tem
= call1 (predicate
, value
);
135 error ("Attempt to modify read-only object");
139 args_out_of_range (a1
, a2
)
143 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
147 args_out_of_range_3 (a1
, a2
, a3
)
148 Lisp_Object a1
, a2
, a3
;
151 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
154 /* On some machines, XINT needs a temporary location.
155 Here it is, in case it is needed. */
157 int sign_extend_temp
;
159 /* On a few machines, XINT can only be done by calling this. */
162 sign_extend_lisp_int (num
)
165 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
166 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
168 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
171 /* Data type predicates */
173 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
174 doc
: /* Return t if the two args are the same Lisp object. */)
176 Lisp_Object obj1
, obj2
;
183 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
184 doc
: /* Return t if OBJECT is nil. */)
193 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
194 doc
: /* Return a symbol representing the type of OBJECT.
195 The symbol returned names the object's basic type;
196 for example, (type-of 1) returns `integer'. */)
200 switch (XGCTYPE (object
))
215 switch (XMISCTYPE (object
))
217 case Lisp_Misc_Marker
:
219 case Lisp_Misc_Overlay
:
221 case Lisp_Misc_Float
:
226 case Lisp_Vectorlike
:
227 if (GC_WINDOW_CONFIGURATIONP (object
))
228 return Qwindow_configuration
;
229 if (GC_PROCESSP (object
))
231 if (GC_WINDOWP (object
))
233 if (GC_SUBRP (object
))
235 if (GC_COMPILEDP (object
))
236 return Qcompiled_function
;
237 if (GC_BUFFERP (object
))
239 if (GC_CHAR_TABLE_P (object
))
241 if (GC_BOOL_VECTOR_P (object
))
243 if (GC_FRAMEP (object
))
245 if (GC_HASH_TABLE_P (object
))
257 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
258 doc
: /* Return t if OBJECT is a cons cell. */)
267 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
268 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
277 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
278 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
279 Otherwise, return nil. */)
283 if (CONSP (object
) || NILP (object
))
288 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
289 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
293 if (CONSP (object
) || NILP (object
))
298 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
299 doc
: /* Return t if OBJECT is a symbol. */)
303 if (SYMBOLP (object
))
308 /* Define this in C to avoid unnecessarily consing up the symbol
310 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
311 doc
: /* Return t if OBJECT is a keyword.
312 This means that it is a symbol with a print name beginning with `:'
313 interned in the initial obarray. */)
318 && SREF (SYMBOL_NAME (object
), 0) == ':'
319 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
324 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a vector. */)
329 if (VECTORP (object
))
334 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
335 doc
: /* Return t if OBJECT is a string. */)
339 if (STRINGP (object
))
344 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
346 doc
: /* Return t if OBJECT is a multibyte string. */)
350 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
355 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
356 doc
: /* Return t if OBJECT is a char-table. */)
360 if (CHAR_TABLE_P (object
))
365 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
366 Svector_or_char_table_p
, 1, 1, 0,
367 doc
: /* Return t if OBJECT is a char-table or vector. */)
371 if (VECTORP (object
) || CHAR_TABLE_P (object
))
376 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is a bool-vector. */)
381 if (BOOL_VECTOR_P (object
))
386 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is an array (string or vector). */)
391 if (VECTORP (object
) || STRINGP (object
)
392 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
397 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is a sequence (list or array). */)
400 register Lisp_Object object
;
402 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
403 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
408 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
409 doc
: /* Return t if OBJECT is an editor buffer. */)
413 if (BUFFERP (object
))
418 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
423 if (MARKERP (object
))
428 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
429 doc
: /* Return t if OBJECT is a built-in function. */)
438 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
440 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
444 if (COMPILEDP (object
))
449 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
450 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
452 register Lisp_Object object
;
454 if (INTEGERP (object
) || STRINGP (object
))
459 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
460 doc
: /* Return t if OBJECT is an integer. */)
464 if (INTEGERP (object
))
469 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
470 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
472 register Lisp_Object object
;
474 if (MARKERP (object
) || INTEGERP (object
))
479 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
480 doc
: /* Return t if OBJECT is a nonnegative integer. */)
484 if (NATNUMP (object
))
489 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
490 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
494 if (NUMBERP (object
))
500 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
501 Snumber_or_marker_p
, 1, 1, 0,
502 doc
: /* Return t if OBJECT is a number or a marker. */)
506 if (NUMBERP (object
) || MARKERP (object
))
511 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
512 doc
: /* Return t if OBJECT is a floating point number. */)
522 /* Extract and set components of lists */
524 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
525 doc
: /* Return the car of LIST. If arg is nil, return nil.
526 Error if arg is not nil and not a cons cell. See also `car-safe'.
528 See Info node `(elisp)Cons Cells' for a discussion of related basic
529 Lisp concepts such as car, cdr, cons cell and list. */)
531 register Lisp_Object list
;
537 else if (EQ (list
, Qnil
))
540 list
= wrong_type_argument (Qlistp
, list
);
544 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
545 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
550 return XCAR (object
);
555 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
556 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
557 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
559 See Info node `(elisp)Cons Cells' for a discussion of related basic
560 Lisp concepts such as cdr, car, cons cell and list. */)
562 register Lisp_Object list
;
568 else if (EQ (list
, Qnil
))
571 list
= wrong_type_argument (Qlistp
, list
);
575 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
576 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
581 return XCDR (object
);
586 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
587 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
589 register Lisp_Object cell
, newcar
;
592 cell
= wrong_type_argument (Qconsp
, cell
);
595 XSETCAR (cell
, newcar
);
599 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
600 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
602 register Lisp_Object cell
, newcdr
;
605 cell
= wrong_type_argument (Qconsp
, cell
);
608 XSETCDR (cell
, newcdr
);
612 /* Extract and set components of symbols */
614 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
615 doc
: /* Return t if SYMBOL's value is not void. */)
617 register Lisp_Object symbol
;
619 Lisp_Object valcontents
;
620 CHECK_SYMBOL (symbol
);
622 valcontents
= SYMBOL_VALUE (symbol
);
624 if (BUFFER_LOCAL_VALUEP (valcontents
)
625 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
626 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
628 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
631 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
632 doc
: /* Return t if SYMBOL's function definition is not void. */)
634 register Lisp_Object symbol
;
636 CHECK_SYMBOL (symbol
);
637 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
640 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
641 doc
: /* Make SYMBOL's value be void.
644 register Lisp_Object symbol
;
646 CHECK_SYMBOL (symbol
);
647 if (XSYMBOL (symbol
)->constant
)
648 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
649 Fset (symbol
, Qunbound
);
653 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
654 doc
: /* Make SYMBOL's function definition be void.
657 register Lisp_Object symbol
;
659 CHECK_SYMBOL (symbol
);
660 if (NILP (symbol
) || EQ (symbol
, Qt
))
661 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
662 XSYMBOL (symbol
)->function
= Qunbound
;
666 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
667 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
669 register Lisp_Object symbol
;
671 CHECK_SYMBOL (symbol
);
672 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
673 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
674 return XSYMBOL (symbol
)->function
;
677 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
678 doc
: /* Return SYMBOL's property list. */)
680 register Lisp_Object symbol
;
682 CHECK_SYMBOL (symbol
);
683 return XSYMBOL (symbol
)->plist
;
686 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
687 doc
: /* Return SYMBOL's name, a string. */)
689 register Lisp_Object symbol
;
691 register Lisp_Object name
;
693 CHECK_SYMBOL (symbol
);
694 name
= SYMBOL_NAME (symbol
);
698 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
699 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
701 register Lisp_Object symbol
, definition
;
703 CHECK_SYMBOL (symbol
);
704 if (NILP (symbol
) || EQ (symbol
, Qt
))
705 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
706 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
707 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
709 XSYMBOL (symbol
)->function
= definition
;
710 /* Handle automatic advice activation */
711 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
713 call2 (Qad_activate_internal
, symbol
, Qnil
);
714 definition
= XSYMBOL (symbol
)->function
;
719 extern Lisp_Object Qfunction_documentation
;
721 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
722 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
723 Associates the function with the current load file, if any.
724 The optional third argument DOCSTRING specifies the documentation string
725 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
726 determined by DEFINITION. */)
727 (symbol
, definition
, docstring
)
728 register Lisp_Object symbol
, definition
, docstring
;
730 CHECK_SYMBOL (symbol
);
731 if (CONSP (XSYMBOL (symbol
)->function
)
732 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
733 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
734 definition
= Ffset (symbol
, definition
);
735 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
736 if (!NILP (docstring
))
737 Fput (symbol
, Qfunction_documentation
, docstring
);
741 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
742 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
744 register Lisp_Object symbol
, newplist
;
746 CHECK_SYMBOL (symbol
);
747 XSYMBOL (symbol
)->plist
= newplist
;
751 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
752 doc
: /* Return minimum and maximum number of args allowed for SUBR.
753 SUBR must be a built-in function.
754 The returned value is a pair (MIN . MAX). MIN is the minimum number
755 of args. MAX is the maximum number or the symbol `many', for a
756 function with `&rest' args, or `unevalled' for a special form. */)
760 short minargs
, maxargs
;
762 wrong_type_argument (Qsubrp
, subr
);
763 minargs
= XSUBR (subr
)->min_args
;
764 maxargs
= XSUBR (subr
)->max_args
;
766 return Fcons (make_number (minargs
), Qmany
);
767 else if (maxargs
== UNEVALLED
)
768 return Fcons (make_number (minargs
), Qunevalled
);
770 return Fcons (make_number (minargs
), make_number (maxargs
));
773 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
774 doc
: /* Return name of subroutine SUBR.
775 SUBR must be a built-in function. */)
781 wrong_type_argument (Qsubrp
, subr
);
782 name
= XSUBR (subr
)->symbol_name
;
783 return make_string (name
, strlen (name
));
786 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
787 doc
: /* Return the interactive form of CMD or nil if none.
788 If CMD is not a command, the return value is nil.
789 Value, if non-nil, is a list \(interactive SPEC). */)
793 Lisp_Object fun
= indirect_function (cmd
);
797 if (XSUBR (fun
)->prompt
)
798 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
800 else if (COMPILEDP (fun
))
802 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
803 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
805 else if (CONSP (fun
))
807 Lisp_Object funcar
= XCAR (fun
);
808 if (EQ (funcar
, Qlambda
))
809 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
810 else if (EQ (funcar
, Qautoload
))
814 do_autoload (fun
, cmd
);
816 return Finteractive_form (cmd
);
823 /***********************************************************************
824 Getting and Setting Values of Symbols
825 ***********************************************************************/
827 /* Return the symbol holding SYMBOL's value. Signal
828 `cyclic-variable-indirection' if SYMBOL's chain of variable
829 indirections contains a loop. */
832 indirect_variable (symbol
)
835 Lisp_Object tortoise
, hare
;
837 hare
= tortoise
= symbol
;
839 while (XSYMBOL (hare
)->indirect_variable
)
841 hare
= XSYMBOL (hare
)->value
;
842 if (!XSYMBOL (hare
)->indirect_variable
)
845 hare
= XSYMBOL (hare
)->value
;
846 tortoise
= XSYMBOL (tortoise
)->value
;
848 if (EQ (hare
, tortoise
))
849 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
856 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
857 doc
: /* Return the variable at the end of OBJECT's variable chain.
858 If OBJECT is a symbol, follow all variable indirections and return the final
859 variable. If OBJECT is not a symbol, just return it.
860 Signal a cyclic-variable-indirection error if there is a loop in the
861 variable chain of symbols. */)
865 if (SYMBOLP (object
))
866 object
= indirect_variable (object
);
871 /* Given the raw contents of a symbol value cell,
872 return the Lisp value of the symbol.
873 This does not handle buffer-local variables; use
874 swap_in_symval_forwarding for that. */
877 do_symval_forwarding (valcontents
)
878 register Lisp_Object valcontents
;
880 register Lisp_Object val
;
882 if (MISCP (valcontents
))
883 switch (XMISCTYPE (valcontents
))
885 case Lisp_Misc_Intfwd
:
886 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
889 case Lisp_Misc_Boolfwd
:
890 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
892 case Lisp_Misc_Objfwd
:
893 return *XOBJFWD (valcontents
)->objvar
;
895 case Lisp_Misc_Buffer_Objfwd
:
896 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
897 return PER_BUFFER_VALUE (current_buffer
, offset
);
899 case Lisp_Misc_Kboard_Objfwd
:
900 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
901 /* We used to simply use current_kboard here, but from Lisp
902 code, it's value is often unexpected. It seems nicer to
903 allow constructions like this to work as intuitively expected:
905 (with-selected-frame frame
906 (define-key local-function-map "\eOP" [f1]))
908 On the other hand, this affects the semantics of
909 last-command and real-last-command, and people may rely on
910 that. I took a quick look at the Lisp codebase, and I
911 don't think anything will break. --lorentey */
912 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
917 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
918 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
919 buffer-independent contents of the value cell: forwarded just one
920 step past the buffer-localness.
922 BUF non-zero means set the value in buffer BUF instead of the
923 current buffer. This only plays a role for per-buffer variables. */
926 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
928 register Lisp_Object valcontents
, newval
;
931 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
934 switch (XMISCTYPE (valcontents
))
936 case Lisp_Misc_Intfwd
:
937 CHECK_NUMBER (newval
);
938 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
939 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
940 error ("Value out of range for variable `%s'",
941 SDATA (SYMBOL_NAME (symbol
)));
944 case Lisp_Misc_Boolfwd
:
945 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
948 case Lisp_Misc_Objfwd
:
949 *XOBJFWD (valcontents
)->objvar
= newval
;
951 /* If this variable is a default for something stored
952 in the buffer itself, such as default-fill-column,
953 find the buffers that don't have local values for it
955 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
956 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
958 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
959 - (char *) &buffer_defaults
);
960 int idx
= PER_BUFFER_IDX (offset
);
967 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
972 buf
= Fcdr (XCAR (tail
));
973 if (!BUFFERP (buf
)) continue;
976 if (! PER_BUFFER_VALUE_P (b
, idx
))
977 PER_BUFFER_VALUE (b
, offset
) = newval
;
982 case Lisp_Misc_Buffer_Objfwd
:
984 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
987 type
= PER_BUFFER_TYPE (offset
);
988 if (! NILP (type
) && ! NILP (newval
)
989 && XTYPE (newval
) != XINT (type
))
990 buffer_slot_type_mismatch (offset
);
993 buf
= current_buffer
;
994 PER_BUFFER_VALUE (buf
, offset
) = newval
;
998 case Lisp_Misc_Kboard_Objfwd
:
1000 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1001 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1002 *(Lisp_Object
*) p
= newval
;
1013 valcontents
= SYMBOL_VALUE (symbol
);
1014 if (BUFFER_LOCAL_VALUEP (valcontents
)
1015 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1016 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1018 SET_SYMBOL_VALUE (symbol
, newval
);
1022 /* Set up SYMBOL to refer to its global binding.
1023 This makes it safe to alter the status of other bindings. */
1026 swap_in_global_binding (symbol
)
1029 Lisp_Object valcontents
, cdr
;
1031 valcontents
= SYMBOL_VALUE (symbol
);
1032 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1033 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1035 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1037 /* Unload the previously loaded binding. */
1038 Fsetcdr (XCAR (cdr
),
1039 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1041 /* Select the global binding in the symbol. */
1043 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1045 /* Indicate that the global binding is set up now. */
1046 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1047 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1048 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1049 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1052 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1053 VALCONTENTS is the contents of its value cell,
1054 which points to a struct Lisp_Buffer_Local_Value.
1056 Return the value forwarded one step past the buffer-local stage.
1057 This could be another forwarding pointer. */
1060 swap_in_symval_forwarding (symbol
, valcontents
)
1061 Lisp_Object symbol
, valcontents
;
1063 register Lisp_Object tem1
;
1065 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1068 || current_buffer
!= XBUFFER (tem1
)
1069 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1070 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1072 if (XSYMBOL (symbol
)->indirect_variable
)
1073 symbol
= indirect_variable (symbol
);
1075 /* Unload the previously loaded binding. */
1076 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1078 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1079 /* Choose the new binding. */
1080 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1081 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1082 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1085 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1086 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1088 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1090 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1093 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1095 /* Load the new binding. */
1096 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1097 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1098 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1099 store_symval_forwarding (symbol
,
1100 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1103 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1106 /* Find the value of a symbol, returning Qunbound if it's not bound.
1107 This is helpful for code which just wants to get a variable's value
1108 if it has one, without signaling an error.
1109 Note that it must not be possible to quit
1110 within this function. Great care is required for this. */
1113 find_symbol_value (symbol
)
1116 register Lisp_Object valcontents
;
1117 register Lisp_Object val
;
1119 CHECK_SYMBOL (symbol
);
1120 valcontents
= SYMBOL_VALUE (symbol
);
1122 if (BUFFER_LOCAL_VALUEP (valcontents
)
1123 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1124 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1126 if (MISCP (valcontents
))
1128 switch (XMISCTYPE (valcontents
))
1130 case Lisp_Misc_Intfwd
:
1131 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1134 case Lisp_Misc_Boolfwd
:
1135 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1137 case Lisp_Misc_Objfwd
:
1138 return *XOBJFWD (valcontents
)->objvar
;
1140 case Lisp_Misc_Buffer_Objfwd
:
1141 return PER_BUFFER_VALUE (current_buffer
,
1142 XBUFFER_OBJFWD (valcontents
)->offset
);
1144 case Lisp_Misc_Kboard_Objfwd
:
1145 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1146 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1153 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1154 doc
: /* Return SYMBOL's value. Error if that is void. */)
1160 val
= find_symbol_value (symbol
);
1161 if (EQ (val
, Qunbound
))
1162 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1167 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1168 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1170 register Lisp_Object symbol
, newval
;
1172 return set_internal (symbol
, newval
, current_buffer
, 0);
1175 /* Return 1 if SYMBOL currently has a let-binding
1176 which was made in the buffer that is now current. */
1179 let_shadows_buffer_binding_p (symbol
)
1182 volatile struct specbinding
*p
;
1184 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1186 && CONSP (p
->symbol
))
1188 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1189 if ((EQ (symbol
, let_bound_symbol
)
1190 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1191 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1192 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1196 return p
>= specpdl
;
1199 /* Store the value NEWVAL into SYMBOL.
1200 If buffer-locality is an issue, BUF specifies which buffer to use.
1201 (0 stands for the current buffer.)
1203 If BINDFLAG is zero, then if this symbol is supposed to become
1204 local in every buffer where it is set, then we make it local.
1205 If BINDFLAG is nonzero, we don't do that. */
1208 set_internal (symbol
, newval
, buf
, bindflag
)
1209 register Lisp_Object symbol
, newval
;
1213 int voide
= EQ (newval
, Qunbound
);
1215 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1218 buf
= current_buffer
;
1220 /* If restoring in a dead buffer, do nothing. */
1221 if (NILP (buf
->name
))
1224 CHECK_SYMBOL (symbol
);
1225 if (SYMBOL_CONSTANT_P (symbol
)
1226 && (NILP (Fkeywordp (symbol
))
1227 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1228 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1230 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1232 if (BUFFER_OBJFWDP (valcontents
))
1234 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1235 int idx
= PER_BUFFER_IDX (offset
);
1238 && !let_shadows_buffer_binding_p (symbol
))
1239 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1241 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1242 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1244 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1245 if (XSYMBOL (symbol
)->indirect_variable
)
1246 symbol
= indirect_variable (symbol
);
1248 /* What binding is loaded right now? */
1249 current_alist_element
1250 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1252 /* If the current buffer is not the buffer whose binding is
1253 loaded, or if there may be frame-local bindings and the frame
1254 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1255 the default binding is loaded, the loaded binding may be the
1257 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1258 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1259 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1260 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1261 || (BUFFER_LOCAL_VALUEP (valcontents
)
1262 && EQ (XCAR (current_alist_element
),
1263 current_alist_element
)))
1265 /* The currently loaded binding is not necessarily valid.
1266 We need to unload it, and choose a new binding. */
1268 /* Write out `realvalue' to the old loaded binding. */
1269 Fsetcdr (current_alist_element
,
1270 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1272 /* Find the new binding. */
1273 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1274 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1275 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1279 /* This buffer still sees the default value. */
1281 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1282 or if this is `let' rather than `set',
1283 make CURRENT-ALIST-ELEMENT point to itself,
1284 indicating that we're seeing the default value.
1285 Likewise if the variable has been let-bound
1286 in the current buffer. */
1287 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1288 || let_shadows_buffer_binding_p (symbol
))
1290 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1292 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1293 tem1
= Fassq (symbol
,
1294 XFRAME (selected_frame
)->param_alist
);
1297 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1299 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1301 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1302 and we're not within a let that was made for this buffer,
1303 create a new buffer-local binding for the variable.
1304 That means, give this buffer a new assoc for a local value
1305 and load that binding. */
1308 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1309 buf
->local_var_alist
1310 = Fcons (tem1
, buf
->local_var_alist
);
1314 /* Record which binding is now loaded. */
1315 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1318 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1319 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1320 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1322 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1325 /* If storing void (making the symbol void), forward only through
1326 buffer-local indicator, not through Lisp_Objfwd, etc. */
1328 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1330 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1332 /* If we just set a variable whose current binding is frame-local,
1333 store the new value in the frame parameter too. */
1335 if (BUFFER_LOCAL_VALUEP (valcontents
)
1336 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1338 /* What binding is loaded right now? */
1339 current_alist_element
1340 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1342 /* If the current buffer is not the buffer whose binding is
1343 loaded, or if there may be frame-local bindings and the frame
1344 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1345 the default binding is loaded, the loaded binding may be the
1347 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1348 XSETCDR (current_alist_element
, newval
);
1354 /* Access or set a buffer-local symbol's default value. */
1356 /* Return the default value of SYMBOL, but don't check for voidness.
1357 Return Qunbound if it is void. */
1360 default_value (symbol
)
1363 register Lisp_Object valcontents
;
1365 CHECK_SYMBOL (symbol
);
1366 valcontents
= SYMBOL_VALUE (symbol
);
1368 /* For a built-in buffer-local variable, get the default value
1369 rather than letting do_symval_forwarding get the current value. */
1370 if (BUFFER_OBJFWDP (valcontents
))
1372 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1373 if (PER_BUFFER_IDX (offset
) != 0)
1374 return PER_BUFFER_DEFAULT (offset
);
1377 /* Handle user-created local variables. */
1378 if (BUFFER_LOCAL_VALUEP (valcontents
)
1379 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1381 /* If var is set up for a buffer that lacks a local value for it,
1382 the current value is nominally the default value.
1383 But the `realvalue' slot may be more up to date, since
1384 ordinary setq stores just that slot. So use that. */
1385 Lisp_Object current_alist_element
, alist_element_car
;
1386 current_alist_element
1387 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1388 alist_element_car
= XCAR (current_alist_element
);
1389 if (EQ (alist_element_car
, current_alist_element
))
1390 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1392 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1394 /* For other variables, get the current value. */
1395 return do_symval_forwarding (valcontents
);
1398 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1399 doc
: /* Return t if SYMBOL has a non-void default value.
1400 This is the value that is seen in buffers that do not have their own values
1401 for this variable. */)
1405 register Lisp_Object value
;
1407 value
= default_value (symbol
);
1408 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1411 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1412 doc
: /* Return SYMBOL's default value.
1413 This is the value that is seen in buffers that do not have their own values
1414 for this variable. The default value is meaningful for variables with
1415 local bindings in certain buffers. */)
1419 register Lisp_Object value
;
1421 value
= default_value (symbol
);
1422 if (EQ (value
, Qunbound
))
1423 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1427 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1428 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1429 The default value is seen in buffers that do not have their own values
1430 for this variable. */)
1432 Lisp_Object symbol
, value
;
1434 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1436 CHECK_SYMBOL (symbol
);
1437 valcontents
= SYMBOL_VALUE (symbol
);
1439 /* Handle variables like case-fold-search that have special slots
1440 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1442 if (BUFFER_OBJFWDP (valcontents
))
1444 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1445 int idx
= PER_BUFFER_IDX (offset
);
1447 PER_BUFFER_DEFAULT (offset
) = value
;
1449 /* If this variable is not always local in all buffers,
1450 set it in the buffers that don't nominally have a local value. */
1455 for (b
= all_buffers
; b
; b
= b
->next
)
1456 if (!PER_BUFFER_VALUE_P (b
, idx
))
1457 PER_BUFFER_VALUE (b
, offset
) = value
;
1462 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1463 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1464 return Fset (symbol
, value
);
1466 /* Store new value into the DEFAULT-VALUE slot. */
1467 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1469 /* If the default binding is now loaded, set the REALVALUE slot too. */
1470 current_alist_element
1471 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1472 alist_element_buffer
= Fcar (current_alist_element
);
1473 if (EQ (alist_element_buffer
, current_alist_element
))
1474 store_symval_forwarding (symbol
,
1475 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1481 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1482 doc
: /* Set the default value of variable VAR to VALUE.
1483 VAR, the variable name, is literal (not evaluated);
1484 VALUE is an expression: it is evaluated and its value returned.
1485 The default value of a variable is seen in buffers
1486 that do not have their own values for the variable.
1488 More generally, you can use multiple variables and values, as in
1489 (setq-default VAR VALUE VAR VALUE...)
1490 This sets each VAR's default value to the corresponding VALUE.
1491 The VALUE for the Nth VAR can refer to the new default values
1493 usage: (setq-default [VAR VALUE...]) */)
1497 register Lisp_Object args_left
;
1498 register Lisp_Object val
, symbol
;
1499 struct gcpro gcpro1
;
1509 val
= Feval (Fcar (Fcdr (args_left
)));
1510 symbol
= XCAR (args_left
);
1511 Fset_default (symbol
, val
);
1512 args_left
= Fcdr (XCDR (args_left
));
1514 while (!NILP (args_left
));
1520 /* Lisp functions for creating and removing buffer-local variables. */
1522 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1523 1, 1, "vMake Variable Buffer Local: ",
1524 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1525 At any time, the value for the current buffer is in effect,
1526 unless the variable has never been set in this buffer,
1527 in which case the default value is in effect.
1528 Note that binding the variable with `let', or setting it while
1529 a `let'-style binding made in this buffer is in effect,
1530 does not make the variable buffer-local. Return VARIABLE.
1532 In most cases it is better to use `make-local-variable',
1533 which makes a variable local in just one buffer.
1535 The function `default-value' gets the default value and `set-default' sets it. */)
1537 register Lisp_Object variable
;
1539 register Lisp_Object tem
, valcontents
, newval
;
1541 CHECK_SYMBOL (variable
);
1542 variable
= indirect_variable (variable
);
1544 valcontents
= SYMBOL_VALUE (variable
);
1545 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1546 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1548 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1550 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1552 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1555 if (EQ (valcontents
, Qunbound
))
1556 SET_SYMBOL_VALUE (variable
, Qnil
);
1557 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1559 newval
= allocate_misc ();
1560 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1561 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1562 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1563 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1564 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1565 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1566 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1567 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1568 SET_SYMBOL_VALUE (variable
, newval
);
1572 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1573 1, 1, "vMake Local Variable: ",
1574 doc
: /* Make VARIABLE have a separate value in the current buffer.
1575 Other buffers will continue to share a common default value.
1576 \(The buffer-local value of VARIABLE starts out as the same value
1577 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1580 If the variable is already arranged to become local when set,
1581 this function causes a local value to exist for this buffer,
1582 just as setting the variable would do.
1584 This function returns VARIABLE, and therefore
1585 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1588 See also `make-variable-buffer-local'.
1590 Do not use `make-local-variable' to make a hook variable buffer-local.
1591 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1593 register Lisp_Object variable
;
1595 register Lisp_Object tem
, valcontents
;
1597 CHECK_SYMBOL (variable
);
1598 variable
= indirect_variable (variable
);
1600 valcontents
= SYMBOL_VALUE (variable
);
1601 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1602 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1604 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1606 tem
= Fboundp (variable
);
1608 /* Make sure the symbol has a local value in this particular buffer,
1609 by setting it to the same value it already has. */
1610 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1613 /* Make sure symbol is set up to hold per-buffer values. */
1614 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1617 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1619 newval
= allocate_misc ();
1620 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1621 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1622 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1623 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1624 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1625 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1626 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1627 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1628 SET_SYMBOL_VALUE (variable
, newval
);;
1630 /* Make sure this buffer has its own value of symbol. */
1631 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1634 /* Swap out any local binding for some other buffer, and make
1635 sure the current value is permanently recorded, if it's the
1637 find_symbol_value (variable
);
1639 current_buffer
->local_var_alist
1640 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1641 current_buffer
->local_var_alist
);
1643 /* Make sure symbol does not think it is set up for this buffer;
1644 force it to look once again for this buffer's value. */
1646 Lisp_Object
*pvalbuf
;
1648 valcontents
= SYMBOL_VALUE (variable
);
1650 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1651 if (current_buffer
== XBUFFER (*pvalbuf
))
1653 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1657 /* If the symbol forwards into a C variable, then load the binding
1658 for this buffer now. If C code modifies the variable before we
1659 load the binding in, then that new value will clobber the default
1660 binding the next time we unload it. */
1661 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1662 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1663 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1668 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1669 1, 1, "vKill Local Variable: ",
1670 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1671 From now on the default value will apply in this buffer. Return VARIABLE. */)
1673 register Lisp_Object variable
;
1675 register Lisp_Object tem
, valcontents
;
1677 CHECK_SYMBOL (variable
);
1678 variable
= indirect_variable (variable
);
1680 valcontents
= SYMBOL_VALUE (variable
);
1682 if (BUFFER_OBJFWDP (valcontents
))
1684 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1685 int idx
= PER_BUFFER_IDX (offset
);
1689 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1690 PER_BUFFER_VALUE (current_buffer
, offset
)
1691 = PER_BUFFER_DEFAULT (offset
);
1696 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1697 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1700 /* Get rid of this buffer's alist element, if any. */
1702 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1704 current_buffer
->local_var_alist
1705 = Fdelq (tem
, current_buffer
->local_var_alist
);
1707 /* If the symbol is set up with the current buffer's binding
1708 loaded, recompute its value. We have to do it now, or else
1709 forwarded objects won't work right. */
1711 Lisp_Object
*pvalbuf
, buf
;
1712 valcontents
= SYMBOL_VALUE (variable
);
1713 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1714 XSETBUFFER (buf
, current_buffer
);
1715 if (EQ (buf
, *pvalbuf
))
1718 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1719 find_symbol_value (variable
);
1726 /* Lisp functions for creating and removing buffer-local variables. */
1728 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1729 1, 1, "vMake Variable Frame Local: ",
1730 doc
: /* Enable VARIABLE to have frame-local bindings.
1731 This does not create any frame-local bindings for VARIABLE,
1732 it just makes them possible.
1734 A frame-local binding is actually a frame parameter value.
1735 If a frame F has a value for the frame parameter named VARIABLE,
1736 that also acts as a frame-local binding for VARIABLE in F--
1737 provided this function has been called to enable VARIABLE
1738 to have frame-local bindings at all.
1740 The only way to create a frame-local binding for VARIABLE in a frame
1741 is to set the VARIABLE frame parameter of that frame. See
1742 `modify-frame-parameters' for how to set frame parameters.
1744 Buffer-local bindings take precedence over frame-local bindings. */)
1746 register Lisp_Object variable
;
1748 register Lisp_Object tem
, valcontents
, newval
;
1750 CHECK_SYMBOL (variable
);
1751 variable
= indirect_variable (variable
);
1753 valcontents
= SYMBOL_VALUE (variable
);
1754 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1755 || BUFFER_OBJFWDP (valcontents
))
1756 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1758 if (BUFFER_LOCAL_VALUEP (valcontents
)
1759 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1761 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1765 if (EQ (valcontents
, Qunbound
))
1766 SET_SYMBOL_VALUE (variable
, Qnil
);
1767 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1769 newval
= allocate_misc ();
1770 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1771 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1772 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1773 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1774 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1775 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1776 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1777 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1778 SET_SYMBOL_VALUE (variable
, newval
);
1782 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1784 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1785 BUFFER defaults to the current buffer. */)
1787 register Lisp_Object variable
, buffer
;
1789 Lisp_Object valcontents
;
1790 register struct buffer
*buf
;
1793 buf
= current_buffer
;
1796 CHECK_BUFFER (buffer
);
1797 buf
= XBUFFER (buffer
);
1800 CHECK_SYMBOL (variable
);
1801 variable
= indirect_variable (variable
);
1803 valcontents
= SYMBOL_VALUE (variable
);
1804 if (BUFFER_LOCAL_VALUEP (valcontents
)
1805 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1807 Lisp_Object tail
, elt
;
1809 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1812 if (EQ (variable
, XCAR (elt
)))
1816 if (BUFFER_OBJFWDP (valcontents
))
1818 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1819 int idx
= PER_BUFFER_IDX (offset
);
1820 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1826 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1828 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1829 More precisely, this means that setting the variable \(with `set' or`setq'),
1830 while it does not have a `let'-style binding that was made in BUFFER,
1831 will produce a buffer local binding. See Info node
1832 `(elisp)Creating Buffer-Local'.
1833 BUFFER defaults to the current buffer. */)
1835 register Lisp_Object variable
, buffer
;
1837 Lisp_Object valcontents
;
1838 register struct buffer
*buf
;
1841 buf
= current_buffer
;
1844 CHECK_BUFFER (buffer
);
1845 buf
= XBUFFER (buffer
);
1848 CHECK_SYMBOL (variable
);
1849 variable
= indirect_variable (variable
);
1851 valcontents
= SYMBOL_VALUE (variable
);
1853 /* This means that make-variable-buffer-local was done. */
1854 if (BUFFER_LOCAL_VALUEP (valcontents
))
1856 /* All these slots become local if they are set. */
1857 if (BUFFER_OBJFWDP (valcontents
))
1859 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1861 Lisp_Object tail
, elt
;
1862 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1865 if (EQ (variable
, XCAR (elt
)))
1872 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1874 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1875 If the current binding is buffer-local, the value is the current buffer.
1876 If the current binding is frame-local, the value is the selected frame.
1877 If the current binding is global (the default), the value is nil. */)
1879 register Lisp_Object variable
;
1881 Lisp_Object valcontents
;
1883 CHECK_SYMBOL (variable
);
1884 variable
= indirect_variable (variable
);
1886 /* Make sure the current binding is actually swapped in. */
1887 find_symbol_value (variable
);
1889 valcontents
= XSYMBOL (variable
)->value
;
1891 if (BUFFER_LOCAL_VALUEP (valcontents
)
1892 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1893 || BUFFER_OBJFWDP (valcontents
))
1895 /* For a local variable, record both the symbol and which
1896 buffer's or frame's value we are saving. */
1897 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1898 return Fcurrent_buffer ();
1899 else if (!BUFFER_OBJFWDP (valcontents
)
1900 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1901 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1907 /* This code is disabled now that we use the selected frame to return
1908 keyboard-local-values. */
1910 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1912 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1913 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1914 If SYMBOL is not a terminal-local variable, then return its normal
1915 value, like `symbol-value'.
1917 TERMINAL may be a terminal id, a frame, or nil (meaning the
1918 selected frame's terminal device). */)
1921 Lisp_Object terminal
;
1924 struct terminal
*t
= get_terminal (terminal
, 1);
1925 push_kboard (t
->kboard
);
1926 result
= Fsymbol_value (symbol
);
1931 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1932 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1933 If VARIABLE is not a terminal-local variable, then set its normal
1934 binding, like `set'.
1936 TERMINAL may be a terminal id, a frame, or nil (meaning the
1937 selected frame's terminal device). */)
1938 (symbol
, terminal
, value
)
1940 Lisp_Object terminal
;
1944 struct terminal
*t
= get_terminal (terminal
, 1);
1945 push_kboard (d
->kboard
);
1946 result
= Fset (symbol
, value
);
1952 /* Find the function at the end of a chain of symbol function indirections. */
1954 /* If OBJECT is a symbol, find the end of its function chain and
1955 return the value found there. If OBJECT is not a symbol, just
1956 return it. If there is a cycle in the function chain, signal a
1957 cyclic-function-indirection error.
1959 This is like Findirect_function, except that it doesn't signal an
1960 error if the chain ends up unbound. */
1962 indirect_function (object
)
1963 register Lisp_Object object
;
1965 Lisp_Object tortoise
, hare
;
1967 hare
= tortoise
= object
;
1971 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1973 hare
= XSYMBOL (hare
)->function
;
1974 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1976 hare
= XSYMBOL (hare
)->function
;
1978 tortoise
= XSYMBOL (tortoise
)->function
;
1980 if (EQ (hare
, tortoise
))
1981 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1987 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1988 doc
: /* Return the function at the end of OBJECT's function chain.
1989 If OBJECT is not a symbol, just return it. Otherwise, follow all
1990 function indirections to find the final function binding and return it.
1991 If the final symbol in the chain is unbound, signal a void-function error.
1992 Optional arg NOERROR non-nil means to return nil instead of signalling.
1993 Signal a cyclic-function-indirection error if there is a loop in the
1994 function chain of symbols. */)
1996 register Lisp_Object object
;
1997 Lisp_Object noerror
;
2001 result
= indirect_function (object
);
2003 if (EQ (result
, Qunbound
))
2004 return (NILP (noerror
)
2005 ? Fsignal (Qvoid_function
, Fcons (object
, Qnil
))
2010 /* Extract and set vector and string elements */
2012 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2013 doc
: /* Return the element of ARRAY at index IDX.
2014 ARRAY may be a vector, a string, a char-table, a bool-vector,
2015 or a byte-code object. IDX starts at 0. */)
2017 register Lisp_Object array
;
2020 register int idxval
;
2023 idxval
= XINT (idx
);
2024 if (STRINGP (array
))
2028 if (idxval
< 0 || idxval
>= SCHARS (array
))
2029 args_out_of_range (array
, idx
);
2030 if (! STRING_MULTIBYTE (array
))
2031 return make_number ((unsigned char) SREF (array
, idxval
));
2032 idxval_byte
= string_char_to_byte (array
, idxval
);
2034 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2035 SBYTES (array
) - idxval_byte
);
2036 return make_number (c
);
2038 else if (BOOL_VECTOR_P (array
))
2042 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2043 args_out_of_range (array
, idx
);
2045 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2046 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2048 else if (CHAR_TABLE_P (array
))
2055 args_out_of_range (array
, idx
);
2056 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2058 if (! SINGLE_BYTE_CHAR_P (idxval
))
2059 args_out_of_range (array
, idx
);
2060 /* For ASCII and 8-bit European characters, the element is
2061 stored in the top table. */
2062 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2066 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2067 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2068 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2069 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2072 val
= XCHAR_TABLE (array
)->defalt
;
2073 while (NILP (val
)) /* Follow parents until we find some value. */
2075 array
= XCHAR_TABLE (array
)->parent
;
2078 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2080 val
= XCHAR_TABLE (array
)->defalt
;
2087 Lisp_Object sub_table
;
2088 Lisp_Object current_default
;
2090 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2091 if (code
[1] < 32) code
[1] = -1;
2092 else if (code
[2] < 32) code
[2] = -1;
2094 /* Here, the possible range of CODE[0] (== charset ID) is
2095 128..MAX_CHARSET. Since the top level char table contains
2096 data for multibyte characters after 256th element, we must
2097 increment CODE[0] by 128 to get a correct index. */
2099 code
[3] = -1; /* anchor */
2101 try_parent_char_table
:
2102 current_default
= XCHAR_TABLE (array
)->defalt
;
2104 for (i
= 0; code
[i
] >= 0; i
++)
2106 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2107 if (SUB_CHAR_TABLE_P (val
))
2110 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2111 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2116 val
= current_default
;
2119 array
= XCHAR_TABLE (array
)->parent
;
2121 goto try_parent_char_table
;
2126 /* Reaching here means IDXVAL is a generic character in
2127 which each character or a group has independent value.
2128 Essentially it's nonsense to get a value for such a
2129 generic character, but for backward compatibility, we try
2130 the default value and parent. */
2131 val
= current_default
;
2134 array
= XCHAR_TABLE (array
)->parent
;
2136 goto try_parent_char_table
;
2144 if (VECTORP (array
))
2145 size
= XVECTOR (array
)->size
;
2146 else if (COMPILEDP (array
))
2147 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2149 wrong_type_argument (Qarrayp
, array
);
2151 if (idxval
< 0 || idxval
>= size
)
2152 args_out_of_range (array
, idx
);
2153 return XVECTOR (array
)->contents
[idxval
];
2157 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2158 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2159 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2160 bool-vector. IDX starts at 0. */)
2161 (array
, idx
, newelt
)
2162 register Lisp_Object array
;
2163 Lisp_Object idx
, newelt
;
2165 register int idxval
;
2168 idxval
= XINT (idx
);
2169 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2170 && ! CHAR_TABLE_P (array
))
2171 array
= wrong_type_argument (Qarrayp
, array
);
2172 CHECK_IMPURE (array
);
2174 if (VECTORP (array
))
2176 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2177 args_out_of_range (array
, idx
);
2178 XVECTOR (array
)->contents
[idxval
] = newelt
;
2180 else if (BOOL_VECTOR_P (array
))
2184 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2185 args_out_of_range (array
, idx
);
2187 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2189 if (! NILP (newelt
))
2190 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2192 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2193 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2195 else if (CHAR_TABLE_P (array
))
2198 args_out_of_range (array
, idx
);
2199 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2201 if (! SINGLE_BYTE_CHAR_P (idxval
))
2202 args_out_of_range (array
, idx
);
2203 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2210 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2211 if (code
[1] < 32) code
[1] = -1;
2212 else if (code
[2] < 32) code
[2] = -1;
2214 /* See the comment of the corresponding part in Faref. */
2216 code
[3] = -1; /* anchor */
2217 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2219 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2220 if (SUB_CHAR_TABLE_P (val
))
2226 /* VAL is a leaf. Create a sub char table with the
2227 initial value VAL and look into it. */
2229 temp
= make_sub_char_table (val
);
2230 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2234 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2237 else if (STRING_MULTIBYTE (array
))
2239 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2240 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2242 if (idxval
< 0 || idxval
>= SCHARS (array
))
2243 args_out_of_range (array
, idx
);
2244 CHECK_NUMBER (newelt
);
2246 nbytes
= SBYTES (array
);
2248 idxval_byte
= string_char_to_byte (array
, idxval
);
2249 p1
= SDATA (array
) + idxval_byte
;
2250 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2251 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2252 if (prev_bytes
!= new_bytes
)
2254 /* We must relocate the string data. */
2255 int nchars
= SCHARS (array
);
2259 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2260 bcopy (SDATA (array
), str
, nbytes
);
2261 allocate_string_data (XSTRING (array
), nchars
,
2262 nbytes
+ new_bytes
- prev_bytes
);
2263 bcopy (str
, SDATA (array
), idxval_byte
);
2264 p1
= SDATA (array
) + idxval_byte
;
2265 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2266 nbytes
- (idxval_byte
+ prev_bytes
));
2268 clear_string_char_byte_cache ();
2275 if (idxval
< 0 || idxval
>= SCHARS (array
))
2276 args_out_of_range (array
, idx
);
2277 CHECK_NUMBER (newelt
);
2279 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2280 SSET (array
, idxval
, XINT (newelt
));
2283 /* We must relocate the string data while converting it to
2285 int idxval_byte
, prev_bytes
, new_bytes
;
2286 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2287 unsigned char *origstr
= SDATA (array
), *str
;
2291 nchars
= SCHARS (array
);
2292 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2293 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2295 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2296 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2297 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2299 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2300 allocate_string_data (XSTRING (array
), nchars
,
2301 nbytes
+ new_bytes
- prev_bytes
);
2302 bcopy (str
, SDATA (array
), idxval_byte
);
2303 p1
= SDATA (array
) + idxval_byte
;
2306 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2307 nbytes
- (idxval_byte
+ prev_bytes
));
2309 clear_string_char_byte_cache ();
2316 /* Arithmetic functions */
2318 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2321 arithcompare (num1
, num2
, comparison
)
2322 Lisp_Object num1
, num2
;
2323 enum comparison comparison
;
2325 double f1
= 0, f2
= 0;
2328 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2329 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2331 if (FLOATP (num1
) || FLOATP (num2
))
2334 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2335 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2341 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2346 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2351 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2356 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2361 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2366 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2375 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2376 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2378 register Lisp_Object num1
, num2
;
2380 return arithcompare (num1
, num2
, equal
);
2383 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2384 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2386 register Lisp_Object num1
, num2
;
2388 return arithcompare (num1
, num2
, less
);
2391 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2392 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2394 register Lisp_Object num1
, num2
;
2396 return arithcompare (num1
, num2
, grtr
);
2399 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2400 doc
: /* Return t if first arg is less than or equal to second arg.
2401 Both must be numbers or markers. */)
2403 register Lisp_Object num1
, num2
;
2405 return arithcompare (num1
, num2
, less_or_equal
);
2408 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2409 doc
: /* Return t if first arg is greater than or equal to second arg.
2410 Both must be numbers or markers. */)
2412 register Lisp_Object num1
, num2
;
2414 return arithcompare (num1
, num2
, grtr_or_equal
);
2417 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2418 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2420 register Lisp_Object num1
, num2
;
2422 return arithcompare (num1
, num2
, notequal
);
2425 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2426 doc
: /* Return t if NUMBER is zero. */)
2428 register Lisp_Object number
;
2430 CHECK_NUMBER_OR_FLOAT (number
);
2432 if (FLOATP (number
))
2434 if (XFLOAT_DATA (number
) == 0.0)
2444 /* Convert between long values and pairs of Lisp integers. */
2450 unsigned long top
= i
>> 16;
2451 unsigned int bot
= i
& 0xFFFF;
2453 return make_number (bot
);
2454 if (top
== (unsigned long)-1 >> 16)
2455 return Fcons (make_number (-1), make_number (bot
));
2456 return Fcons (make_number (top
), make_number (bot
));
2463 Lisp_Object top
, bot
;
2470 return ((XINT (top
) << 16) | XINT (bot
));
2473 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2474 doc
: /* Return the decimal representation of NUMBER as a string.
2475 Uses a minus sign if negative.
2476 NUMBER may be an integer or a floating point number. */)
2480 char buffer
[VALBITS
];
2482 CHECK_NUMBER_OR_FLOAT (number
);
2484 if (FLOATP (number
))
2486 char pigbuf
[350]; /* see comments in float_to_string */
2488 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2489 return build_string (pigbuf
);
2492 if (sizeof (int) == sizeof (EMACS_INT
))
2493 sprintf (buffer
, "%d", XINT (number
));
2494 else if (sizeof (long) == sizeof (EMACS_INT
))
2495 sprintf (buffer
, "%ld", (long) XINT (number
));
2498 return build_string (buffer
);
2502 digit_to_number (character
, base
)
2503 int character
, base
;
2507 if (character
>= '0' && character
<= '9')
2508 digit
= character
- '0';
2509 else if (character
>= 'a' && character
<= 'z')
2510 digit
= character
- 'a' + 10;
2511 else if (character
>= 'A' && character
<= 'Z')
2512 digit
= character
- 'A' + 10;
2522 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2523 doc
: /* Parse STRING as a decimal number and return the number.
2524 This parses both integers and floating point numbers.
2525 It ignores leading spaces and tabs.
2527 If BASE, interpret STRING as a number in that base. If BASE isn't
2528 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2529 If the base used is not 10, floating point is not recognized. */)
2531 register Lisp_Object string
, base
;
2533 register unsigned char *p
;
2538 CHECK_STRING (string
);
2544 CHECK_NUMBER (base
);
2546 if (b
< 2 || b
> 16)
2547 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2550 /* Skip any whitespace at the front of the number. Some versions of
2551 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2553 while (*p
== ' ' || *p
== '\t')
2564 if (isfloat_string (p
) && b
== 10)
2565 val
= make_float (sign
* atof (p
));
2572 int digit
= digit_to_number (*p
++, b
);
2578 val
= make_fixnum_or_float (sign
* v
);
2598 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2599 int, Lisp_Object
*));
2600 extern Lisp_Object
fmod_float ();
2603 arith_driver (code
, nargs
, args
)
2606 register Lisp_Object
*args
;
2608 register Lisp_Object val
;
2609 register int argnum
;
2610 register EMACS_INT accum
= 0;
2611 register EMACS_INT next
;
2613 switch (SWITCH_ENUM_CAST (code
))
2631 for (argnum
= 0; argnum
< nargs
; argnum
++)
2633 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2635 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2638 return float_arith_driver ((double) accum
, argnum
, code
,
2641 next
= XINT (args
[argnum
]);
2642 switch (SWITCH_ENUM_CAST (code
))
2648 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2659 Fsignal (Qarith_error
, Qnil
);
2673 if (!argnum
|| next
> accum
)
2677 if (!argnum
|| next
< accum
)
2683 XSETINT (val
, accum
);
2688 #define isnan(x) ((x) != (x))
2691 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2693 register int argnum
;
2696 register Lisp_Object
*args
;
2698 register Lisp_Object val
;
2701 for (; argnum
< nargs
; argnum
++)
2703 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2704 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2708 next
= XFLOAT_DATA (val
);
2712 args
[argnum
] = val
; /* runs into a compiler bug. */
2713 next
= XINT (args
[argnum
]);
2715 switch (SWITCH_ENUM_CAST (code
))
2721 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2731 if (! IEEE_FLOATING_POINT
&& next
== 0)
2732 Fsignal (Qarith_error
, Qnil
);
2739 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2741 if (!argnum
|| isnan (next
) || next
> accum
)
2745 if (!argnum
|| isnan (next
) || next
< accum
)
2751 return make_float (accum
);
2755 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2756 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2757 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2762 return arith_driver (Aadd
, nargs
, args
);
2765 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2766 doc
: /* Negate number or subtract numbers or markers and return the result.
2767 With one arg, negates it. With more than one arg,
2768 subtracts all but the first from the first.
2769 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2774 return arith_driver (Asub
, nargs
, args
);
2777 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2778 doc
: /* Return product of any number of arguments, which are numbers or markers.
2779 usage: (* &rest NUMBERS-OR-MARKERS) */)
2784 return arith_driver (Amult
, nargs
, args
);
2787 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2788 doc
: /* Return first argument divided by all the remaining arguments.
2789 The arguments must be numbers or markers.
2790 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2796 for (argnum
= 2; argnum
< nargs
; argnum
++)
2797 if (FLOATP (args
[argnum
]))
2798 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2799 return arith_driver (Adiv
, nargs
, args
);
2802 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2803 doc
: /* Return remainder of X divided by Y.
2804 Both must be integers or markers. */)
2806 register Lisp_Object x
, y
;
2810 CHECK_NUMBER_COERCE_MARKER (x
);
2811 CHECK_NUMBER_COERCE_MARKER (y
);
2813 if (XFASTINT (y
) == 0)
2814 Fsignal (Qarith_error
, Qnil
);
2816 XSETINT (val
, XINT (x
) % XINT (y
));
2830 /* If the magnitude of the result exceeds that of the divisor, or
2831 the sign of the result does not agree with that of the dividend,
2832 iterate with the reduced value. This does not yield a
2833 particularly accurate result, but at least it will be in the
2834 range promised by fmod. */
2836 r
-= f2
* floor (r
/ f2
);
2837 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2841 #endif /* ! HAVE_FMOD */
2843 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2844 doc
: /* Return X modulo Y.
2845 The result falls between zero (inclusive) and Y (exclusive).
2846 Both X and Y must be numbers or markers. */)
2848 register Lisp_Object x
, y
;
2853 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2854 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2856 if (FLOATP (x
) || FLOATP (y
))
2857 return fmod_float (x
, y
);
2863 Fsignal (Qarith_error
, Qnil
);
2867 /* If the "remainder" comes out with the wrong sign, fix it. */
2868 if (i2
< 0 ? i1
> 0 : i1
< 0)
2875 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2876 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2877 The value is always a number; markers are converted to numbers.
2878 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2883 return arith_driver (Amax
, nargs
, args
);
2886 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2887 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2888 The value is always a number; markers are converted to numbers.
2889 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2894 return arith_driver (Amin
, nargs
, args
);
2897 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2898 doc
: /* Return bitwise-and of all the arguments.
2899 Arguments may be integers, or markers converted to integers.
2900 usage: (logand &rest INTS-OR-MARKERS) */)
2905 return arith_driver (Alogand
, nargs
, args
);
2908 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2909 doc
: /* Return bitwise-or of all the arguments.
2910 Arguments may be integers, or markers converted to integers.
2911 usage: (logior &rest INTS-OR-MARKERS) */)
2916 return arith_driver (Alogior
, nargs
, args
);
2919 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2920 doc
: /* Return bitwise-exclusive-or of all the arguments.
2921 Arguments may be integers, or markers converted to integers.
2922 usage: (logxor &rest INTS-OR-MARKERS) */)
2927 return arith_driver (Alogxor
, nargs
, args
);
2930 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2931 doc
: /* Return VALUE with its bits shifted left by COUNT.
2932 If COUNT is negative, shifting is actually to the right.
2933 In this case, the sign bit is duplicated. */)
2935 register Lisp_Object value
, count
;
2937 register Lisp_Object val
;
2939 CHECK_NUMBER (value
);
2940 CHECK_NUMBER (count
);
2942 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2944 else if (XINT (count
) > 0)
2945 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2946 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2947 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2949 XSETINT (val
, XINT (value
) >> -XINT (count
));
2953 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2954 doc
: /* Return VALUE with its bits shifted left by COUNT.
2955 If COUNT is negative, shifting is actually to the right.
2956 In this case, zeros are shifted in on the left. */)
2958 register Lisp_Object value
, count
;
2960 register Lisp_Object val
;
2962 CHECK_NUMBER (value
);
2963 CHECK_NUMBER (count
);
2965 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2967 else if (XINT (count
) > 0)
2968 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2969 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2972 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2976 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2977 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2978 Markers are converted to integers. */)
2980 register Lisp_Object number
;
2982 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2984 if (FLOATP (number
))
2985 return (make_float (1.0 + XFLOAT_DATA (number
)));
2987 XSETINT (number
, XINT (number
) + 1);
2991 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2992 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2993 Markers are converted to integers. */)
2995 register Lisp_Object number
;
2997 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2999 if (FLOATP (number
))
3000 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3002 XSETINT (number
, XINT (number
) - 1);
3006 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3007 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3009 register Lisp_Object number
;
3011 CHECK_NUMBER (number
);
3012 XSETINT (number
, ~XINT (number
));
3016 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3017 doc
: /* Return the byteorder for the machine.
3018 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3019 lowercase l) for small endian machines. */)
3022 unsigned i
= 0x04030201;
3023 int order
= *(char *)&i
== 1 ? 108 : 66;
3025 return make_number (order
);
3033 Lisp_Object error_tail
, arith_tail
;
3035 Qquote
= intern ("quote");
3036 Qlambda
= intern ("lambda");
3037 Qsubr
= intern ("subr");
3038 Qerror_conditions
= intern ("error-conditions");
3039 Qerror_message
= intern ("error-message");
3040 Qtop_level
= intern ("top-level");
3042 Qerror
= intern ("error");
3043 Qquit
= intern ("quit");
3044 Qwrong_type_argument
= intern ("wrong-type-argument");
3045 Qargs_out_of_range
= intern ("args-out-of-range");
3046 Qvoid_function
= intern ("void-function");
3047 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3048 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3049 Qvoid_variable
= intern ("void-variable");
3050 Qsetting_constant
= intern ("setting-constant");
3051 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3053 Qinvalid_function
= intern ("invalid-function");
3054 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3055 Qno_catch
= intern ("no-catch");
3056 Qend_of_file
= intern ("end-of-file");
3057 Qarith_error
= intern ("arith-error");
3058 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3059 Qend_of_buffer
= intern ("end-of-buffer");
3060 Qbuffer_read_only
= intern ("buffer-read-only");
3061 Qtext_read_only
= intern ("text-read-only");
3062 Qmark_inactive
= intern ("mark-inactive");
3064 Qlistp
= intern ("listp");
3065 Qconsp
= intern ("consp");
3066 Qsymbolp
= intern ("symbolp");
3067 Qkeywordp
= intern ("keywordp");
3068 Qintegerp
= intern ("integerp");
3069 Qnatnump
= intern ("natnump");
3070 Qwholenump
= intern ("wholenump");
3071 Qstringp
= intern ("stringp");
3072 Qarrayp
= intern ("arrayp");
3073 Qsequencep
= intern ("sequencep");
3074 Qbufferp
= intern ("bufferp");
3075 Qvectorp
= intern ("vectorp");
3076 Qchar_or_string_p
= intern ("char-or-string-p");
3077 Qmarkerp
= intern ("markerp");
3078 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3079 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3080 Qboundp
= intern ("boundp");
3081 Qfboundp
= intern ("fboundp");
3083 Qfloatp
= intern ("floatp");
3084 Qnumberp
= intern ("numberp");
3085 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3087 Qchar_table_p
= intern ("char-table-p");
3088 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3090 Qsubrp
= intern ("subrp");
3091 Qunevalled
= intern ("unevalled");
3092 Qmany
= intern ("many");
3094 Qcdr
= intern ("cdr");
3096 /* Handle automatic advice activation */
3097 Qad_advice_info
= intern ("ad-advice-info");
3098 Qad_activate_internal
= intern ("ad-activate-internal");
3100 error_tail
= Fcons (Qerror
, Qnil
);
3102 /* ERROR is used as a signaler for random errors for which nothing else is right */
3104 Fput (Qerror
, Qerror_conditions
,
3106 Fput (Qerror
, Qerror_message
,
3107 build_string ("error"));
3109 Fput (Qquit
, Qerror_conditions
,
3110 Fcons (Qquit
, Qnil
));
3111 Fput (Qquit
, Qerror_message
,
3112 build_string ("Quit"));
3114 Fput (Qwrong_type_argument
, Qerror_conditions
,
3115 Fcons (Qwrong_type_argument
, error_tail
));
3116 Fput (Qwrong_type_argument
, Qerror_message
,
3117 build_string ("Wrong type argument"));
3119 Fput (Qargs_out_of_range
, Qerror_conditions
,
3120 Fcons (Qargs_out_of_range
, error_tail
));
3121 Fput (Qargs_out_of_range
, Qerror_message
,
3122 build_string ("Args out of range"));
3124 Fput (Qvoid_function
, Qerror_conditions
,
3125 Fcons (Qvoid_function
, error_tail
));
3126 Fput (Qvoid_function
, Qerror_message
,
3127 build_string ("Symbol's function definition is void"));
3129 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3130 Fcons (Qcyclic_function_indirection
, error_tail
));
3131 Fput (Qcyclic_function_indirection
, Qerror_message
,
3132 build_string ("Symbol's chain of function indirections contains a loop"));
3134 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3135 Fcons (Qcyclic_variable_indirection
, error_tail
));
3136 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3137 build_string ("Symbol's chain of variable indirections contains a loop"));
3139 Qcircular_list
= intern ("circular-list");
3140 staticpro (&Qcircular_list
);
3141 Fput (Qcircular_list
, Qerror_conditions
,
3142 Fcons (Qcircular_list
, error_tail
));
3143 Fput (Qcircular_list
, Qerror_message
,
3144 build_string ("List contains a loop"));
3146 Fput (Qvoid_variable
, Qerror_conditions
,
3147 Fcons (Qvoid_variable
, error_tail
));
3148 Fput (Qvoid_variable
, Qerror_message
,
3149 build_string ("Symbol's value as variable is void"));
3151 Fput (Qsetting_constant
, Qerror_conditions
,
3152 Fcons (Qsetting_constant
, error_tail
));
3153 Fput (Qsetting_constant
, Qerror_message
,
3154 build_string ("Attempt to set a constant symbol"));
3156 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3157 Fcons (Qinvalid_read_syntax
, error_tail
));
3158 Fput (Qinvalid_read_syntax
, Qerror_message
,
3159 build_string ("Invalid read syntax"));
3161 Fput (Qinvalid_function
, Qerror_conditions
,
3162 Fcons (Qinvalid_function
, error_tail
));
3163 Fput (Qinvalid_function
, Qerror_message
,
3164 build_string ("Invalid function"));
3166 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3167 Fcons (Qwrong_number_of_arguments
, error_tail
));
3168 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3169 build_string ("Wrong number of arguments"));
3171 Fput (Qno_catch
, Qerror_conditions
,
3172 Fcons (Qno_catch
, error_tail
));
3173 Fput (Qno_catch
, Qerror_message
,
3174 build_string ("No catch for tag"));
3176 Fput (Qend_of_file
, Qerror_conditions
,
3177 Fcons (Qend_of_file
, error_tail
));
3178 Fput (Qend_of_file
, Qerror_message
,
3179 build_string ("End of file during parsing"));
3181 arith_tail
= Fcons (Qarith_error
, error_tail
);
3182 Fput (Qarith_error
, Qerror_conditions
,
3184 Fput (Qarith_error
, Qerror_message
,
3185 build_string ("Arithmetic error"));
3187 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3188 Fcons (Qbeginning_of_buffer
, error_tail
));
3189 Fput (Qbeginning_of_buffer
, Qerror_message
,
3190 build_string ("Beginning of buffer"));
3192 Fput (Qend_of_buffer
, Qerror_conditions
,
3193 Fcons (Qend_of_buffer
, error_tail
));
3194 Fput (Qend_of_buffer
, Qerror_message
,
3195 build_string ("End of buffer"));
3197 Fput (Qbuffer_read_only
, Qerror_conditions
,
3198 Fcons (Qbuffer_read_only
, error_tail
));
3199 Fput (Qbuffer_read_only
, Qerror_message
,
3200 build_string ("Buffer is read-only"));
3202 Fput (Qtext_read_only
, Qerror_conditions
,
3203 Fcons (Qtext_read_only
, error_tail
));
3204 Fput (Qtext_read_only
, Qerror_message
,
3205 build_string ("Text is read-only"));
3207 Qrange_error
= intern ("range-error");
3208 Qdomain_error
= intern ("domain-error");
3209 Qsingularity_error
= intern ("singularity-error");
3210 Qoverflow_error
= intern ("overflow-error");
3211 Qunderflow_error
= intern ("underflow-error");
3213 Fput (Qdomain_error
, Qerror_conditions
,
3214 Fcons (Qdomain_error
, arith_tail
));
3215 Fput (Qdomain_error
, Qerror_message
,
3216 build_string ("Arithmetic domain error"));
3218 Fput (Qrange_error
, Qerror_conditions
,
3219 Fcons (Qrange_error
, arith_tail
));
3220 Fput (Qrange_error
, Qerror_message
,
3221 build_string ("Arithmetic range error"));
3223 Fput (Qsingularity_error
, Qerror_conditions
,
3224 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3225 Fput (Qsingularity_error
, Qerror_message
,
3226 build_string ("Arithmetic singularity error"));
3228 Fput (Qoverflow_error
, Qerror_conditions
,
3229 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3230 Fput (Qoverflow_error
, Qerror_message
,
3231 build_string ("Arithmetic overflow error"));
3233 Fput (Qunderflow_error
, Qerror_conditions
,
3234 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3235 Fput (Qunderflow_error
, Qerror_message
,
3236 build_string ("Arithmetic underflow error"));
3238 staticpro (&Qrange_error
);
3239 staticpro (&Qdomain_error
);
3240 staticpro (&Qsingularity_error
);
3241 staticpro (&Qoverflow_error
);
3242 staticpro (&Qunderflow_error
);
3246 staticpro (&Qquote
);
3247 staticpro (&Qlambda
);
3249 staticpro (&Qunbound
);
3250 staticpro (&Qerror_conditions
);
3251 staticpro (&Qerror_message
);
3252 staticpro (&Qtop_level
);
3254 staticpro (&Qerror
);
3256 staticpro (&Qwrong_type_argument
);
3257 staticpro (&Qargs_out_of_range
);
3258 staticpro (&Qvoid_function
);
3259 staticpro (&Qcyclic_function_indirection
);
3260 staticpro (&Qcyclic_variable_indirection
);
3261 staticpro (&Qvoid_variable
);
3262 staticpro (&Qsetting_constant
);
3263 staticpro (&Qinvalid_read_syntax
);
3264 staticpro (&Qwrong_number_of_arguments
);
3265 staticpro (&Qinvalid_function
);
3266 staticpro (&Qno_catch
);
3267 staticpro (&Qend_of_file
);
3268 staticpro (&Qarith_error
);
3269 staticpro (&Qbeginning_of_buffer
);
3270 staticpro (&Qend_of_buffer
);
3271 staticpro (&Qbuffer_read_only
);
3272 staticpro (&Qtext_read_only
);
3273 staticpro (&Qmark_inactive
);
3275 staticpro (&Qlistp
);
3276 staticpro (&Qconsp
);
3277 staticpro (&Qsymbolp
);
3278 staticpro (&Qkeywordp
);
3279 staticpro (&Qintegerp
);
3280 staticpro (&Qnatnump
);
3281 staticpro (&Qwholenump
);
3282 staticpro (&Qstringp
);
3283 staticpro (&Qarrayp
);
3284 staticpro (&Qsequencep
);
3285 staticpro (&Qbufferp
);
3286 staticpro (&Qvectorp
);
3287 staticpro (&Qchar_or_string_p
);
3288 staticpro (&Qmarkerp
);
3289 staticpro (&Qbuffer_or_string_p
);
3290 staticpro (&Qinteger_or_marker_p
);
3291 staticpro (&Qfloatp
);
3292 staticpro (&Qnumberp
);
3293 staticpro (&Qnumber_or_marker_p
);
3294 staticpro (&Qchar_table_p
);
3295 staticpro (&Qvector_or_char_table_p
);
3296 staticpro (&Qsubrp
);
3298 staticpro (&Qunevalled
);
3300 staticpro (&Qboundp
);
3301 staticpro (&Qfboundp
);
3303 staticpro (&Qad_advice_info
);
3304 staticpro (&Qad_activate_internal
);
3306 /* Types that type-of returns. */
3307 Qinteger
= intern ("integer");
3308 Qsymbol
= intern ("symbol");
3309 Qstring
= intern ("string");
3310 Qcons
= intern ("cons");
3311 Qmarker
= intern ("marker");
3312 Qoverlay
= intern ("overlay");
3313 Qfloat
= intern ("float");
3314 Qwindow_configuration
= intern ("window-configuration");
3315 Qprocess
= intern ("process");
3316 Qwindow
= intern ("window");
3317 /* Qsubr = intern ("subr"); */
3318 Qcompiled_function
= intern ("compiled-function");
3319 Qbuffer
= intern ("buffer");
3320 Qframe
= intern ("frame");
3321 Qvector
= intern ("vector");
3322 Qchar_table
= intern ("char-table");
3323 Qbool_vector
= intern ("bool-vector");
3324 Qhash_table
= intern ("hash-table");
3326 staticpro (&Qinteger
);
3327 staticpro (&Qsymbol
);
3328 staticpro (&Qstring
);
3330 staticpro (&Qmarker
);
3331 staticpro (&Qoverlay
);
3332 staticpro (&Qfloat
);
3333 staticpro (&Qwindow_configuration
);
3334 staticpro (&Qprocess
);
3335 staticpro (&Qwindow
);
3336 /* staticpro (&Qsubr); */
3337 staticpro (&Qcompiled_function
);
3338 staticpro (&Qbuffer
);
3339 staticpro (&Qframe
);
3340 staticpro (&Qvector
);
3341 staticpro (&Qchar_table
);
3342 staticpro (&Qbool_vector
);
3343 staticpro (&Qhash_table
);
3345 defsubr (&Sindirect_variable
);
3346 defsubr (&Sinteractive_form
);
3349 defsubr (&Stype_of
);
3354 defsubr (&Sintegerp
);
3355 defsubr (&Sinteger_or_marker_p
);
3356 defsubr (&Snumberp
);
3357 defsubr (&Snumber_or_marker_p
);
3359 defsubr (&Snatnump
);
3360 defsubr (&Ssymbolp
);
3361 defsubr (&Skeywordp
);
3362 defsubr (&Sstringp
);
3363 defsubr (&Smultibyte_string_p
);
3364 defsubr (&Svectorp
);
3365 defsubr (&Schar_table_p
);
3366 defsubr (&Svector_or_char_table_p
);
3367 defsubr (&Sbool_vector_p
);
3369 defsubr (&Ssequencep
);
3370 defsubr (&Sbufferp
);
3371 defsubr (&Smarkerp
);
3373 defsubr (&Sbyte_code_function_p
);
3374 defsubr (&Schar_or_string_p
);
3377 defsubr (&Scar_safe
);
3378 defsubr (&Scdr_safe
);
3381 defsubr (&Ssymbol_function
);
3382 defsubr (&Sindirect_function
);
3383 defsubr (&Ssymbol_plist
);
3384 defsubr (&Ssymbol_name
);
3385 defsubr (&Smakunbound
);
3386 defsubr (&Sfmakunbound
);
3388 defsubr (&Sfboundp
);
3390 defsubr (&Sdefalias
);
3391 defsubr (&Ssetplist
);
3392 defsubr (&Ssymbol_value
);
3394 defsubr (&Sdefault_boundp
);
3395 defsubr (&Sdefault_value
);
3396 defsubr (&Sset_default
);
3397 defsubr (&Ssetq_default
);
3398 defsubr (&Smake_variable_buffer_local
);
3399 defsubr (&Smake_local_variable
);
3400 defsubr (&Skill_local_variable
);
3401 defsubr (&Smake_variable_frame_local
);
3402 defsubr (&Slocal_variable_p
);
3403 defsubr (&Slocal_variable_if_set_p
);
3404 defsubr (&Svariable_binding_locus
);
3405 #if 0 /* XXX Remove this. --lorentey */
3406 defsubr (&Sterminal_local_value
);
3407 defsubr (&Sset_terminal_local_value
);
3411 defsubr (&Snumber_to_string
);
3412 defsubr (&Sstring_to_number
);
3413 defsubr (&Seqlsign
);
3436 defsubr (&Sbyteorder
);
3437 defsubr (&Ssubr_arity
);
3438 defsubr (&Ssubr_name
);
3440 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3442 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3443 doc
: /* The largest value that is representable in a Lisp integer. */);
3444 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3446 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3447 doc
: /* The smallest value that is representable in a Lisp integer. */);
3448 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3455 #if defined(USG) && !defined(POSIX_SIGNALS)
3456 /* USG systems forget handlers when they are used;
3457 must reestablish each time */
3458 signal (signo
, arith_error
);
3461 /* VMS systems are like USG. */
3462 signal (signo
, arith_error
);
3466 #else /* not BSD4_1 */
3467 sigsetmask (SIGEMPTYMASK
);
3468 #endif /* not BSD4_1 */
3470 SIGNAL_THREAD_CHECK (signo
);
3471 Fsignal (Qarith_error
, Qnil
);
3477 /* Don't do this if just dumping out.
3478 We don't want to call `signal' in this case
3479 so that we don't have trouble with dumping
3480 signal-delivering routines in an inconsistent state. */
3484 #endif /* CANNOT_DUMP */
3485 signal (SIGFPE
, arith_error
);
3488 signal (SIGEMT
, arith_error
);
3492 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3493 (do not change this comment) */