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 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. This includes nil. */)
282 if (CONSP (object
) || NILP (object
))
287 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
288 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
292 if (CONSP (object
) || NILP (object
))
297 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
298 doc
: /* Return t if OBJECT is a symbol. */)
302 if (SYMBOLP (object
))
307 /* Define this in C to avoid unnecessarily consing up the symbol
309 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
310 doc
: /* Return t if OBJECT is a keyword.
311 This means that it is a symbol with a print name beginning with `:'
312 interned in the initial obarray. */)
317 && SREF (SYMBOL_NAME (object
), 0) == ':'
318 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
323 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
324 doc
: /* Return t if OBJECT is a vector. */)
328 if (VECTORP (object
))
333 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is a string. */)
338 if (STRINGP (object
))
343 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
345 doc
: /* Return t if OBJECT is a multibyte string. */)
349 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
354 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
355 doc
: /* Return t if OBJECT is a char-table. */)
359 if (CHAR_TABLE_P (object
))
364 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
365 Svector_or_char_table_p
, 1, 1, 0,
366 doc
: /* Return t if OBJECT is a char-table or vector. */)
370 if (VECTORP (object
) || CHAR_TABLE_P (object
))
375 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
376 doc
: /* Return t if OBJECT is a bool-vector. */)
380 if (BOOL_VECTOR_P (object
))
385 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
386 doc
: /* Return t if OBJECT is an array (string or vector). */)
390 if (VECTORP (object
) || STRINGP (object
)
391 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
396 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is a sequence (list or array). */)
399 register Lisp_Object object
;
401 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
402 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
407 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is an editor buffer. */)
412 if (BUFFERP (object
))
417 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
422 if (MARKERP (object
))
427 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
428 doc
: /* Return t if OBJECT is a built-in function. */)
437 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
439 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
443 if (COMPILEDP (object
))
448 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
451 register Lisp_Object object
;
453 if (INTEGERP (object
) || STRINGP (object
))
458 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer. */)
463 if (INTEGERP (object
))
468 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
471 register Lisp_Object object
;
473 if (MARKERP (object
) || INTEGERP (object
))
478 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
479 doc
: /* Return t if OBJECT is a nonnegative integer. */)
483 if (NATNUMP (object
))
488 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
489 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
493 if (NUMBERP (object
))
499 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
500 Snumber_or_marker_p
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a number or a marker. */)
505 if (NUMBERP (object
) || MARKERP (object
))
510 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
511 doc
: /* Return t if OBJECT is a floating point number. */)
521 /* Extract and set components of lists */
523 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
524 doc
: /* Return the car of LIST. If arg is nil, return nil.
525 Error if arg is not nil and not a cons cell. See also `car-safe'. */)
527 register Lisp_Object list
;
533 else if (EQ (list
, Qnil
))
536 list
= wrong_type_argument (Qlistp
, list
);
540 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
541 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
546 return XCAR (object
);
551 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
552 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
553 Error if arg is not nil and not a cons cell. See also `cdr-safe'. */)
555 register Lisp_Object list
;
561 else if (EQ (list
, Qnil
))
564 list
= wrong_type_argument (Qlistp
, list
);
568 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
569 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
574 return XCDR (object
);
579 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
580 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
582 register Lisp_Object cell
, newcar
;
585 cell
= wrong_type_argument (Qconsp
, cell
);
588 XSETCAR (cell
, newcar
);
592 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
593 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
595 register Lisp_Object cell
, newcdr
;
598 cell
= wrong_type_argument (Qconsp
, cell
);
601 XSETCDR (cell
, newcdr
);
605 /* Extract and set components of symbols */
607 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
608 doc
: /* Return t if SYMBOL's value is not void. */)
610 register Lisp_Object symbol
;
612 Lisp_Object valcontents
;
613 CHECK_SYMBOL (symbol
);
615 valcontents
= SYMBOL_VALUE (symbol
);
617 if (BUFFER_LOCAL_VALUEP (valcontents
)
618 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
619 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
621 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
624 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
625 doc
: /* Return t if SYMBOL's function definition is not void. */)
627 register Lisp_Object symbol
;
629 CHECK_SYMBOL (symbol
);
630 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
633 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
634 doc
: /* Make SYMBOL's value be void.
637 register Lisp_Object symbol
;
639 CHECK_SYMBOL (symbol
);
640 if (XSYMBOL (symbol
)->constant
)
641 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
642 Fset (symbol
, Qunbound
);
646 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
647 doc
: /* Make SYMBOL's function definition be void.
650 register Lisp_Object symbol
;
652 CHECK_SYMBOL (symbol
);
653 if (NILP (symbol
) || EQ (symbol
, Qt
))
654 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
655 XSYMBOL (symbol
)->function
= Qunbound
;
659 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
660 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
662 register Lisp_Object symbol
;
664 CHECK_SYMBOL (symbol
);
665 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
666 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
667 return XSYMBOL (symbol
)->function
;
670 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
671 doc
: /* Return SYMBOL's property list. */)
673 register Lisp_Object symbol
;
675 CHECK_SYMBOL (symbol
);
676 return XSYMBOL (symbol
)->plist
;
679 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
680 doc
: /* Return SYMBOL's name, a string. */)
682 register Lisp_Object symbol
;
684 register Lisp_Object name
;
686 CHECK_SYMBOL (symbol
);
687 name
= SYMBOL_NAME (symbol
);
691 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
692 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
694 register Lisp_Object symbol
, definition
;
696 CHECK_SYMBOL (symbol
);
697 if (NILP (symbol
) || EQ (symbol
, Qt
))
698 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
699 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
700 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
702 XSYMBOL (symbol
)->function
= definition
;
703 /* Handle automatic advice activation */
704 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
706 call2 (Qad_activate_internal
, symbol
, Qnil
);
707 definition
= XSYMBOL (symbol
)->function
;
712 extern Lisp_Object Qfunction_documentation
;
714 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
715 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
716 Associates the function with the current load file, if any.
717 The optional third argument DOCSTRING specifies the documentation string
718 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
719 determined by DEFINITION. */)
720 (symbol
, definition
, docstring
)
721 register Lisp_Object symbol
, definition
, docstring
;
723 CHECK_SYMBOL (symbol
);
724 if (CONSP (XSYMBOL (symbol
)->function
)
725 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
726 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
727 definition
= Ffset (symbol
, definition
);
728 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
729 if (!NILP (docstring
))
730 Fput (symbol
, Qfunction_documentation
, docstring
);
734 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
735 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
737 register Lisp_Object symbol
, newplist
;
739 CHECK_SYMBOL (symbol
);
740 XSYMBOL (symbol
)->plist
= newplist
;
744 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
745 doc
: /* Return minimum and maximum number of args allowed for SUBR.
746 SUBR must be a built-in function.
747 The returned value is a pair (MIN . MAX). MIN is the minimum number
748 of args. MAX is the maximum number or the symbol `many', for a
749 function with `&rest' args, or `unevalled' for a special form. */)
753 short minargs
, maxargs
;
755 wrong_type_argument (Qsubrp
, subr
);
756 minargs
= XSUBR (subr
)->min_args
;
757 maxargs
= XSUBR (subr
)->max_args
;
759 return Fcons (make_number (minargs
), Qmany
);
760 else if (maxargs
== UNEVALLED
)
761 return Fcons (make_number (minargs
), Qunevalled
);
763 return Fcons (make_number (minargs
), make_number (maxargs
));
766 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
767 doc
: /* Return name of subroutine SUBR.
768 SUBR must be a built-in function. */)
774 wrong_type_argument (Qsubrp
, subr
);
775 name
= XSUBR (subr
)->symbol_name
;
776 return make_string (name
, strlen (name
));
779 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
780 doc
: /* Return the interactive form of CMD or nil if none.
781 If CMD is not a command, the return value is nil.
782 Value, if non-nil, is a list \(interactive SPEC). */)
786 Lisp_Object fun
= indirect_function (cmd
);
790 if (XSUBR (fun
)->prompt
)
791 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
793 else if (COMPILEDP (fun
))
795 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
796 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
798 else if (CONSP (fun
))
800 Lisp_Object funcar
= XCAR (fun
);
801 if (EQ (funcar
, Qlambda
))
802 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
803 else if (EQ (funcar
, Qautoload
))
807 do_autoload (fun
, cmd
);
809 return Finteractive_form (cmd
);
816 /***********************************************************************
817 Getting and Setting Values of Symbols
818 ***********************************************************************/
820 /* Return the symbol holding SYMBOL's value. Signal
821 `cyclic-variable-indirection' if SYMBOL's chain of variable
822 indirections contains a loop. */
825 indirect_variable (symbol
)
828 Lisp_Object tortoise
, hare
;
830 hare
= tortoise
= symbol
;
832 while (XSYMBOL (hare
)->indirect_variable
)
834 hare
= XSYMBOL (hare
)->value
;
835 if (!XSYMBOL (hare
)->indirect_variable
)
838 hare
= XSYMBOL (hare
)->value
;
839 tortoise
= XSYMBOL (tortoise
)->value
;
841 if (EQ (hare
, tortoise
))
842 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
849 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
850 doc
: /* Return the variable at the end of OBJECT's variable chain.
851 If OBJECT is a symbol, follow all variable indirections and return the final
852 variable. If OBJECT is not a symbol, just return it.
853 Signal a cyclic-variable-indirection error if there is a loop in the
854 variable chain of symbols. */)
858 if (SYMBOLP (object
))
859 object
= indirect_variable (object
);
864 /* Given the raw contents of a symbol value cell,
865 return the Lisp value of the symbol.
866 This does not handle buffer-local variables; use
867 swap_in_symval_forwarding for that. */
870 do_symval_forwarding (valcontents
)
871 register Lisp_Object valcontents
;
873 register Lisp_Object val
;
875 if (MISCP (valcontents
))
876 switch (XMISCTYPE (valcontents
))
878 case Lisp_Misc_Intfwd
:
879 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
882 case Lisp_Misc_Boolfwd
:
883 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
885 case Lisp_Misc_Objfwd
:
886 return *XOBJFWD (valcontents
)->objvar
;
888 case Lisp_Misc_Buffer_Objfwd
:
889 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
890 return PER_BUFFER_VALUE (current_buffer
, offset
);
892 case Lisp_Misc_Kboard_Objfwd
:
893 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
894 /* We used to simply use current_kboard here, but from Lisp
895 code, it's value is often unexpected. It seems nicer to
896 allow constructions like this to work as intuitively expected:
898 (with-selected-frame frame
899 (define-key local-function-map "\eOP" [f1]))
901 On the other hand, this affects the semantics of
902 last-command and real-last-command, and people may rely on
903 that. I took a quick look at the Lisp codebase, and I
904 don't think anything will break. --lorentey */
905 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
910 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
911 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
912 buffer-independent contents of the value cell: forwarded just one
913 step past the buffer-localness.
915 BUF non-zero means set the value in buffer BUF instead of the
916 current buffer. This only plays a role for per-buffer variables. */
919 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
921 register Lisp_Object valcontents
, newval
;
924 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
927 switch (XMISCTYPE (valcontents
))
929 case Lisp_Misc_Intfwd
:
930 CHECK_NUMBER (newval
);
931 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
932 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
933 error ("Value out of range for variable `%s'",
934 SDATA (SYMBOL_NAME (symbol
)));
937 case Lisp_Misc_Boolfwd
:
938 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
941 case Lisp_Misc_Objfwd
:
942 *XOBJFWD (valcontents
)->objvar
= newval
;
944 /* If this variable is a default for something stored
945 in the buffer itself, such as default-fill-column,
946 find the buffers that don't have local values for it
948 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
949 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
951 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
952 - (char *) &buffer_defaults
);
953 int idx
= PER_BUFFER_IDX (offset
);
960 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
965 buf
= Fcdr (XCAR (tail
));
966 if (!BUFFERP (buf
)) continue;
969 if (! PER_BUFFER_VALUE_P (b
, idx
))
970 PER_BUFFER_VALUE (b
, offset
) = newval
;
975 case Lisp_Misc_Buffer_Objfwd
:
977 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
980 type
= PER_BUFFER_TYPE (offset
);
981 if (! NILP (type
) && ! NILP (newval
)
982 && XTYPE (newval
) != XINT (type
))
983 buffer_slot_type_mismatch (offset
);
986 buf
= current_buffer
;
987 PER_BUFFER_VALUE (buf
, offset
) = newval
;
991 case Lisp_Misc_Kboard_Objfwd
:
993 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
994 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
995 *(Lisp_Object
*) p
= newval
;
1006 valcontents
= SYMBOL_VALUE (symbol
);
1007 if (BUFFER_LOCAL_VALUEP (valcontents
)
1008 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1009 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1011 SET_SYMBOL_VALUE (symbol
, newval
);
1015 /* Set up SYMBOL to refer to its global binding.
1016 This makes it safe to alter the status of other bindings. */
1019 swap_in_global_binding (symbol
)
1022 Lisp_Object valcontents
, cdr
;
1024 valcontents
= SYMBOL_VALUE (symbol
);
1025 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1026 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1028 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1030 /* Unload the previously loaded binding. */
1031 Fsetcdr (XCAR (cdr
),
1032 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1034 /* Select the global binding in the symbol. */
1036 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1038 /* Indicate that the global binding is set up now. */
1039 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1040 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1041 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1042 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1045 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1046 VALCONTENTS is the contents of its value cell,
1047 which points to a struct Lisp_Buffer_Local_Value.
1049 Return the value forwarded one step past the buffer-local stage.
1050 This could be another forwarding pointer. */
1053 swap_in_symval_forwarding (symbol
, valcontents
)
1054 Lisp_Object symbol
, valcontents
;
1056 register Lisp_Object tem1
;
1058 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1061 || current_buffer
!= XBUFFER (tem1
)
1062 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1063 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1065 if (XSYMBOL (symbol
)->indirect_variable
)
1066 symbol
= indirect_variable (symbol
);
1068 /* Unload the previously loaded binding. */
1069 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1071 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1072 /* Choose the new binding. */
1073 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1074 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1075 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1078 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1079 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1081 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1083 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1086 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1088 /* Load the new binding. */
1089 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1090 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1091 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1092 store_symval_forwarding (symbol
,
1093 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1096 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1099 /* Find the value of a symbol, returning Qunbound if it's not bound.
1100 This is helpful for code which just wants to get a variable's value
1101 if it has one, without signaling an error.
1102 Note that it must not be possible to quit
1103 within this function. Great care is required for this. */
1106 find_symbol_value (symbol
)
1109 register Lisp_Object valcontents
;
1110 register Lisp_Object val
;
1112 CHECK_SYMBOL (symbol
);
1113 valcontents
= SYMBOL_VALUE (symbol
);
1115 if (BUFFER_LOCAL_VALUEP (valcontents
)
1116 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1117 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1119 if (MISCP (valcontents
))
1121 switch (XMISCTYPE (valcontents
))
1123 case Lisp_Misc_Intfwd
:
1124 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1127 case Lisp_Misc_Boolfwd
:
1128 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1130 case Lisp_Misc_Objfwd
:
1131 return *XOBJFWD (valcontents
)->objvar
;
1133 case Lisp_Misc_Buffer_Objfwd
:
1134 return PER_BUFFER_VALUE (current_buffer
,
1135 XBUFFER_OBJFWD (valcontents
)->offset
);
1137 case Lisp_Misc_Kboard_Objfwd
:
1138 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1139 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1146 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1147 doc
: /* Return SYMBOL's value. Error if that is void. */)
1153 val
= find_symbol_value (symbol
);
1154 if (EQ (val
, Qunbound
))
1155 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1160 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1161 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1163 register Lisp_Object symbol
, newval
;
1165 return set_internal (symbol
, newval
, current_buffer
, 0);
1168 /* Return 1 if SYMBOL currently has a let-binding
1169 which was made in the buffer that is now current. */
1172 let_shadows_buffer_binding_p (symbol
)
1175 volatile struct specbinding
*p
;
1177 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1179 && CONSP (p
->symbol
))
1181 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1182 if ((EQ (symbol
, let_bound_symbol
)
1183 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1184 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1185 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1189 return p
>= specpdl
;
1192 /* Store the value NEWVAL into SYMBOL.
1193 If buffer-locality is an issue, BUF specifies which buffer to use.
1194 (0 stands for the current buffer.)
1196 If BINDFLAG is zero, then if this symbol is supposed to become
1197 local in every buffer where it is set, then we make it local.
1198 If BINDFLAG is nonzero, we don't do that. */
1201 set_internal (symbol
, newval
, buf
, bindflag
)
1202 register Lisp_Object symbol
, newval
;
1206 int voide
= EQ (newval
, Qunbound
);
1208 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1211 buf
= current_buffer
;
1213 /* If restoring in a dead buffer, do nothing. */
1214 if (NILP (buf
->name
))
1217 CHECK_SYMBOL (symbol
);
1218 if (SYMBOL_CONSTANT_P (symbol
)
1219 && (NILP (Fkeywordp (symbol
))
1220 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1221 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1223 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1225 if (BUFFER_OBJFWDP (valcontents
))
1227 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1228 int idx
= PER_BUFFER_IDX (offset
);
1231 && !let_shadows_buffer_binding_p (symbol
))
1232 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1234 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1235 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1237 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1238 if (XSYMBOL (symbol
)->indirect_variable
)
1239 symbol
= indirect_variable (symbol
);
1241 /* What binding is loaded right now? */
1242 current_alist_element
1243 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1245 /* If the current buffer is not the buffer whose binding is
1246 loaded, or if there may be frame-local bindings and the frame
1247 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1248 the default binding is loaded, the loaded binding may be the
1250 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1251 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1252 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1253 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1254 || (BUFFER_LOCAL_VALUEP (valcontents
)
1255 && EQ (XCAR (current_alist_element
),
1256 current_alist_element
)))
1258 /* The currently loaded binding is not necessarily valid.
1259 We need to unload it, and choose a new binding. */
1261 /* Write out `realvalue' to the old loaded binding. */
1262 Fsetcdr (current_alist_element
,
1263 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1265 /* Find the new binding. */
1266 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1267 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1268 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1272 /* This buffer still sees the default value. */
1274 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1275 or if this is `let' rather than `set',
1276 make CURRENT-ALIST-ELEMENT point to itself,
1277 indicating that we're seeing the default value.
1278 Likewise if the variable has been let-bound
1279 in the current buffer. */
1280 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1281 || let_shadows_buffer_binding_p (symbol
))
1283 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1285 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1286 tem1
= Fassq (symbol
,
1287 XFRAME (selected_frame
)->param_alist
);
1290 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1292 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1294 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1295 and we're not within a let that was made for this buffer,
1296 create a new buffer-local binding for the variable.
1297 That means, give this buffer a new assoc for a local value
1298 and load that binding. */
1301 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1302 buf
->local_var_alist
1303 = Fcons (tem1
, buf
->local_var_alist
);
1307 /* Record which binding is now loaded. */
1308 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1311 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1312 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1313 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1315 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1318 /* If storing void (making the symbol void), forward only through
1319 buffer-local indicator, not through Lisp_Objfwd, etc. */
1321 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1323 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1325 /* If we just set a variable whose current binding is frame-local,
1326 store the new value in the frame parameter too. */
1328 if (BUFFER_LOCAL_VALUEP (valcontents
)
1329 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1331 /* What binding is loaded right now? */
1332 current_alist_element
1333 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1335 /* If the current buffer is not the buffer whose binding is
1336 loaded, or if there may be frame-local bindings and the frame
1337 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1338 the default binding is loaded, the loaded binding may be the
1340 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1341 XSETCDR (current_alist_element
, newval
);
1347 /* Access or set a buffer-local symbol's default value. */
1349 /* Return the default value of SYMBOL, but don't check for voidness.
1350 Return Qunbound if it is void. */
1353 default_value (symbol
)
1356 register Lisp_Object valcontents
;
1358 CHECK_SYMBOL (symbol
);
1359 valcontents
= SYMBOL_VALUE (symbol
);
1361 /* For a built-in buffer-local variable, get the default value
1362 rather than letting do_symval_forwarding get the current value. */
1363 if (BUFFER_OBJFWDP (valcontents
))
1365 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1366 if (PER_BUFFER_IDX (offset
) != 0)
1367 return PER_BUFFER_DEFAULT (offset
);
1370 /* Handle user-created local variables. */
1371 if (BUFFER_LOCAL_VALUEP (valcontents
)
1372 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1374 /* If var is set up for a buffer that lacks a local value for it,
1375 the current value is nominally the default value.
1376 But the `realvalue' slot may be more up to date, since
1377 ordinary setq stores just that slot. So use that. */
1378 Lisp_Object current_alist_element
, alist_element_car
;
1379 current_alist_element
1380 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1381 alist_element_car
= XCAR (current_alist_element
);
1382 if (EQ (alist_element_car
, current_alist_element
))
1383 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1385 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1387 /* For other variables, get the current value. */
1388 return do_symval_forwarding (valcontents
);
1391 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1392 doc
: /* Return t if SYMBOL has a non-void default value.
1393 This is the value that is seen in buffers that do not have their own values
1394 for this variable. */)
1398 register Lisp_Object value
;
1400 value
= default_value (symbol
);
1401 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1404 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1405 doc
: /* Return SYMBOL's default value.
1406 This is the value that is seen in buffers that do not have their own values
1407 for this variable. The default value is meaningful for variables with
1408 local bindings in certain buffers. */)
1412 register Lisp_Object value
;
1414 value
= default_value (symbol
);
1415 if (EQ (value
, Qunbound
))
1416 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1420 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1421 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1422 The default value is seen in buffers that do not have their own values
1423 for this variable. */)
1425 Lisp_Object symbol
, value
;
1427 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1429 CHECK_SYMBOL (symbol
);
1430 valcontents
= SYMBOL_VALUE (symbol
);
1432 /* Handle variables like case-fold-search that have special slots
1433 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1435 if (BUFFER_OBJFWDP (valcontents
))
1437 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1438 int idx
= PER_BUFFER_IDX (offset
);
1440 PER_BUFFER_DEFAULT (offset
) = value
;
1442 /* If this variable is not always local in all buffers,
1443 set it in the buffers that don't nominally have a local value. */
1448 for (b
= all_buffers
; b
; b
= b
->next
)
1449 if (!PER_BUFFER_VALUE_P (b
, idx
))
1450 PER_BUFFER_VALUE (b
, offset
) = value
;
1455 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1456 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1457 return Fset (symbol
, value
);
1459 /* Store new value into the DEFAULT-VALUE slot. */
1460 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1462 /* If the default binding is now loaded, set the REALVALUE slot too. */
1463 current_alist_element
1464 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1465 alist_element_buffer
= Fcar (current_alist_element
);
1466 if (EQ (alist_element_buffer
, current_alist_element
))
1467 store_symval_forwarding (symbol
,
1468 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1474 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1475 doc
: /* Set the default value of variable VAR to VALUE.
1476 VAR, the variable name, is literal (not evaluated);
1477 VALUE is an expression: it is evaluated and its value returned.
1478 The default value of a variable is seen in buffers
1479 that do not have their own values for the variable.
1481 More generally, you can use multiple variables and values, as in
1482 (setq-default VAR VALUE VAR VALUE...)
1483 This sets each VAR's default value to the corresponding VALUE.
1484 The VALUE for the Nth VAR can refer to the new default values
1486 usage: (setq-default [VAR VALUE...]) */)
1490 register Lisp_Object args_left
;
1491 register Lisp_Object val
, symbol
;
1492 struct gcpro gcpro1
;
1502 val
= Feval (Fcar (Fcdr (args_left
)));
1503 symbol
= XCAR (args_left
);
1504 Fset_default (symbol
, val
);
1505 args_left
= Fcdr (XCDR (args_left
));
1507 while (!NILP (args_left
));
1513 /* Lisp functions for creating and removing buffer-local variables. */
1515 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1516 1, 1, "vMake Variable Buffer Local: ",
1517 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1518 At any time, the value for the current buffer is in effect,
1519 unless the variable has never been set in this buffer,
1520 in which case the default value is in effect.
1521 Note that binding the variable with `let', or setting it while
1522 a `let'-style binding made in this buffer is in effect,
1523 does not make the variable buffer-local. Return VARIABLE.
1525 In most cases it is better to use `make-local-variable',
1526 which makes a variable local in just one buffer.
1528 The function `default-value' gets the default value and `set-default' sets it. */)
1530 register Lisp_Object variable
;
1532 register Lisp_Object tem
, valcontents
, newval
;
1534 CHECK_SYMBOL (variable
);
1535 variable
= indirect_variable (variable
);
1537 valcontents
= SYMBOL_VALUE (variable
);
1538 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1539 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1541 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1543 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1545 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1548 if (EQ (valcontents
, Qunbound
))
1549 SET_SYMBOL_VALUE (variable
, Qnil
);
1550 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1552 newval
= allocate_misc ();
1553 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1554 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1555 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1556 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1557 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1558 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1559 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1560 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1561 SET_SYMBOL_VALUE (variable
, newval
);
1565 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1566 1, 1, "vMake Local Variable: ",
1567 doc
: /* Make VARIABLE have a separate value in the current buffer.
1568 Other buffers will continue to share a common default value.
1569 \(The buffer-local value of VARIABLE starts out as the same value
1570 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1573 If the variable is already arranged to become local when set,
1574 this function causes a local value to exist for this buffer,
1575 just as setting the variable would do.
1577 This function returns VARIABLE, and therefore
1578 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1581 See also `make-variable-buffer-local'.
1583 Do not use `make-local-variable' to make a hook variable buffer-local.
1584 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1586 register Lisp_Object variable
;
1588 register Lisp_Object tem
, valcontents
;
1590 CHECK_SYMBOL (variable
);
1591 variable
= indirect_variable (variable
);
1593 valcontents
= SYMBOL_VALUE (variable
);
1594 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1595 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1597 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1599 tem
= Fboundp (variable
);
1601 /* Make sure the symbol has a local value in this particular buffer,
1602 by setting it to the same value it already has. */
1603 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1606 /* Make sure symbol is set up to hold per-buffer values. */
1607 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1610 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1612 newval
= allocate_misc ();
1613 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1614 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1615 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1616 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1617 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1618 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1619 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1620 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1621 SET_SYMBOL_VALUE (variable
, newval
);;
1623 /* Make sure this buffer has its own value of symbol. */
1624 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1627 /* Swap out any local binding for some other buffer, and make
1628 sure the current value is permanently recorded, if it's the
1630 find_symbol_value (variable
);
1632 current_buffer
->local_var_alist
1633 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1634 current_buffer
->local_var_alist
);
1636 /* Make sure symbol does not think it is set up for this buffer;
1637 force it to look once again for this buffer's value. */
1639 Lisp_Object
*pvalbuf
;
1641 valcontents
= SYMBOL_VALUE (variable
);
1643 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1644 if (current_buffer
== XBUFFER (*pvalbuf
))
1646 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1650 /* If the symbol forwards into a C variable, then load the binding
1651 for this buffer now. If C code modifies the variable before we
1652 load the binding in, then that new value will clobber the default
1653 binding the next time we unload it. */
1654 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1655 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1656 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1661 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1662 1, 1, "vKill Local Variable: ",
1663 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1664 From now on the default value will apply in this buffer. Return VARIABLE. */)
1666 register Lisp_Object variable
;
1668 register Lisp_Object tem
, valcontents
;
1670 CHECK_SYMBOL (variable
);
1671 variable
= indirect_variable (variable
);
1673 valcontents
= SYMBOL_VALUE (variable
);
1675 if (BUFFER_OBJFWDP (valcontents
))
1677 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1678 int idx
= PER_BUFFER_IDX (offset
);
1682 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1683 PER_BUFFER_VALUE (current_buffer
, offset
)
1684 = PER_BUFFER_DEFAULT (offset
);
1689 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1690 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1693 /* Get rid of this buffer's alist element, if any. */
1695 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1697 current_buffer
->local_var_alist
1698 = Fdelq (tem
, current_buffer
->local_var_alist
);
1700 /* If the symbol is set up with the current buffer's binding
1701 loaded, recompute its value. We have to do it now, or else
1702 forwarded objects won't work right. */
1704 Lisp_Object
*pvalbuf
, buf
;
1705 valcontents
= SYMBOL_VALUE (variable
);
1706 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1707 XSETBUFFER (buf
, current_buffer
);
1708 if (EQ (buf
, *pvalbuf
))
1711 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1712 find_symbol_value (variable
);
1719 /* Lisp functions for creating and removing buffer-local variables. */
1721 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1722 1, 1, "vMake Variable Frame Local: ",
1723 doc
: /* Enable VARIABLE to have frame-local bindings.
1724 This does not create any frame-local bindings for VARIABLE,
1725 it just makes them possible.
1727 A frame-local binding is actually a frame parameter value.
1728 If a frame F has a value for the frame parameter named VARIABLE,
1729 that also acts as a frame-local binding for VARIABLE in F--
1730 provided this function has been called to enable VARIABLE
1731 to have frame-local bindings at all.
1733 The only way to create a frame-local binding for VARIABLE in a frame
1734 is to set the VARIABLE frame parameter of that frame. See
1735 `modify-frame-parameters' for how to set frame parameters.
1737 Buffer-local bindings take precedence over frame-local bindings. */)
1739 register Lisp_Object variable
;
1741 register Lisp_Object tem
, valcontents
, newval
;
1743 CHECK_SYMBOL (variable
);
1744 variable
= indirect_variable (variable
);
1746 valcontents
= SYMBOL_VALUE (variable
);
1747 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1748 || BUFFER_OBJFWDP (valcontents
))
1749 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1751 if (BUFFER_LOCAL_VALUEP (valcontents
)
1752 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1754 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1758 if (EQ (valcontents
, Qunbound
))
1759 SET_SYMBOL_VALUE (variable
, Qnil
);
1760 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1762 newval
= allocate_misc ();
1763 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1764 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1765 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1766 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1767 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1768 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1769 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1770 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1771 SET_SYMBOL_VALUE (variable
, newval
);
1775 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1777 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1778 BUFFER defaults to the current buffer. */)
1780 register Lisp_Object variable
, buffer
;
1782 Lisp_Object valcontents
;
1783 register struct buffer
*buf
;
1786 buf
= current_buffer
;
1789 CHECK_BUFFER (buffer
);
1790 buf
= XBUFFER (buffer
);
1793 CHECK_SYMBOL (variable
);
1794 variable
= indirect_variable (variable
);
1796 valcontents
= SYMBOL_VALUE (variable
);
1797 if (BUFFER_LOCAL_VALUEP (valcontents
)
1798 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1800 Lisp_Object tail
, elt
;
1802 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1805 if (EQ (variable
, XCAR (elt
)))
1809 if (BUFFER_OBJFWDP (valcontents
))
1811 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1812 int idx
= PER_BUFFER_IDX (offset
);
1813 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1819 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1821 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1822 More precisely, this means that setting the variable \(with `set' or`setq'),
1823 while it does not have a `let'-style binding that was made in BUFFER,
1824 will produce a buffer local binding. See Info node
1825 `(elisp)Creating Buffer-Local'.
1826 BUFFER defaults to the current buffer. */)
1828 register Lisp_Object variable
, buffer
;
1830 Lisp_Object valcontents
;
1831 register struct buffer
*buf
;
1834 buf
= current_buffer
;
1837 CHECK_BUFFER (buffer
);
1838 buf
= XBUFFER (buffer
);
1841 CHECK_SYMBOL (variable
);
1842 variable
= indirect_variable (variable
);
1844 valcontents
= SYMBOL_VALUE (variable
);
1846 /* This means that make-variable-buffer-local was done. */
1847 if (BUFFER_LOCAL_VALUEP (valcontents
))
1849 /* All these slots become local if they are set. */
1850 if (BUFFER_OBJFWDP (valcontents
))
1852 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1854 Lisp_Object tail
, elt
;
1855 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1858 if (EQ (variable
, XCAR (elt
)))
1865 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1867 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1868 If the current binding is buffer-local, the value is the current buffer.
1869 If the current binding is frame-local, the value is the selected frame.
1870 If the current binding is global (the default), the value is nil. */)
1872 register Lisp_Object variable
;
1874 Lisp_Object valcontents
;
1876 CHECK_SYMBOL (variable
);
1877 variable
= indirect_variable (variable
);
1879 /* Make sure the current binding is actually swapped in. */
1880 find_symbol_value (variable
);
1882 valcontents
= XSYMBOL (variable
)->value
;
1884 if (BUFFER_LOCAL_VALUEP (valcontents
)
1885 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1886 || BUFFER_OBJFWDP (valcontents
))
1888 /* For a local variable, record both the symbol and which
1889 buffer's or frame's value we are saving. */
1890 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1891 return Fcurrent_buffer ();
1892 else if (!BUFFER_OBJFWDP (valcontents
)
1893 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1894 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1900 /* This code is disabled now that we use the selected frame to return
1901 keyboard-local-values. */
1903 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1905 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1906 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1907 If SYMBOL is not a terminal-local variable, then return its normal
1908 value, like `symbol-value'.
1910 TERMINAL may be a terminal id, a frame, or nil (meaning the
1911 selected frame's terminal device). */)
1914 Lisp_Object terminal
;
1917 struct terminal
*t
= get_terminal (terminal
, 1);
1918 push_kboard (t
->kboard
);
1919 result
= Fsymbol_value (symbol
);
1924 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1925 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1926 If VARIABLE is not a terminal-local variable, then set its normal
1927 binding, like `set'.
1929 TERMINAL may be a terminal id, a frame, or nil (meaning the
1930 selected frame's terminal device). */)
1931 (symbol
, terminal
, value
)
1933 Lisp_Object terminal
;
1937 struct terminal
*t
= get_terminal (terminal
, 1);
1938 push_kboard (d
->kboard
);
1939 result
= Fset (symbol
, value
);
1945 /* Find the function at the end of a chain of symbol function indirections. */
1947 /* If OBJECT is a symbol, find the end of its function chain and
1948 return the value found there. If OBJECT is not a symbol, just
1949 return it. If there is a cycle in the function chain, signal a
1950 cyclic-function-indirection error.
1952 This is like Findirect_function, except that it doesn't signal an
1953 error if the chain ends up unbound. */
1955 indirect_function (object
)
1956 register Lisp_Object object
;
1958 Lisp_Object tortoise
, hare
;
1960 hare
= tortoise
= object
;
1964 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1966 hare
= XSYMBOL (hare
)->function
;
1967 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1969 hare
= XSYMBOL (hare
)->function
;
1971 tortoise
= XSYMBOL (tortoise
)->function
;
1973 if (EQ (hare
, tortoise
))
1974 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1980 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1981 doc
: /* Return the function at the end of OBJECT's function chain.
1982 If OBJECT is a symbol, follow all function indirections and return the final
1984 If OBJECT is not a symbol, just return it.
1985 Signal a void-function error if the final symbol is unbound.
1986 Signal a cyclic-function-indirection error if there is a loop in the
1987 function chain of symbols. */)
1989 register Lisp_Object object
;
1993 result
= indirect_function (object
);
1995 if (EQ (result
, Qunbound
))
1996 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
2000 /* Extract and set vector and string elements */
2002 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2003 doc
: /* Return the element of ARRAY at index IDX.
2004 ARRAY may be a vector, a string, a char-table, a bool-vector,
2005 or a byte-code object. IDX starts at 0. */)
2007 register Lisp_Object array
;
2010 register int idxval
;
2013 idxval
= XINT (idx
);
2014 if (STRINGP (array
))
2018 if (idxval
< 0 || idxval
>= SCHARS (array
))
2019 args_out_of_range (array
, idx
);
2020 if (! STRING_MULTIBYTE (array
))
2021 return make_number ((unsigned char) SREF (array
, idxval
));
2022 idxval_byte
= string_char_to_byte (array
, idxval
);
2024 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2025 SBYTES (array
) - idxval_byte
);
2026 return make_number (c
);
2028 else if (BOOL_VECTOR_P (array
))
2032 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2033 args_out_of_range (array
, idx
);
2035 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2036 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2038 else if (CHAR_TABLE_P (array
))
2045 args_out_of_range (array
, idx
);
2046 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2048 if (! SINGLE_BYTE_CHAR_P (idxval
))
2049 args_out_of_range (array
, idx
);
2050 /* For ASCII and 8-bit European characters, the element is
2051 stored in the top table. */
2052 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2056 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2057 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2058 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2059 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2062 val
= XCHAR_TABLE (array
)->defalt
;
2063 while (NILP (val
)) /* Follow parents until we find some value. */
2065 array
= XCHAR_TABLE (array
)->parent
;
2068 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2070 val
= XCHAR_TABLE (array
)->defalt
;
2077 Lisp_Object sub_table
;
2078 Lisp_Object current_default
;
2080 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2081 if (code
[1] < 32) code
[1] = -1;
2082 else if (code
[2] < 32) code
[2] = -1;
2084 /* Here, the possible range of CODE[0] (== charset ID) is
2085 128..MAX_CHARSET. Since the top level char table contains
2086 data for multibyte characters after 256th element, we must
2087 increment CODE[0] by 128 to get a correct index. */
2089 code
[3] = -1; /* anchor */
2091 try_parent_char_table
:
2092 current_default
= XCHAR_TABLE (array
)->defalt
;
2094 for (i
= 0; code
[i
] >= 0; i
++)
2096 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2097 if (SUB_CHAR_TABLE_P (val
))
2100 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2101 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2106 val
= current_default
;
2109 array
= XCHAR_TABLE (array
)->parent
;
2111 goto try_parent_char_table
;
2116 /* Reaching here means IDXVAL is a generic character in
2117 which each character or a group has independent value.
2118 Essentially it's nonsense to get a value for such a
2119 generic character, but for backward compatibility, we try
2120 the default value and parent. */
2121 val
= current_default
;
2124 array
= XCHAR_TABLE (array
)->parent
;
2126 goto try_parent_char_table
;
2134 if (VECTORP (array
))
2135 size
= XVECTOR (array
)->size
;
2136 else if (COMPILEDP (array
))
2137 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2139 wrong_type_argument (Qarrayp
, array
);
2141 if (idxval
< 0 || idxval
>= size
)
2142 args_out_of_range (array
, idx
);
2143 return XVECTOR (array
)->contents
[idxval
];
2147 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2148 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2149 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2150 bool-vector. IDX starts at 0. */)
2151 (array
, idx
, newelt
)
2152 register Lisp_Object array
;
2153 Lisp_Object idx
, newelt
;
2155 register int idxval
;
2158 idxval
= XINT (idx
);
2159 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
2160 && ! CHAR_TABLE_P (array
))
2161 array
= wrong_type_argument (Qarrayp
, array
);
2162 CHECK_IMPURE (array
);
2164 if (VECTORP (array
))
2166 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2167 args_out_of_range (array
, idx
);
2168 XVECTOR (array
)->contents
[idxval
] = newelt
;
2170 else if (BOOL_VECTOR_P (array
))
2174 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2175 args_out_of_range (array
, idx
);
2177 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2179 if (! NILP (newelt
))
2180 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2182 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2183 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2185 else if (CHAR_TABLE_P (array
))
2188 args_out_of_range (array
, idx
);
2189 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2191 if (! SINGLE_BYTE_CHAR_P (idxval
))
2192 args_out_of_range (array
, idx
);
2193 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2200 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2201 if (code
[1] < 32) code
[1] = -1;
2202 else if (code
[2] < 32) code
[2] = -1;
2204 /* See the comment of the corresponding part in Faref. */
2206 code
[3] = -1; /* anchor */
2207 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2209 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2210 if (SUB_CHAR_TABLE_P (val
))
2216 /* VAL is a leaf. Create a sub char table with the
2217 initial value VAL and look into it. */
2219 temp
= make_sub_char_table (val
);
2220 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2224 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2227 else if (STRING_MULTIBYTE (array
))
2229 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2230 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2232 if (idxval
< 0 || idxval
>= SCHARS (array
))
2233 args_out_of_range (array
, idx
);
2234 CHECK_NUMBER (newelt
);
2236 nbytes
= SBYTES (array
);
2238 idxval_byte
= string_char_to_byte (array
, idxval
);
2239 p1
= SDATA (array
) + idxval_byte
;
2240 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2241 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2242 if (prev_bytes
!= new_bytes
)
2244 /* We must relocate the string data. */
2245 int nchars
= SCHARS (array
);
2249 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2250 bcopy (SDATA (array
), str
, nbytes
);
2251 allocate_string_data (XSTRING (array
), nchars
,
2252 nbytes
+ new_bytes
- prev_bytes
);
2253 bcopy (str
, SDATA (array
), idxval_byte
);
2254 p1
= SDATA (array
) + idxval_byte
;
2255 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2256 nbytes
- (idxval_byte
+ prev_bytes
));
2258 clear_string_char_byte_cache ();
2265 if (idxval
< 0 || idxval
>= SCHARS (array
))
2266 args_out_of_range (array
, idx
);
2267 CHECK_NUMBER (newelt
);
2269 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2270 SSET (array
, idxval
, XINT (newelt
));
2273 /* We must relocate the string data while converting it to
2275 int idxval_byte
, prev_bytes
, new_bytes
;
2276 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2277 unsigned char *origstr
= SDATA (array
), *str
;
2281 nchars
= SCHARS (array
);
2282 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2283 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2285 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2286 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2287 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2289 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2290 allocate_string_data (XSTRING (array
), nchars
,
2291 nbytes
+ new_bytes
- prev_bytes
);
2292 bcopy (str
, SDATA (array
), idxval_byte
);
2293 p1
= SDATA (array
) + idxval_byte
;
2296 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2297 nbytes
- (idxval_byte
+ prev_bytes
));
2299 clear_string_char_byte_cache ();
2306 /* Arithmetic functions */
2308 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2311 arithcompare (num1
, num2
, comparison
)
2312 Lisp_Object num1
, num2
;
2313 enum comparison comparison
;
2315 double f1
= 0, f2
= 0;
2318 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2319 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2321 if (FLOATP (num1
) || FLOATP (num2
))
2324 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2325 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2331 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2336 if (floatp
? f1
!= f2
: XINT (num1
) != 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
))
2365 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2366 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2368 register Lisp_Object num1
, num2
;
2370 return arithcompare (num1
, num2
, equal
);
2373 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2374 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2376 register Lisp_Object num1
, num2
;
2378 return arithcompare (num1
, num2
, less
);
2381 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2382 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2384 register Lisp_Object num1
, num2
;
2386 return arithcompare (num1
, num2
, grtr
);
2389 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2390 doc
: /* Return t if first arg is less than or equal to second arg.
2391 Both must be numbers or markers. */)
2393 register Lisp_Object num1
, num2
;
2395 return arithcompare (num1
, num2
, less_or_equal
);
2398 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2399 doc
: /* Return t if first arg is greater than or equal to second arg.
2400 Both must be numbers or markers. */)
2402 register Lisp_Object num1
, num2
;
2404 return arithcompare (num1
, num2
, grtr_or_equal
);
2407 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2408 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2410 register Lisp_Object num1
, num2
;
2412 return arithcompare (num1
, num2
, notequal
);
2415 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2416 doc
: /* Return t if NUMBER is zero. */)
2418 register Lisp_Object number
;
2420 CHECK_NUMBER_OR_FLOAT (number
);
2422 if (FLOATP (number
))
2424 if (XFLOAT_DATA (number
) == 0.0)
2434 /* Convert between long values and pairs of Lisp integers. */
2440 unsigned long top
= i
>> 16;
2441 unsigned int bot
= i
& 0xFFFF;
2443 return make_number (bot
);
2444 if (top
== (unsigned long)-1 >> 16)
2445 return Fcons (make_number (-1), make_number (bot
));
2446 return Fcons (make_number (top
), make_number (bot
));
2453 Lisp_Object top
, bot
;
2460 return ((XINT (top
) << 16) | XINT (bot
));
2463 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2464 doc
: /* Return the decimal representation of NUMBER as a string.
2465 Uses a minus sign if negative.
2466 NUMBER may be an integer or a floating point number. */)
2470 char buffer
[VALBITS
];
2472 CHECK_NUMBER_OR_FLOAT (number
);
2474 if (FLOATP (number
))
2476 char pigbuf
[350]; /* see comments in float_to_string */
2478 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2479 return build_string (pigbuf
);
2482 if (sizeof (int) == sizeof (EMACS_INT
))
2483 sprintf (buffer
, "%d", XINT (number
));
2484 else if (sizeof (long) == sizeof (EMACS_INT
))
2485 sprintf (buffer
, "%ld", (long) XINT (number
));
2488 return build_string (buffer
);
2492 digit_to_number (character
, base
)
2493 int character
, base
;
2497 if (character
>= '0' && character
<= '9')
2498 digit
= character
- '0';
2499 else if (character
>= 'a' && character
<= 'z')
2500 digit
= character
- 'a' + 10;
2501 else if (character
>= 'A' && character
<= 'Z')
2502 digit
= character
- 'A' + 10;
2512 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2513 doc
: /* Parse STRING as a decimal number and return the number.
2514 This parses both integers and floating point numbers.
2515 It ignores leading spaces and tabs.
2517 If BASE, interpret STRING as a number in that base. If BASE isn't
2518 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2519 If the base used is not 10, floating point is not recognized. */)
2521 register Lisp_Object string
, base
;
2523 register unsigned char *p
;
2528 CHECK_STRING (string
);
2534 CHECK_NUMBER (base
);
2536 if (b
< 2 || b
> 16)
2537 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2540 /* Skip any whitespace at the front of the number. Some versions of
2541 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2543 while (*p
== ' ' || *p
== '\t')
2554 if (isfloat_string (p
) && b
== 10)
2555 val
= make_float (sign
* atof (p
));
2562 int digit
= digit_to_number (*p
++, b
);
2568 val
= make_fixnum_or_float (sign
* v
);
2588 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2589 int, Lisp_Object
*));
2590 extern Lisp_Object
fmod_float ();
2593 arith_driver (code
, nargs
, args
)
2596 register Lisp_Object
*args
;
2598 register Lisp_Object val
;
2599 register int argnum
;
2600 register EMACS_INT accum
= 0;
2601 register EMACS_INT next
;
2603 switch (SWITCH_ENUM_CAST (code
))
2621 for (argnum
= 0; argnum
< nargs
; argnum
++)
2623 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2625 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2628 return float_arith_driver ((double) accum
, argnum
, code
,
2631 next
= XINT (args
[argnum
]);
2632 switch (SWITCH_ENUM_CAST (code
))
2638 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2649 Fsignal (Qarith_error
, Qnil
);
2663 if (!argnum
|| next
> accum
)
2667 if (!argnum
|| next
< accum
)
2673 XSETINT (val
, accum
);
2678 #define isnan(x) ((x) != (x))
2681 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2683 register int argnum
;
2686 register Lisp_Object
*args
;
2688 register Lisp_Object val
;
2691 for (; argnum
< nargs
; argnum
++)
2693 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2694 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2698 next
= XFLOAT_DATA (val
);
2702 args
[argnum
] = val
; /* runs into a compiler bug. */
2703 next
= XINT (args
[argnum
]);
2705 switch (SWITCH_ENUM_CAST (code
))
2711 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2721 if (! IEEE_FLOATING_POINT
&& next
== 0)
2722 Fsignal (Qarith_error
, Qnil
);
2729 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2731 if (!argnum
|| isnan (next
) || next
> accum
)
2735 if (!argnum
|| isnan (next
) || next
< accum
)
2741 return make_float (accum
);
2745 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2746 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2747 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2752 return arith_driver (Aadd
, nargs
, args
);
2755 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2756 doc
: /* Negate number or subtract numbers or markers and return the result.
2757 With one arg, negates it. With more than one arg,
2758 subtracts all but the first from the first.
2759 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2764 return arith_driver (Asub
, nargs
, args
);
2767 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2768 doc
: /* Return product of any number of arguments, which are numbers or markers.
2769 usage: (* &rest NUMBERS-OR-MARKERS) */)
2774 return arith_driver (Amult
, nargs
, args
);
2777 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2778 doc
: /* Return first argument divided by all the remaining arguments.
2779 The arguments must be numbers or markers.
2780 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2786 for (argnum
= 2; argnum
< nargs
; argnum
++)
2787 if (FLOATP (args
[argnum
]))
2788 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2789 return arith_driver (Adiv
, nargs
, args
);
2792 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2793 doc
: /* Return remainder of X divided by Y.
2794 Both must be integers or markers. */)
2796 register Lisp_Object x
, y
;
2800 CHECK_NUMBER_COERCE_MARKER (x
);
2801 CHECK_NUMBER_COERCE_MARKER (y
);
2803 if (XFASTINT (y
) == 0)
2804 Fsignal (Qarith_error
, Qnil
);
2806 XSETINT (val
, XINT (x
) % XINT (y
));
2820 /* If the magnitude of the result exceeds that of the divisor, or
2821 the sign of the result does not agree with that of the dividend,
2822 iterate with the reduced value. This does not yield a
2823 particularly accurate result, but at least it will be in the
2824 range promised by fmod. */
2826 r
-= f2
* floor (r
/ f2
);
2827 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2831 #endif /* ! HAVE_FMOD */
2833 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2834 doc
: /* Return X modulo Y.
2835 The result falls between zero (inclusive) and Y (exclusive).
2836 Both X and Y must be numbers or markers. */)
2838 register Lisp_Object x
, y
;
2843 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2844 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2846 if (FLOATP (x
) || FLOATP (y
))
2847 return fmod_float (x
, y
);
2853 Fsignal (Qarith_error
, Qnil
);
2857 /* If the "remainder" comes out with the wrong sign, fix it. */
2858 if (i2
< 0 ? i1
> 0 : i1
< 0)
2865 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2866 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2867 The value is always a number; markers are converted to numbers.
2868 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2873 return arith_driver (Amax
, nargs
, args
);
2876 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2877 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2878 The value is always a number; markers are converted to numbers.
2879 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2884 return arith_driver (Amin
, nargs
, args
);
2887 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2888 doc
: /* Return bitwise-and of all the arguments.
2889 Arguments may be integers, or markers converted to integers.
2890 usage: (logand &rest INTS-OR-MARKERS) */)
2895 return arith_driver (Alogand
, nargs
, args
);
2898 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2899 doc
: /* Return bitwise-or of all the arguments.
2900 Arguments may be integers, or markers converted to integers.
2901 usage: (logior &rest INTS-OR-MARKERS) */)
2906 return arith_driver (Alogior
, nargs
, args
);
2909 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2910 doc
: /* Return bitwise-exclusive-or of all the arguments.
2911 Arguments may be integers, or markers converted to integers.
2912 usage: (logxor &rest INTS-OR-MARKERS) */)
2917 return arith_driver (Alogxor
, nargs
, args
);
2920 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2921 doc
: /* Return VALUE with its bits shifted left by COUNT.
2922 If COUNT is negative, shifting is actually to the right.
2923 In this case, the sign bit is duplicated. */)
2925 register Lisp_Object value
, count
;
2927 register Lisp_Object val
;
2929 CHECK_NUMBER (value
);
2930 CHECK_NUMBER (count
);
2932 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2934 else if (XINT (count
) > 0)
2935 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2936 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2937 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2939 XSETINT (val
, XINT (value
) >> -XINT (count
));
2943 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2944 doc
: /* Return VALUE with its bits shifted left by COUNT.
2945 If COUNT is negative, shifting is actually to the right.
2946 In this case, zeros are shifted in on the left. */)
2948 register Lisp_Object value
, count
;
2950 register Lisp_Object val
;
2952 CHECK_NUMBER (value
);
2953 CHECK_NUMBER (count
);
2955 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2957 else if (XINT (count
) > 0)
2958 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2959 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2962 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2966 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2967 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2968 Markers are converted to integers. */)
2970 register Lisp_Object number
;
2972 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2974 if (FLOATP (number
))
2975 return (make_float (1.0 + XFLOAT_DATA (number
)));
2977 XSETINT (number
, XINT (number
) + 1);
2981 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2982 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2983 Markers are converted to integers. */)
2985 register Lisp_Object number
;
2987 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2989 if (FLOATP (number
))
2990 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2992 XSETINT (number
, XINT (number
) - 1);
2996 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2997 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2999 register Lisp_Object number
;
3001 CHECK_NUMBER (number
);
3002 XSETINT (number
, ~XINT (number
));
3006 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3007 doc
: /* Return the byteorder for the machine.
3008 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3009 lowercase l) for small endian machines. */)
3012 unsigned i
= 0x04030201;
3013 int order
= *(char *)&i
== 1 ? 108 : 66;
3015 return make_number (order
);
3023 Lisp_Object error_tail
, arith_tail
;
3025 Qquote
= intern ("quote");
3026 Qlambda
= intern ("lambda");
3027 Qsubr
= intern ("subr");
3028 Qerror_conditions
= intern ("error-conditions");
3029 Qerror_message
= intern ("error-message");
3030 Qtop_level
= intern ("top-level");
3032 Qerror
= intern ("error");
3033 Qquit
= intern ("quit");
3034 Qwrong_type_argument
= intern ("wrong-type-argument");
3035 Qargs_out_of_range
= intern ("args-out-of-range");
3036 Qvoid_function
= intern ("void-function");
3037 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3038 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3039 Qvoid_variable
= intern ("void-variable");
3040 Qsetting_constant
= intern ("setting-constant");
3041 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3043 Qinvalid_function
= intern ("invalid-function");
3044 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3045 Qno_catch
= intern ("no-catch");
3046 Qend_of_file
= intern ("end-of-file");
3047 Qarith_error
= intern ("arith-error");
3048 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3049 Qend_of_buffer
= intern ("end-of-buffer");
3050 Qbuffer_read_only
= intern ("buffer-read-only");
3051 Qtext_read_only
= intern ("text-read-only");
3052 Qmark_inactive
= intern ("mark-inactive");
3054 Qlistp
= intern ("listp");
3055 Qconsp
= intern ("consp");
3056 Qsymbolp
= intern ("symbolp");
3057 Qkeywordp
= intern ("keywordp");
3058 Qintegerp
= intern ("integerp");
3059 Qnatnump
= intern ("natnump");
3060 Qwholenump
= intern ("wholenump");
3061 Qstringp
= intern ("stringp");
3062 Qarrayp
= intern ("arrayp");
3063 Qsequencep
= intern ("sequencep");
3064 Qbufferp
= intern ("bufferp");
3065 Qvectorp
= intern ("vectorp");
3066 Qchar_or_string_p
= intern ("char-or-string-p");
3067 Qmarkerp
= intern ("markerp");
3068 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3069 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3070 Qboundp
= intern ("boundp");
3071 Qfboundp
= intern ("fboundp");
3073 Qfloatp
= intern ("floatp");
3074 Qnumberp
= intern ("numberp");
3075 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3077 Qchar_table_p
= intern ("char-table-p");
3078 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3080 Qsubrp
= intern ("subrp");
3081 Qunevalled
= intern ("unevalled");
3082 Qmany
= intern ("many");
3084 Qcdr
= intern ("cdr");
3086 /* Handle automatic advice activation */
3087 Qad_advice_info
= intern ("ad-advice-info");
3088 Qad_activate_internal
= intern ("ad-activate-internal");
3090 error_tail
= Fcons (Qerror
, Qnil
);
3092 /* ERROR is used as a signaler for random errors for which nothing else is right */
3094 Fput (Qerror
, Qerror_conditions
,
3096 Fput (Qerror
, Qerror_message
,
3097 build_string ("error"));
3099 Fput (Qquit
, Qerror_conditions
,
3100 Fcons (Qquit
, Qnil
));
3101 Fput (Qquit
, Qerror_message
,
3102 build_string ("Quit"));
3104 Fput (Qwrong_type_argument
, Qerror_conditions
,
3105 Fcons (Qwrong_type_argument
, error_tail
));
3106 Fput (Qwrong_type_argument
, Qerror_message
,
3107 build_string ("Wrong type argument"));
3109 Fput (Qargs_out_of_range
, Qerror_conditions
,
3110 Fcons (Qargs_out_of_range
, error_tail
));
3111 Fput (Qargs_out_of_range
, Qerror_message
,
3112 build_string ("Args out of range"));
3114 Fput (Qvoid_function
, Qerror_conditions
,
3115 Fcons (Qvoid_function
, error_tail
));
3116 Fput (Qvoid_function
, Qerror_message
,
3117 build_string ("Symbol's function definition is void"));
3119 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3120 Fcons (Qcyclic_function_indirection
, error_tail
));
3121 Fput (Qcyclic_function_indirection
, Qerror_message
,
3122 build_string ("Symbol's chain of function indirections contains a loop"));
3124 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3125 Fcons (Qcyclic_variable_indirection
, error_tail
));
3126 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3127 build_string ("Symbol's chain of variable indirections contains a loop"));
3129 Qcircular_list
= intern ("circular-list");
3130 staticpro (&Qcircular_list
);
3131 Fput (Qcircular_list
, Qerror_conditions
,
3132 Fcons (Qcircular_list
, error_tail
));
3133 Fput (Qcircular_list
, Qerror_message
,
3134 build_string ("List contains a loop"));
3136 Fput (Qvoid_variable
, Qerror_conditions
,
3137 Fcons (Qvoid_variable
, error_tail
));
3138 Fput (Qvoid_variable
, Qerror_message
,
3139 build_string ("Symbol's value as variable is void"));
3141 Fput (Qsetting_constant
, Qerror_conditions
,
3142 Fcons (Qsetting_constant
, error_tail
));
3143 Fput (Qsetting_constant
, Qerror_message
,
3144 build_string ("Attempt to set a constant symbol"));
3146 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3147 Fcons (Qinvalid_read_syntax
, error_tail
));
3148 Fput (Qinvalid_read_syntax
, Qerror_message
,
3149 build_string ("Invalid read syntax"));
3151 Fput (Qinvalid_function
, Qerror_conditions
,
3152 Fcons (Qinvalid_function
, error_tail
));
3153 Fput (Qinvalid_function
, Qerror_message
,
3154 build_string ("Invalid function"));
3156 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3157 Fcons (Qwrong_number_of_arguments
, error_tail
));
3158 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3159 build_string ("Wrong number of arguments"));
3161 Fput (Qno_catch
, Qerror_conditions
,
3162 Fcons (Qno_catch
, error_tail
));
3163 Fput (Qno_catch
, Qerror_message
,
3164 build_string ("No catch for tag"));
3166 Fput (Qend_of_file
, Qerror_conditions
,
3167 Fcons (Qend_of_file
, error_tail
));
3168 Fput (Qend_of_file
, Qerror_message
,
3169 build_string ("End of file during parsing"));
3171 arith_tail
= Fcons (Qarith_error
, error_tail
);
3172 Fput (Qarith_error
, Qerror_conditions
,
3174 Fput (Qarith_error
, Qerror_message
,
3175 build_string ("Arithmetic error"));
3177 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3178 Fcons (Qbeginning_of_buffer
, error_tail
));
3179 Fput (Qbeginning_of_buffer
, Qerror_message
,
3180 build_string ("Beginning of buffer"));
3182 Fput (Qend_of_buffer
, Qerror_conditions
,
3183 Fcons (Qend_of_buffer
, error_tail
));
3184 Fput (Qend_of_buffer
, Qerror_message
,
3185 build_string ("End of buffer"));
3187 Fput (Qbuffer_read_only
, Qerror_conditions
,
3188 Fcons (Qbuffer_read_only
, error_tail
));
3189 Fput (Qbuffer_read_only
, Qerror_message
,
3190 build_string ("Buffer is read-only"));
3192 Fput (Qtext_read_only
, Qerror_conditions
,
3193 Fcons (Qtext_read_only
, error_tail
));
3194 Fput (Qtext_read_only
, Qerror_message
,
3195 build_string ("Text is read-only"));
3197 Qrange_error
= intern ("range-error");
3198 Qdomain_error
= intern ("domain-error");
3199 Qsingularity_error
= intern ("singularity-error");
3200 Qoverflow_error
= intern ("overflow-error");
3201 Qunderflow_error
= intern ("underflow-error");
3203 Fput (Qdomain_error
, Qerror_conditions
,
3204 Fcons (Qdomain_error
, arith_tail
));
3205 Fput (Qdomain_error
, Qerror_message
,
3206 build_string ("Arithmetic domain error"));
3208 Fput (Qrange_error
, Qerror_conditions
,
3209 Fcons (Qrange_error
, arith_tail
));
3210 Fput (Qrange_error
, Qerror_message
,
3211 build_string ("Arithmetic range error"));
3213 Fput (Qsingularity_error
, Qerror_conditions
,
3214 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3215 Fput (Qsingularity_error
, Qerror_message
,
3216 build_string ("Arithmetic singularity error"));
3218 Fput (Qoverflow_error
, Qerror_conditions
,
3219 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3220 Fput (Qoverflow_error
, Qerror_message
,
3221 build_string ("Arithmetic overflow error"));
3223 Fput (Qunderflow_error
, Qerror_conditions
,
3224 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3225 Fput (Qunderflow_error
, Qerror_message
,
3226 build_string ("Arithmetic underflow error"));
3228 staticpro (&Qrange_error
);
3229 staticpro (&Qdomain_error
);
3230 staticpro (&Qsingularity_error
);
3231 staticpro (&Qoverflow_error
);
3232 staticpro (&Qunderflow_error
);
3236 staticpro (&Qquote
);
3237 staticpro (&Qlambda
);
3239 staticpro (&Qunbound
);
3240 staticpro (&Qerror_conditions
);
3241 staticpro (&Qerror_message
);
3242 staticpro (&Qtop_level
);
3244 staticpro (&Qerror
);
3246 staticpro (&Qwrong_type_argument
);
3247 staticpro (&Qargs_out_of_range
);
3248 staticpro (&Qvoid_function
);
3249 staticpro (&Qcyclic_function_indirection
);
3250 staticpro (&Qcyclic_variable_indirection
);
3251 staticpro (&Qvoid_variable
);
3252 staticpro (&Qsetting_constant
);
3253 staticpro (&Qinvalid_read_syntax
);
3254 staticpro (&Qwrong_number_of_arguments
);
3255 staticpro (&Qinvalid_function
);
3256 staticpro (&Qno_catch
);
3257 staticpro (&Qend_of_file
);
3258 staticpro (&Qarith_error
);
3259 staticpro (&Qbeginning_of_buffer
);
3260 staticpro (&Qend_of_buffer
);
3261 staticpro (&Qbuffer_read_only
);
3262 staticpro (&Qtext_read_only
);
3263 staticpro (&Qmark_inactive
);
3265 staticpro (&Qlistp
);
3266 staticpro (&Qconsp
);
3267 staticpro (&Qsymbolp
);
3268 staticpro (&Qkeywordp
);
3269 staticpro (&Qintegerp
);
3270 staticpro (&Qnatnump
);
3271 staticpro (&Qwholenump
);
3272 staticpro (&Qstringp
);
3273 staticpro (&Qarrayp
);
3274 staticpro (&Qsequencep
);
3275 staticpro (&Qbufferp
);
3276 staticpro (&Qvectorp
);
3277 staticpro (&Qchar_or_string_p
);
3278 staticpro (&Qmarkerp
);
3279 staticpro (&Qbuffer_or_string_p
);
3280 staticpro (&Qinteger_or_marker_p
);
3281 staticpro (&Qfloatp
);
3282 staticpro (&Qnumberp
);
3283 staticpro (&Qnumber_or_marker_p
);
3284 staticpro (&Qchar_table_p
);
3285 staticpro (&Qvector_or_char_table_p
);
3286 staticpro (&Qsubrp
);
3288 staticpro (&Qunevalled
);
3290 staticpro (&Qboundp
);
3291 staticpro (&Qfboundp
);
3293 staticpro (&Qad_advice_info
);
3294 staticpro (&Qad_activate_internal
);
3296 /* Types that type-of returns. */
3297 Qinteger
= intern ("integer");
3298 Qsymbol
= intern ("symbol");
3299 Qstring
= intern ("string");
3300 Qcons
= intern ("cons");
3301 Qmarker
= intern ("marker");
3302 Qoverlay
= intern ("overlay");
3303 Qfloat
= intern ("float");
3304 Qwindow_configuration
= intern ("window-configuration");
3305 Qprocess
= intern ("process");
3306 Qwindow
= intern ("window");
3307 /* Qsubr = intern ("subr"); */
3308 Qcompiled_function
= intern ("compiled-function");
3309 Qbuffer
= intern ("buffer");
3310 Qframe
= intern ("frame");
3311 Qvector
= intern ("vector");
3312 Qchar_table
= intern ("char-table");
3313 Qbool_vector
= intern ("bool-vector");
3314 Qhash_table
= intern ("hash-table");
3316 staticpro (&Qinteger
);
3317 staticpro (&Qsymbol
);
3318 staticpro (&Qstring
);
3320 staticpro (&Qmarker
);
3321 staticpro (&Qoverlay
);
3322 staticpro (&Qfloat
);
3323 staticpro (&Qwindow_configuration
);
3324 staticpro (&Qprocess
);
3325 staticpro (&Qwindow
);
3326 /* staticpro (&Qsubr); */
3327 staticpro (&Qcompiled_function
);
3328 staticpro (&Qbuffer
);
3329 staticpro (&Qframe
);
3330 staticpro (&Qvector
);
3331 staticpro (&Qchar_table
);
3332 staticpro (&Qbool_vector
);
3333 staticpro (&Qhash_table
);
3335 defsubr (&Sindirect_variable
);
3336 defsubr (&Sinteractive_form
);
3339 defsubr (&Stype_of
);
3344 defsubr (&Sintegerp
);
3345 defsubr (&Sinteger_or_marker_p
);
3346 defsubr (&Snumberp
);
3347 defsubr (&Snumber_or_marker_p
);
3349 defsubr (&Snatnump
);
3350 defsubr (&Ssymbolp
);
3351 defsubr (&Skeywordp
);
3352 defsubr (&Sstringp
);
3353 defsubr (&Smultibyte_string_p
);
3354 defsubr (&Svectorp
);
3355 defsubr (&Schar_table_p
);
3356 defsubr (&Svector_or_char_table_p
);
3357 defsubr (&Sbool_vector_p
);
3359 defsubr (&Ssequencep
);
3360 defsubr (&Sbufferp
);
3361 defsubr (&Smarkerp
);
3363 defsubr (&Sbyte_code_function_p
);
3364 defsubr (&Schar_or_string_p
);
3367 defsubr (&Scar_safe
);
3368 defsubr (&Scdr_safe
);
3371 defsubr (&Ssymbol_function
);
3372 defsubr (&Sindirect_function
);
3373 defsubr (&Ssymbol_plist
);
3374 defsubr (&Ssymbol_name
);
3375 defsubr (&Smakunbound
);
3376 defsubr (&Sfmakunbound
);
3378 defsubr (&Sfboundp
);
3380 defsubr (&Sdefalias
);
3381 defsubr (&Ssetplist
);
3382 defsubr (&Ssymbol_value
);
3384 defsubr (&Sdefault_boundp
);
3385 defsubr (&Sdefault_value
);
3386 defsubr (&Sset_default
);
3387 defsubr (&Ssetq_default
);
3388 defsubr (&Smake_variable_buffer_local
);
3389 defsubr (&Smake_local_variable
);
3390 defsubr (&Skill_local_variable
);
3391 defsubr (&Smake_variable_frame_local
);
3392 defsubr (&Slocal_variable_p
);
3393 defsubr (&Slocal_variable_if_set_p
);
3394 defsubr (&Svariable_binding_locus
);
3395 #if 0 /* XXX Remove this. --lorentey */
3396 defsubr (&Sterminal_local_value
);
3397 defsubr (&Sset_terminal_local_value
);
3401 defsubr (&Snumber_to_string
);
3402 defsubr (&Sstring_to_number
);
3403 defsubr (&Seqlsign
);
3426 defsubr (&Sbyteorder
);
3427 defsubr (&Ssubr_arity
);
3428 defsubr (&Ssubr_name
);
3430 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3432 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3433 doc
: /* The largest value that is representable in a Lisp integer. */);
3434 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3436 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3437 doc
: /* The smallest value that is representable in a Lisp integer. */);
3438 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3445 #if defined(USG) && !defined(POSIX_SIGNALS)
3446 /* USG systems forget handlers when they are used;
3447 must reestablish each time */
3448 signal (signo
, arith_error
);
3451 /* VMS systems are like USG. */
3452 signal (signo
, arith_error
);
3456 #else /* not BSD4_1 */
3457 sigsetmask (SIGEMPTYMASK
);
3458 #endif /* not BSD4_1 */
3460 SIGNAL_THREAD_CHECK (signo
);
3461 Fsignal (Qarith_error
, Qnil
);
3467 /* Don't do this if just dumping out.
3468 We don't want to call `signal' in this case
3469 so that we don't have trouble with dumping
3470 signal-delivering routines in an inconsistent state. */
3474 #endif /* CANNOT_DUMP */
3475 signal (SIGFPE
, arith_error
);
3478 signal (SIGEMT
, arith_error
);
3482 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3483 (do not change this comment) */