1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
53 extern double atof ();
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
, Qthread_local_mark
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
87 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
96 Lisp_Object impl_Vmost_positive_fixnum
, impl_Vmost_negative_fixnum
;
99 circular_list_error (list
)
102 xsignal (Qcircular_list
, list
);
107 wrong_type_argument (predicate
, value
)
108 register Lisp_Object predicate
, value
;
110 /* If VALUE is not even a valid Lisp object, we'd want to abort here
111 where we can get a backtrace showing where it came from. We used
112 to try and do that by checking the tagbits, but nowadays all
113 tagbits are potentially valid. */
114 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
117 xsignal2 (Qwrong_type_argument
, predicate
, value
);
123 error ("Attempt to modify read-only object");
127 args_out_of_range (a1
, a2
)
130 xsignal2 (Qargs_out_of_range
, a1
, a2
);
134 args_out_of_range_3 (a1
, a2
, a3
)
135 Lisp_Object a1
, a2
, a3
;
137 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
140 /* On some machines, XINT needs a temporary location.
141 Here it is, in case it is needed. */
143 int sign_extend_temp
;
145 /* On a few machines, XINT can only be done by calling this. */
148 sign_extend_lisp_int (num
)
151 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
152 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
154 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
157 /* Data type predicates */
159 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
160 doc
: /* Return t if the two args are the same Lisp object. */)
162 Lisp_Object obj1
, obj2
;
169 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
170 doc
: /* Return t if OBJECT is nil. */)
179 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
180 doc
: /* Return a symbol representing the type of OBJECT.
181 The symbol returned names the object's basic type;
182 for example, (type-of 1) returns `integer'. */)
186 switch (XTYPE (object
))
201 switch (XMISCTYPE (object
))
203 case Lisp_Misc_Marker
:
205 case Lisp_Misc_Overlay
:
207 case Lisp_Misc_Float
:
212 case Lisp_Vectorlike
:
213 if (WINDOW_CONFIGURATIONP (object
))
214 return Qwindow_configuration
;
215 if (PROCESSP (object
))
217 if (WINDOWP (object
))
221 if (COMPILEDP (object
))
222 return Qcompiled_function
;
223 if (BUFFERP (object
))
225 if (CHAR_TABLE_P (object
))
227 if (BOOL_VECTOR_P (object
))
231 if (HASH_TABLE_P (object
))
233 if (FONT_SPEC_P (object
))
235 if (FONT_ENTITY_P (object
))
237 if (FONT_OBJECT_P (object
))
249 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
250 doc
: /* Return t if OBJECT is a cons cell. */)
259 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
260 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
269 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
270 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
271 Otherwise, return nil. */)
275 if (CONSP (object
) || NILP (object
))
280 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
281 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
285 if (CONSP (object
) || NILP (object
))
290 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
291 doc
: /* Return t if OBJECT is a symbol. */)
295 if (SYMBOLP (object
))
300 /* Define this in C to avoid unnecessarily consing up the symbol
302 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
303 doc
: /* Return t if OBJECT is a keyword.
304 This means that it is a symbol with a print name beginning with `:'
305 interned in the initial obarray. */)
310 && SREF (SYMBOL_NAME (object
), 0) == ':'
311 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
316 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
317 doc
: /* Return t if OBJECT is a vector. */)
321 if (VECTORP (object
))
326 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
327 doc
: /* Return t if OBJECT is a string. */)
331 if (STRINGP (object
))
336 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
338 doc
: /* Return t if OBJECT is a multibyte string. */)
342 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
347 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
348 doc
: /* Return t if OBJECT is a char-table. */)
352 if (CHAR_TABLE_P (object
))
357 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
358 Svector_or_char_table_p
, 1, 1, 0,
359 doc
: /* Return t if OBJECT is a char-table or vector. */)
363 if (VECTORP (object
) || CHAR_TABLE_P (object
))
368 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
369 doc
: /* Return t if OBJECT is a bool-vector. */)
373 if (BOOL_VECTOR_P (object
))
378 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
379 doc
: /* Return t if OBJECT is an array (string or vector). */)
388 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
389 doc
: /* Return t if OBJECT is a sequence (list or array). */)
391 register Lisp_Object object
;
393 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
398 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
399 doc
: /* Return t if OBJECT is an editor buffer. */)
403 if (BUFFERP (object
))
408 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
409 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
413 if (MARKERP (object
))
418 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a built-in function. */)
428 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
430 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
434 if (COMPILEDP (object
))
439 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
440 doc
: /* Return t if OBJECT is a character or a string. */)
442 register Lisp_Object object
;
444 if (CHARACTERP (object
) || STRINGP (object
))
449 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
450 doc
: /* Return t if OBJECT is an integer. */)
454 if (INTEGERP (object
))
459 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
460 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
462 register Lisp_Object object
;
464 if (MARKERP (object
) || INTEGERP (object
))
469 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
470 doc
: /* Return t if OBJECT is a nonnegative integer. */)
474 if (NATNUMP (object
))
479 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
480 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
484 if (NUMBERP (object
))
490 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
491 Snumber_or_marker_p
, 1, 1, 0,
492 doc
: /* Return t if OBJECT is a number or a marker. */)
496 if (NUMBERP (object
) || MARKERP (object
))
501 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
502 doc
: /* Return t if OBJECT is a floating point number. */)
512 /* Extract and set components of lists */
514 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
515 doc
: /* Return the car of LIST. If arg is nil, return nil.
516 Error if arg is not nil and not a cons cell. See also `car-safe'.
518 See Info node `(elisp)Cons Cells' for a discussion of related basic
519 Lisp concepts such as car, cdr, cons cell and list. */)
521 register Lisp_Object list
;
526 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
527 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
531 return CAR_SAFE (object
);
534 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
535 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
536 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
538 See Info node `(elisp)Cons Cells' for a discussion of related basic
539 Lisp concepts such as cdr, car, cons cell and list. */)
541 register Lisp_Object list
;
546 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
547 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
551 return CDR_SAFE (object
);
554 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
555 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
557 register Lisp_Object cell
, newcar
;
561 XSETCAR (cell
, newcar
);
565 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
566 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
568 register Lisp_Object cell
, newcdr
;
572 XSETCDR (cell
, newcdr
);
576 /* Extract and set components of symbols */
578 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
579 doc
: /* Return t if SYMBOL's value is not void. */)
581 register Lisp_Object symbol
;
583 Lisp_Object valcontents
;
585 valcontents
= find_symbol_value (symbol
);
587 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
590 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
591 doc
: /* Return t if SYMBOL's function definition is not void. */)
593 register Lisp_Object symbol
;
595 CHECK_SYMBOL (symbol
);
596 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
599 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
600 doc
: /* Make SYMBOL's value be void.
603 register Lisp_Object symbol
;
605 CHECK_SYMBOL (symbol
);
606 if (SYMBOL_CONSTANT_P (symbol
))
607 xsignal1 (Qsetting_constant
, symbol
);
608 Fset (symbol
, Qunbound
);
612 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
613 doc
: /* Make SYMBOL's function definition be void.
616 register Lisp_Object symbol
;
618 CHECK_SYMBOL (symbol
);
619 if (NILP (symbol
) || EQ (symbol
, Qt
))
620 xsignal1 (Qsetting_constant
, symbol
);
621 XSYMBOL (symbol
)->function
= Qunbound
;
625 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
626 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
628 register Lisp_Object symbol
;
630 CHECK_SYMBOL (symbol
);
631 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
632 return XSYMBOL (symbol
)->function
;
633 xsignal1 (Qvoid_function
, symbol
);
636 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
637 doc
: /* Return SYMBOL's property list. */)
639 register Lisp_Object symbol
;
641 CHECK_SYMBOL (symbol
);
642 return XSYMBOL (symbol
)->plist
;
645 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
646 doc
: /* Return SYMBOL's name, a string. */)
648 register Lisp_Object symbol
;
650 register Lisp_Object name
;
652 CHECK_SYMBOL (symbol
);
653 name
= SYMBOL_NAME (symbol
);
657 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
658 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
660 register Lisp_Object symbol
, definition
;
662 register Lisp_Object function
;
664 CHECK_SYMBOL (symbol
);
665 if (NILP (symbol
) || EQ (symbol
, Qt
))
666 xsignal1 (Qsetting_constant
, symbol
);
668 function
= XSYMBOL (symbol
)->function
;
670 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
671 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
673 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
674 Fput (symbol
, Qautoload
, XCDR (function
));
676 XSYMBOL (symbol
)->function
= definition
;
677 /* Handle automatic advice activation */
678 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
680 call2 (Qad_activate_internal
, symbol
, Qnil
);
681 definition
= XSYMBOL (symbol
)->function
;
686 extern Lisp_Object Qfunction_documentation
;
688 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
689 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
690 Associates the function with the current load file, if any.
691 The optional third argument DOCSTRING specifies the documentation string
692 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
693 determined by DEFINITION. */)
694 (symbol
, definition
, docstring
)
695 register Lisp_Object symbol
, definition
, docstring
;
697 CHECK_SYMBOL (symbol
);
698 if (CONSP (XSYMBOL (symbol
)->function
)
699 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
700 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
701 definition
= Ffset (symbol
, definition
);
702 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
703 if (!NILP (docstring
))
704 Fput (symbol
, Qfunction_documentation
, docstring
);
708 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
709 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
711 register Lisp_Object symbol
, newplist
;
713 CHECK_SYMBOL (symbol
);
714 XSYMBOL (symbol
)->plist
= newplist
;
718 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
719 doc
: /* Return minimum and maximum number of args allowed for SUBR.
720 SUBR must be a built-in function.
721 The returned value is a pair (MIN . MAX). MIN is the minimum number
722 of args. MAX is the maximum number or the symbol `many', for a
723 function with `&rest' args, or `unevalled' for a special form. */)
727 short minargs
, maxargs
;
729 minargs
= XSUBR (subr
)->min_args
;
730 maxargs
= XSUBR (subr
)->max_args
;
732 return Fcons (make_number (minargs
), Qmany
);
733 else if (maxargs
== UNEVALLED
)
734 return Fcons (make_number (minargs
), Qunevalled
);
736 return Fcons (make_number (minargs
), make_number (maxargs
));
739 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
740 doc
: /* Return name of subroutine SUBR.
741 SUBR must be a built-in function. */)
747 name
= XSUBR (subr
)->symbol_name
;
748 return make_string (name
, strlen (name
));
751 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
752 doc
: /* Return the interactive form of CMD or nil if none.
753 If CMD is not a command, the return value is nil.
754 Value, if non-nil, is a list \(interactive SPEC). */)
758 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
760 if (NILP (fun
) || EQ (fun
, Qunbound
))
763 /* Use an `interactive-form' property if present, analogous to the
764 function-documentation property. */
766 while (SYMBOLP (fun
))
768 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
772 fun
= Fsymbol_function (fun
);
777 char *spec
= XSUBR (fun
)->intspec
;
779 return list2 (Qinteractive
,
780 (*spec
!= '(') ? build_string (spec
) :
781 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
783 else if (COMPILEDP (fun
))
785 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
786 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
788 else if (CONSP (fun
))
790 Lisp_Object funcar
= XCAR (fun
);
791 if (EQ (funcar
, Qlambda
))
792 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
793 else if (EQ (funcar
, Qautoload
))
797 do_autoload (fun
, cmd
);
799 return Finteractive_form (cmd
);
806 /***********************************************************************
807 Getting and Setting Values of Symbols
808 ***********************************************************************/
811 blocal_getrealvalue (struct Lisp_Buffer_Local_Value
*blv
)
813 return &XCDR_AS_LVALUE (ensure_thread_local (&(blv
->realvalue
)));
817 blocal_get_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object symbol
)
819 Lisp_Object ret
= assq_no_quit (get_current_thread (), l
->thread_data
);
822 Lisp_Object tem
, val
, len
;
827 XSETFASTINT (len
, 4);
828 ret
= Fmake_vector (len
, Qnil
);
830 BLOCAL_CLEAR_FLAGS_VEC (ret
);
831 tem
= Fcons (Qnil
, Qnil
);
832 val
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
833 if (NILP (val
) || (l
->check_frame
&& ! EQ (selected_frame
, Qnil
)))
835 val
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
837 BLOCAL_SET_FOUND_FOR_FRAME_VEC (ret
);
840 val
= XTHREADLOCAL (l
->realvalue
)->global
;
848 XSETCDR (tem
, XTHREADLOCAL (l
->realvalue
)->global
);
849 BLOCAL_SET_FOUND_FOR_BUFFER_VEC (ret
);
852 BLOCAL_BUFFER_VEC (ret
) = Fcurrent_buffer ();
853 BLOCAL_FRAME_VEC (ret
) = Qnil
;
854 BLOCAL_CDR_VEC (ret
) = tem
;
856 ret
= Fcons (get_current_thread (), ret
);
857 l
->thread_data
= Fcons (ret
, l
->thread_data
);
858 XTHREADLOCAL (l
->realvalue
)->thread_alist
=
859 Fcons (Fcons (get_current_thread (), val
),
860 XTHREADLOCAL (l
->realvalue
)->thread_alist
);
863 return &XCDR_AS_LVALUE (ret
);
866 /* Remove any thread-local data. */
868 blocal_unbind_thread (Lisp_Object thread
)
872 struct Lisp_Vector
*obarray
= XVECTOR (Vobarray
);
873 for (i
= 0; i
< obarray
->size
; i
++)
875 struct Lisp_Symbol
*sym
;
877 if (!SYMBOLP (obarray
->contents
[i
]))
880 sym
= XSYMBOL (obarray
->contents
[i
]);
882 #define UNBIND_LOCAL_VALUE(X) do { \
883 Lisp_Object tem = assq_no_quit (thread, (X)); \
885 (X) = Fdelq (tem, (X)); \
888 if (BUFFER_LOCAL_VALUEP (SYMBOL_VALUE (obarray
->contents
[i
])))
890 struct Lisp_Buffer_Local_Value
*loc
891 = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (obarray
->contents
[i
]));
893 UNBIND_LOCAL_VALUE (loc
->realvalue
);
894 UNBIND_LOCAL_VALUE (loc
->thread_data
);
897 if (THREADLOCALP (SYMBOL_VALUE (obarray
->contents
[i
])))
899 struct Lisp_ThreadLocal
*val
900 = XTHREADLOCAL (SYMBOL_VALUE (obarray
->contents
[i
]));
901 UNBIND_LOCAL_VALUE (val
->thread_alist
);
904 #undef UNBIND_LOCAL_VALUE
908 blocal_set_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object obj
)
910 if (! NILP (l
->thread_data
))
913 l
->thread_data
= Fcons (Fcons (get_current_thread (), obj
), Qnil
);
917 find_variable_location (Lisp_Object
*root
)
919 if (THREADLOCALP (*root
))
921 struct Lisp_ThreadLocal
*thr
= XTHREADLOCAL (*root
);
922 Lisp_Object cons
= assq_no_quit (get_current_thread (),
924 if (!EQ (cons
, Qnil
))
925 return &XCDR_AS_LVALUE (cons
);
934 ensure_thread_local (Lisp_Object
*root
)
938 if (THREADLOCALP (*root
))
939 cons
= assq_no_quit (get_current_thread (),
940 XTHREADLOCAL (*root
)->thread_alist
);
944 newval
= allocate_misc ();
945 XMISCTYPE (newval
) = Lisp_Misc_ThreadLocal
;
946 XTHREADLOCAL (newval
)->global
= *root
;
947 XTHREADLOCAL (newval
)->thread_alist
= Qnil
;
954 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
955 cons
= Fcons (get_current_thread (), Qthread_local_mark
);
956 local
->thread_alist
= Fcons (cons
, local
->thread_alist
);
963 remove_thread_local (Lisp_Object
*root
)
965 if (THREADLOCALP (*root
))
967 Lisp_Object iter
, thr
= get_current_thread (), prior
= Qnil
;
968 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
969 for (iter
= local
->thread_alist
; !NILP (iter
); iter
= XCDR (iter
))
971 if (EQ (XCAR (XCAR (iter
)), thr
))
974 local
->thread_alist
= XCDR (iter
);
976 XSETCDR (prior
, XCDR (iter
));
984 /* Return the symbol holding SYMBOL's value. Signal
985 `cyclic-variable-indirection' if SYMBOL's chain of variable
986 indirections contains a loop. */
989 indirect_variable (symbol
)
990 struct Lisp_Symbol
*symbol
;
992 struct Lisp_Symbol
*tortoise
, *hare
;
994 hare
= tortoise
= symbol
;
996 while (hare
->indirect_variable
)
998 hare
= XSYMBOL (hare
->value
);
999 if (!hare
->indirect_variable
)
1002 hare
= XSYMBOL (hare
->value
);
1003 tortoise
= XSYMBOL (tortoise
->value
);
1005 if (hare
== tortoise
)
1008 XSETSYMBOL (tem
, symbol
);
1009 xsignal1 (Qcyclic_variable_indirection
, tem
);
1017 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
1018 doc
: /* Return the variable at the end of OBJECT's variable chain.
1019 If OBJECT is a symbol, follow all variable indirections and return the final
1020 variable. If OBJECT is not a symbol, just return it.
1021 Signal a cyclic-variable-indirection error if there is a loop in the
1022 variable chain of symbols. */)
1026 if (SYMBOLP (object
))
1027 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
1032 /* Given the raw contents of a symbol value cell,
1033 return the Lisp value of the symbol.
1034 This does not handle buffer-local variables; use
1035 swap_in_symval_forwarding for that. */
1038 do_symval_forwarding (valcontents
)
1039 Lisp_Object valcontents
;
1041 register Lisp_Object val
;
1042 if (MISCP (valcontents
))
1043 switch (XMISCTYPE (valcontents
))
1045 case Lisp_Misc_Intfwd
:
1046 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1049 case Lisp_Misc_Boolfwd
:
1050 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1052 case Lisp_Misc_Objfwd
:
1053 return *XOBJFWD (valcontents
)->objvar
;
1055 case Lisp_Misc_Buffer_Objfwd
:
1056 return PER_BUFFER_VALUE (current_buffer
,
1057 XBUFFER_OBJFWD (valcontents
)->offset
);
1059 case Lisp_Misc_Kboard_Objfwd
:
1060 /* We used to simply use current_kboard here, but from Lisp
1061 code, it's value is often unexpected. It seems nicer to
1062 allow constructions like this to work as intuitively expected:
1064 (with-selected-frame frame
1065 (define-key local-function-map "\eOP" [f1]))
1067 On the other hand, this affects the semantics of
1068 last-command and real-last-command, and people may rely on
1069 that. I took a quick look at the Lisp codebase, and I
1070 don't think anything will break. --lorentey */
1071 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1072 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1074 case Lisp_Misc_ThreadLocal
:
1075 return *find_variable_location (&valcontents
);
1080 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1081 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1082 buffer-independent contents of the value cell: forwarded just one
1083 step past the buffer-localness.
1085 BUF non-zero means set the value in buffer BUF instead of the
1086 current buffer. This only plays a role for per-buffer variables. */
1089 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
1091 register Lisp_Object valcontents
, newval
;
1094 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
1097 switch (XMISCTYPE (valcontents
))
1099 case Lisp_Misc_Intfwd
:
1100 CHECK_NUMBER (newval
);
1101 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1102 /* This can never happen since intvar points to an EMACS_INT
1103 which is at least large enough to hold a Lisp_Object.
1104 if (*XINTFWD (valcontents)->intvar != XINT (newval))
1105 error ("Value out of range for variable `%s'",
1106 SDATA (SYMBOL_NAME (symbol))); */
1109 case Lisp_Misc_Boolfwd
:
1110 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1113 case Lisp_Misc_Objfwd
:
1114 *find_variable_location (XOBJFWD (valcontents
)->objvar
) = newval
;
1116 /* If this variable is a default for something stored
1117 in the buffer itself, such as default-fill-column,
1118 find the buffers that don't have local values for it
1120 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1121 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1123 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1124 - (char *) &buffer_defaults
);
1125 int idx
= PER_BUFFER_IDX (offset
);
1132 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
1137 buf
= Fcdr (XCAR (tail
));
1138 if (!BUFFERP (buf
)) continue;
1141 if (! PER_BUFFER_VALUE_P (b
, idx
))
1142 SET_PER_BUFFER_VALUE_RAW (b
, offset
, newval
);
1147 case Lisp_Misc_Buffer_Objfwd
:
1149 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1150 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1152 if (!(NILP (type
) || NILP (newval
)
1153 || (XINT (type
) == LISP_INT_TAG
1155 : XTYPE (newval
) == XINT (type
))))
1156 buffer_slot_type_mismatch (newval
, XINT (type
));
1159 buf
= current_buffer
;
1160 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1164 case Lisp_Misc_Kboard_Objfwd
:
1166 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1167 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1168 *(Lisp_Object
*) p
= newval
;
1179 valcontents
= SYMBOL_VALUE (symbol
);
1180 if (BUFFER_LOCAL_VALUEP (valcontents
))
1181 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)) = newval
;
1182 else if (THREADLOCALP (valcontents
))
1184 Lisp_Object val
= indirect_variable (XSYMBOL (symbol
))->value
;
1185 val
= ensure_thread_local (&val
);
1186 XSETCDR (val
, newval
);
1189 SET_SYMBOL_VALUE (symbol
, newval
);
1193 /* Set up SYMBOL to refer to its global binding.
1194 This makes it safe to alter the status of other bindings. */
1197 swap_in_global_binding (symbol
)
1200 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1201 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1202 Lisp_Object cdr
= BLOCAL_CDR (blv
);
1204 /* Unload the previously loaded binding. */
1205 Fsetcdr (XCAR (cdr
),
1206 do_symval_forwarding (BLOCAL_REALVALUE (blv
)));
1208 /* Select the global binding in the symbol. */
1210 store_symval_forwarding (symbol
, BLOCAL_REALVALUE (blv
), XCDR (cdr
), NULL
);
1212 /* Indicate that the global binding is set up now. */
1213 BLOCAL_FRAME (blv
) = Qnil
;
1214 BLOCAL_BUFFER (blv
) = Qnil
;
1215 BLOCAL_CLEAR_FLAGS (blv
);
1218 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1219 VALCONTENTS is the contents of its value cell,
1220 which points to a struct Lisp_Buffer_Local_Value.
1222 Return the value forwarded one step past the buffer-local stage.
1223 This could be another forwarding pointer. */
1226 swap_in_symval_forwarding (symbol
, valcontents
)
1227 Lisp_Object symbol
, valcontents
;
1229 register Lisp_Object tem1
;
1231 struct Lisp_Buffer_Local_Value
*local
= XBUFFER_LOCAL_VALUE (valcontents
);
1232 blocal_get_thread_data (local
, symbol
);
1233 tem1
= BLOCAL_BUFFER (local
);
1236 || current_buffer
!= XBUFFER (tem1
)
1237 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1238 && ! EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))))
1240 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1241 if (sym
->indirect_variable
)
1243 sym
= indirect_variable (sym
);
1244 XSETSYMBOL (symbol
, sym
);
1247 /* Unload the previously loaded binding. */
1248 tem1
= XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1250 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1252 /* Choose the new binding. */
1253 tem1
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1254 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1257 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1258 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1260 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1262 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1265 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1267 /* Load the new binding. */
1268 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1269 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), current_buffer
);
1270 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1271 store_symval_forwarding (symbol
,
1272 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1276 return BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1280 /* Find the value of a symbol, returning Qunbound if it's not bound.
1281 This is helpful for code which just wants to get a variable's value
1282 if it has one, without signaling an error.
1283 Note that it must not be possible to quit
1284 within this function. Great care is required for this. */
1287 find_symbol_value (symbol
)
1290 register Lisp_Object valcontents
;
1291 register Lisp_Object val
;
1293 CHECK_SYMBOL (symbol
);
1294 valcontents
= SYMBOL_VALUE (symbol
);
1296 if (BUFFER_LOCAL_VALUEP (valcontents
))
1297 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1299 return do_symval_forwarding (valcontents
);
1302 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1303 doc
: /* Return SYMBOL's value. Error if that is void. */)
1309 val
= find_symbol_value (symbol
);
1310 if (!EQ (val
, Qunbound
))
1313 xsignal1 (Qvoid_variable
, symbol
);
1316 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1317 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1319 register Lisp_Object symbol
, newval
;
1321 return set_internal (symbol
, newval
, current_buffer
, 0);
1324 /* Return 1 if SYMBOL currently has a let-binding
1325 which was made in the buffer that is now current. */
1328 let_shadows_buffer_binding_p (symbol
)
1329 struct Lisp_Symbol
*symbol
;
1331 volatile struct specbinding
*p
;
1333 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1335 && CONSP (p
->symbol
))
1337 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1338 if ((symbol
== let_bound_symbol
1339 || (let_bound_symbol
->indirect_variable
1340 && symbol
== indirect_variable (let_bound_symbol
)))
1341 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1345 return p
>= specpdl
;
1348 /* Store the value NEWVAL into SYMBOL.
1349 If buffer-locality is an issue, BUF specifies which buffer to use.
1350 (0 stands for the current buffer.)
1352 If BINDFLAG is zero, then if this symbol is supposed to become
1353 local in every buffer where it is set, then we make it local.
1354 If BINDFLAG is nonzero, we don't do that. */
1357 set_internal (symbol
, newval
, buf
, bindflag
)
1358 register Lisp_Object symbol
, newval
;
1362 int voide
= EQ (newval
, Qunbound
);
1364 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1367 buf
= current_buffer
;
1369 /* If restoring in a dead buffer, do nothing. */
1370 if (NILP (BUF_NAME (buf
)))
1373 CHECK_SYMBOL (symbol
);
1374 if (SYMBOL_CONSTANT_P (symbol
)
1375 && (NILP (Fkeywordp (symbol
))
1376 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1377 xsignal1 (Qsetting_constant
, symbol
);
1379 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1381 if (BUFFER_OBJFWDP (valcontents
))
1383 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1384 int idx
= PER_BUFFER_IDX (offset
);
1387 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1388 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1390 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1392 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1393 if (XSYMBOL (symbol
)->indirect_variable
)
1394 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1396 /* What binding is loaded right now? */
1397 current_alist_element
1398 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1400 /* If the current buffer is not the buffer whose binding is
1401 loaded, or if there may be frame-local bindings and the frame
1402 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1403 the default binding is loaded, the loaded binding may be the
1405 if (!BUFFERP (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1406 || buf
!= XBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1407 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1408 && !EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
))))
1409 /* Also unload a global binding (if the var is local_if_set). */
1410 || (EQ (XCAR (current_alist_element
),
1411 current_alist_element
)))
1413 /* The currently loaded binding is not necessarily valid.
1414 We need to unload it, and choose a new binding. */
1416 /* Write out `realvalue' to the old loaded binding. */
1417 Fsetcdr (current_alist_element
,
1418 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1420 /* Find the new binding. */
1421 tem1
= Fassq (symbol
, BUF_LOCAL_VAR_ALIST (buf
));
1422 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1426 /* This buffer still sees the default value. */
1428 /* If the variable is not local_if_set,
1429 or if this is `let' rather than `set',
1430 make CURRENT-ALIST-ELEMENT point to itself,
1431 indicating that we're seeing the default value.
1432 Likewise if the variable has been let-bound
1433 in the current buffer. */
1434 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1435 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1437 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1439 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1440 tem1
= Fassq (symbol
,
1441 XFRAME (selected_frame
)->param_alist
);
1444 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1446 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1448 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1449 and we're not within a let that was made for this buffer,
1450 create a new buffer-local binding for the variable.
1451 That means, give this buffer a new assoc for a local value
1452 and load that binding. */
1455 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1456 BUF_LOCAL_VAR_ALIST (buf
)
1457 = Fcons (tem1
, BUF_LOCAL_VAR_ALIST (buf
));
1461 /* Record which binding is now loaded. */
1462 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1464 /* Set `buffer' and `frame' slots for the binding now loaded. */
1465 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), buf
);
1466 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1468 innercontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1470 /* Store the new value in the cons-cell. */
1471 XSETCDR (XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
))), newval
);
1474 /* If storing void (making the symbol void), forward only through
1475 buffer-local indicator, not through Lisp_Objfwd, etc. */
1477 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1479 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1484 /* Access or set a buffer-local symbol's default value. */
1486 /* Return the default value of SYMBOL, but don't check for voidness.
1487 Return Qunbound if it is void. */
1490 default_value (symbol
)
1493 register Lisp_Object valcontents
;
1495 CHECK_SYMBOL (symbol
);
1496 valcontents
= SYMBOL_VALUE (symbol
);
1498 /* For a built-in buffer-local variable, get the default value
1499 rather than letting do_symval_forwarding get the current value. */
1500 if (BUFFER_OBJFWDP (valcontents
))
1502 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1503 if (PER_BUFFER_IDX (offset
) != 0)
1504 return PER_BUFFER_DEFAULT (offset
);
1507 /* Handle user-created local variables. */
1508 if (BUFFER_LOCAL_VALUEP (valcontents
))
1510 /* If var is set up for a buffer that lacks a local value for it,
1511 the current value is nominally the default value.
1512 But the `realvalue' slot may be more up to date, since
1513 ordinary setq stores just that slot. So use that. */
1514 Lisp_Object current_alist_element
, alist_element_car
;
1515 current_alist_element
1516 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1517 alist_element_car
= XCAR (current_alist_element
);
1518 if (EQ (alist_element_car
, current_alist_element
))
1519 return do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)));
1521 return XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1523 /* For other variables, get the current value. */
1524 return do_symval_forwarding (valcontents
);
1527 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1528 doc
: /* Return t if SYMBOL has a non-void default value.
1529 This is the value that is seen in buffers that do not have their own values
1530 for this variable. */)
1534 register Lisp_Object value
;
1536 value
= default_value (symbol
);
1537 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1540 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1541 doc
: /* Return SYMBOL's default value.
1542 This is the value that is seen in buffers that do not have their own values
1543 for this variable. The default value is meaningful for variables with
1544 local bindings in certain buffers. */)
1548 register Lisp_Object value
;
1550 value
= default_value (symbol
);
1551 if (!EQ (value
, Qunbound
))
1554 xsignal1 (Qvoid_variable
, symbol
);
1557 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1558 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1559 The default value is seen in buffers that do not have their own values
1560 for this variable. */)
1562 Lisp_Object symbol
, value
;
1564 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1566 CHECK_SYMBOL (symbol
);
1567 valcontents
= SYMBOL_VALUE (symbol
);
1569 /* Handle variables like case-fold-search that have special slots
1570 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1572 if (BUFFER_OBJFWDP (valcontents
))
1574 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1575 int idx
= PER_BUFFER_IDX (offset
);
1577 PER_BUFFER_DEFAULT (offset
) = value
;
1579 /* If this variable is not always local in all buffers,
1580 set it in the buffers that don't nominally have a local value. */
1585 for (b
= all_buffers
; b
; b
= b
->next
)
1586 if (!PER_BUFFER_VALUE_P (b
, idx
))
1587 PER_BUFFER_VALUE (b
, offset
) = value
;
1592 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1593 return Fset (symbol
, value
);
1595 /* Store new value into the DEFAULT-VALUE slot. */
1596 XSETCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), value
);
1598 /* If the default binding is now loaded, set the REALVALUE slot too. */
1599 current_alist_element
1600 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1601 alist_element_buffer
= Fcar (current_alist_element
);
1602 if (EQ (alist_element_buffer
, current_alist_element
))
1603 store_symval_forwarding (symbol
,
1604 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1610 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1611 doc
: /* Set the default value of variable VAR to VALUE.
1612 VAR, the variable name, is literal (not evaluated);
1613 VALUE is an expression: it is evaluated and its value returned.
1614 The default value of a variable is seen in buffers
1615 that do not have their own values for the variable.
1617 More generally, you can use multiple variables and values, as in
1618 (setq-default VAR VALUE VAR VALUE...)
1619 This sets each VAR's default value to the corresponding VALUE.
1620 The VALUE for the Nth VAR can refer to the new default values
1622 usage: (setq-default [VAR VALUE]...) */)
1626 register Lisp_Object args_left
;
1627 register Lisp_Object val
, symbol
;
1628 struct gcpro gcpro1
;
1638 val
= Feval (Fcar (Fcdr (args_left
)));
1639 symbol
= XCAR (args_left
);
1640 Fset_default (symbol
, val
);
1641 args_left
= Fcdr (XCDR (args_left
));
1643 while (!NILP (args_left
));
1649 /* Lisp functions for creating and removing buffer-local variables. */
1651 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1652 1, 1, "vMake Variable Buffer Local: ",
1653 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1654 At any time, the value for the current buffer is in effect,
1655 unless the variable has never been set in this buffer,
1656 in which case the default value is in effect.
1657 Note that binding the variable with `let', or setting it while
1658 a `let'-style binding made in this buffer is in effect,
1659 does not make the variable buffer-local. Return VARIABLE.
1661 In most cases it is better to use `make-local-variable',
1662 which makes a variable local in just one buffer.
1664 The function `default-value' gets the default value and `set-default' sets it. */)
1666 register Lisp_Object variable
;
1668 register Lisp_Object tem
, valcontents
, newval
;
1669 struct Lisp_Symbol
*sym
;
1671 CHECK_SYMBOL (variable
);
1672 sym
= indirect_variable (XSYMBOL (variable
));
1674 valcontents
= sym
->value
;
1675 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1676 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1678 if (BUFFER_OBJFWDP (valcontents
))
1680 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1682 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1683 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1684 newval
= valcontents
;
1688 Lisp_Object len
, val_vec
;
1689 XSETFASTINT (len
, 4);
1690 val_vec
= Fmake_vector (len
, Qnil
);
1691 if (EQ (valcontents
, Qunbound
))
1693 tem
= Fcons (Qnil
, valcontents
);
1695 newval
= allocate_misc ();
1696 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1697 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1698 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1699 BLOCAL_BUFFER_VEC (val_vec
) = Fcurrent_buffer ();
1700 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1701 BLOCAL_CDR_VEC (val_vec
) = tem
;
1702 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1703 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1704 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1705 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1706 = Lisp_Misc_ThreadLocal
;
1707 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1709 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1710 = Fcons (Fcons (get_current_thread (), valcontents
), Qnil
);
1711 sym
->value
= newval
;
1713 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1717 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1718 1, 1, "vMake Local Variable: ",
1719 doc
: /* Make VARIABLE have a separate value in the current buffer.
1720 Other buffers will continue to share a common default value.
1721 \(The buffer-local value of VARIABLE starts out as the same value
1722 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1725 If the variable is already arranged to become local when set,
1726 this function causes a local value to exist for this buffer,
1727 just as setting the variable would do.
1729 This function returns VARIABLE, and therefore
1730 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1733 See also `make-variable-buffer-local'.
1735 Do not use `make-local-variable' to make a hook variable buffer-local.
1736 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1738 register Lisp_Object variable
;
1740 register Lisp_Object tem
, valcontents
;
1741 struct Lisp_Symbol
*sym
;
1743 CHECK_SYMBOL (variable
);
1744 sym
= indirect_variable (XSYMBOL (variable
));
1746 valcontents
= sym
->value
;
1747 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1748 || (BUFFER_LOCAL_VALUEP (valcontents
)
1749 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1750 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1752 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1753 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1754 || BUFFER_OBJFWDP (valcontents
))
1756 tem
= Fboundp (variable
);
1758 /* Make sure the symbol has a local value in this particular buffer,
1759 by setting it to the same value it already has. */
1760 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1763 /* Make sure symbol is set up to hold per-buffer values. */
1764 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1766 Lisp_Object newval
, len
, val_vec
;
1767 XSETFASTINT (len
, 4);
1768 val_vec
= Fmake_vector (len
, Qnil
);
1769 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1771 newval
= allocate_misc ();
1772 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1773 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1774 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1775 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1776 BLOCAL_CDR_VEC (val_vec
) = tem
;
1777 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1778 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1779 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1780 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1781 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1782 = Lisp_Misc_ThreadLocal
;
1783 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1785 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1786 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1787 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1788 sym
->value
= newval
;
1790 /* Make sure this buffer has its own value of symbol. */
1791 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1792 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1795 /* Swap out any local binding for some other buffer, and make
1796 sure the current value is permanently recorded, if it's the
1798 find_symbol_value (variable
);
1800 BUF_LOCAL_VAR_ALIST (current_buffer
)
1801 = Fcons (Fcons (variable
, XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (sym
->value
)))),
1802 BUF_LOCAL_VAR_ALIST (current_buffer
));
1804 /* Make sure symbol does not think it is set up for this buffer;
1805 force it to look once again for this buffer's value. */
1807 Lisp_Object
*pvalbuf
;
1809 valcontents
= sym
->value
;
1811 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1812 if (current_buffer
== XBUFFER (*pvalbuf
))
1814 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1818 /* If the symbol forwards into a C variable, then load the binding
1819 for this buffer now. If C code modifies the variable before we
1820 load the binding in, then that new value will clobber the default
1821 binding the next time we unload it. */
1822 valcontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (sym
->value
));
1823 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1824 swap_in_symval_forwarding (variable
, sym
->value
);
1829 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1830 1, 1, "vKill Local Variable: ",
1831 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1832 From now on the default value will apply in this buffer. Return VARIABLE. */)
1834 register Lisp_Object variable
;
1836 register Lisp_Object tem
, valcontents
;
1837 struct Lisp_Symbol
*sym
;
1839 CHECK_SYMBOL (variable
);
1840 sym
= indirect_variable (XSYMBOL (variable
));
1842 valcontents
= sym
->value
;
1844 if (BUFFER_OBJFWDP (valcontents
))
1846 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1847 int idx
= PER_BUFFER_IDX (offset
);
1851 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1852 PER_BUFFER_VALUE (current_buffer
, offset
)
1853 = PER_BUFFER_DEFAULT (offset
);
1858 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1861 /* Get rid of this buffer's alist element, if any. */
1862 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1863 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1865 BUF_LOCAL_VAR_ALIST (current_buffer
)
1866 = Fdelq (tem
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1868 /* If the symbol is set up with the current buffer's binding
1869 loaded, recompute its value. We have to do it now, or else
1870 forwarded objects won't work right. */
1872 Lisp_Object
*pvalbuf
, buf
;
1873 valcontents
= sym
->value
;
1874 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1875 XSETBUFFER (buf
, current_buffer
);
1876 if (EQ (buf
, *pvalbuf
))
1879 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1880 find_symbol_value (variable
);
1887 /* Lisp functions for creating and removing buffer-local variables. */
1889 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1890 when/if this is removed. */
1892 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1893 1, 1, "vMake Variable Frame Local: ",
1894 doc
: /* Enable VARIABLE to have frame-local bindings.
1895 This does not create any frame-local bindings for VARIABLE,
1896 it just makes them possible.
1898 A frame-local binding is actually a frame parameter value.
1899 If a frame F has a value for the frame parameter named VARIABLE,
1900 that also acts as a frame-local binding for VARIABLE in F--
1901 provided this function has been called to enable VARIABLE
1902 to have frame-local bindings at all.
1904 The only way to create a frame-local binding for VARIABLE in a frame
1905 is to set the VARIABLE frame parameter of that frame. See
1906 `modify-frame-parameters' for how to set frame parameters.
1908 Note that since Emacs 23.1, variables cannot be both buffer-local and
1909 frame-local any more (buffer-local bindings used to take precedence over
1910 frame-local bindings). */)
1912 register Lisp_Object variable
;
1914 register Lisp_Object tem
, valcontents
, newval
, val_vec
, len
;
1915 struct Lisp_Symbol
*sym
;
1917 CHECK_SYMBOL (variable
);
1918 sym
= indirect_variable (XSYMBOL (variable
));
1920 valcontents
= sym
->value
;
1921 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1922 || BUFFER_OBJFWDP (valcontents
))
1923 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1925 if (BUFFER_LOCAL_VALUEP (valcontents
))
1927 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1928 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1932 if (EQ (valcontents
, Qunbound
))
1934 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1936 newval
= allocate_misc ();
1937 XSETFASTINT (len
, 4);
1938 val_vec
= Fmake_vector (len
, Qnil
);
1939 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1940 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1941 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1942 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1943 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1944 BLOCAL_CDR_VEC (val_vec
) = tem
;
1945 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1946 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1947 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1948 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1949 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1950 = Lisp_Misc_ThreadLocal
;
1951 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1953 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1954 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1955 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1956 sym
->value
= newval
;
1960 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1962 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1963 BUFFER defaults to the current buffer. */)
1965 register Lisp_Object variable
, buffer
;
1967 Lisp_Object valcontents
;
1968 register struct buffer
*buf
;
1969 struct Lisp_Symbol
*sym
;
1972 buf
= current_buffer
;
1975 CHECK_BUFFER (buffer
);
1976 buf
= XBUFFER (buffer
);
1979 CHECK_SYMBOL (variable
);
1980 sym
= indirect_variable (XSYMBOL (variable
));
1981 XSETSYMBOL (variable
, sym
);
1983 valcontents
= sym
->value
;
1984 if (BUFFER_LOCAL_VALUEP (valcontents
))
1986 Lisp_Object tail
, elt
;
1988 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
1991 if (EQ (variable
, XCAR (elt
)))
1995 if (BUFFER_OBJFWDP (valcontents
))
1997 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1998 int idx
= PER_BUFFER_IDX (offset
);
1999 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2005 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2007 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
2008 More precisely, this means that setting the variable \(with `set' or`setq'),
2009 while it does not have a `let'-style binding that was made in BUFFER,
2010 will produce a buffer local binding. See Info node
2011 `(elisp)Creating Buffer-Local'.
2012 BUFFER defaults to the current buffer. */)
2014 register Lisp_Object variable
, buffer
;
2016 Lisp_Object valcontents
;
2017 register struct buffer
*buf
;
2018 struct Lisp_Symbol
*sym
;
2021 buf
= current_buffer
;
2024 CHECK_BUFFER (buffer
);
2025 buf
= XBUFFER (buffer
);
2028 CHECK_SYMBOL (variable
);
2029 sym
= indirect_variable (XSYMBOL (variable
));
2030 XSETSYMBOL (variable
, sym
);
2032 valcontents
= sym
->value
;
2034 if (BUFFER_OBJFWDP (valcontents
))
2035 /* All these slots become local if they are set. */
2037 else if (BUFFER_LOCAL_VALUEP (valcontents
))
2039 Lisp_Object tail
, elt
;
2040 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
2042 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2045 if (EQ (variable
, XCAR (elt
)))
2052 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2054 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2055 If the current binding is buffer-local, the value is the current buffer.
2056 If the current binding is frame-local, the value is the selected frame.
2057 If the current binding is global (the default), the value is nil. */)
2059 register Lisp_Object variable
;
2061 Lisp_Object valcontents
;
2062 struct Lisp_Symbol
*sym
;
2064 CHECK_SYMBOL (variable
);
2065 sym
= indirect_variable (XSYMBOL (variable
));
2067 /* Make sure the current binding is actually swapped in. */
2068 find_symbol_value (variable
);
2070 valcontents
= sym
->value
;
2072 if (BUFFER_LOCAL_VALUEP (valcontents
)
2073 || BUFFER_OBJFWDP (valcontents
))
2075 /* For a local variable, record both the symbol and which
2076 buffer's or frame's value we are saving. */
2077 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2078 return Fcurrent_buffer ();
2079 else if (BUFFER_LOCAL_VALUEP (valcontents
)
2080 && BLOCAL_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))
2081 return BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
2087 /* This code is disabled now that we use the selected frame to return
2088 keyboard-local-values. */
2090 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2092 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2093 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2094 If SYMBOL is not a terminal-local variable, then return its normal
2095 value, like `symbol-value'.
2097 TERMINAL may be a terminal object, a frame, or nil (meaning the
2098 selected frame's terminal device). */)
2101 Lisp_Object terminal
;
2104 struct terminal
*t
= get_terminal (terminal
, 1);
2105 push_kboard (t
->kboard
);
2106 result
= Fsymbol_value (symbol
);
2111 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2112 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2113 If VARIABLE is not a terminal-local variable, then set its normal
2114 binding, like `set'.
2116 TERMINAL may be a terminal object, a frame, or nil (meaning the
2117 selected frame's terminal device). */)
2118 (symbol
, terminal
, value
)
2120 Lisp_Object terminal
;
2124 struct terminal
*t
= get_terminal (terminal
, 1);
2125 push_kboard (d
->kboard
);
2126 result
= Fset (symbol
, value
);
2132 /* Find the function at the end of a chain of symbol function indirections. */
2134 /* If OBJECT is a symbol, find the end of its function chain and
2135 return the value found there. If OBJECT is not a symbol, just
2136 return it. If there is a cycle in the function chain, signal a
2137 cyclic-function-indirection error.
2139 This is like Findirect_function, except that it doesn't signal an
2140 error if the chain ends up unbound. */
2142 indirect_function (object
)
2143 register Lisp_Object object
;
2145 Lisp_Object tortoise
, hare
;
2147 hare
= tortoise
= object
;
2151 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2153 hare
= XSYMBOL (hare
)->function
;
2154 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2156 hare
= XSYMBOL (hare
)->function
;
2158 tortoise
= XSYMBOL (tortoise
)->function
;
2160 if (EQ (hare
, tortoise
))
2161 xsignal1 (Qcyclic_function_indirection
, object
);
2167 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2168 doc
: /* Return the function at the end of OBJECT's function chain.
2169 If OBJECT is not a symbol, just return it. Otherwise, follow all
2170 function indirections to find the final function binding and return it.
2171 If the final symbol in the chain is unbound, signal a void-function error.
2172 Optional arg NOERROR non-nil means to return nil instead of signalling.
2173 Signal a cyclic-function-indirection error if there is a loop in the
2174 function chain of symbols. */)
2176 register Lisp_Object object
;
2177 Lisp_Object noerror
;
2181 /* Optimize for no indirection. */
2183 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2184 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2185 result
= indirect_function (result
);
2186 if (!EQ (result
, Qunbound
))
2190 xsignal1 (Qvoid_function
, object
);
2195 /* Extract and set vector and string elements */
2197 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2198 doc
: /* Return the element of ARRAY at index IDX.
2199 ARRAY may be a vector, a string, a char-table, a bool-vector,
2200 or a byte-code object. IDX starts at 0. */)
2202 register Lisp_Object array
;
2205 register int idxval
;
2208 idxval
= XINT (idx
);
2209 if (STRINGP (array
))
2213 if (idxval
< 0 || idxval
>= SCHARS (array
))
2214 args_out_of_range (array
, idx
);
2215 if (! STRING_MULTIBYTE (array
))
2216 return make_number ((unsigned char) SREF (array
, idxval
));
2217 idxval_byte
= string_char_to_byte (array
, idxval
);
2219 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2220 return make_number (c
);
2222 else if (BOOL_VECTOR_P (array
))
2226 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2227 args_out_of_range (array
, idx
);
2229 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2230 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2232 else if (CHAR_TABLE_P (array
))
2234 CHECK_CHARACTER (idx
);
2235 return CHAR_TABLE_REF (array
, idxval
);
2240 if (VECTORP (array
))
2241 size
= XVECTOR (array
)->size
;
2242 else if (COMPILEDP (array
))
2243 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2245 wrong_type_argument (Qarrayp
, array
);
2247 if (idxval
< 0 || idxval
>= size
)
2248 args_out_of_range (array
, idx
);
2249 return XVECTOR (array
)->contents
[idxval
];
2253 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2254 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2255 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2256 bool-vector. IDX starts at 0. */)
2257 (array
, idx
, newelt
)
2258 register Lisp_Object array
;
2259 Lisp_Object idx
, newelt
;
2261 register int idxval
;
2264 idxval
= XINT (idx
);
2265 CHECK_ARRAY (array
, Qarrayp
);
2266 CHECK_IMPURE (array
);
2268 if (VECTORP (array
))
2270 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2271 args_out_of_range (array
, idx
);
2272 XVECTOR (array
)->contents
[idxval
] = newelt
;
2274 else if (BOOL_VECTOR_P (array
))
2278 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2279 args_out_of_range (array
, idx
);
2281 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2283 if (! NILP (newelt
))
2284 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2286 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2287 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2289 else if (CHAR_TABLE_P (array
))
2291 CHECK_CHARACTER (idx
);
2292 CHAR_TABLE_SET (array
, idxval
, newelt
);
2294 else if (STRING_MULTIBYTE (array
))
2296 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2297 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2299 if (idxval
< 0 || idxval
>= SCHARS (array
))
2300 args_out_of_range (array
, idx
);
2301 CHECK_CHARACTER (newelt
);
2303 nbytes
= SBYTES (array
);
2305 idxval_byte
= string_char_to_byte (array
, idxval
);
2306 p1
= SDATA (array
) + idxval_byte
;
2307 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2308 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2309 if (prev_bytes
!= new_bytes
)
2311 /* We must relocate the string data. */
2312 int nchars
= SCHARS (array
);
2316 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2317 bcopy (SDATA (array
), str
, nbytes
);
2318 allocate_string_data (XSTRING (array
), nchars
,
2319 nbytes
+ new_bytes
- prev_bytes
);
2320 bcopy (str
, SDATA (array
), idxval_byte
);
2321 p1
= SDATA (array
) + idxval_byte
;
2322 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2323 nbytes
- (idxval_byte
+ prev_bytes
));
2325 clear_string_char_byte_cache ();
2332 if (idxval
< 0 || idxval
>= SCHARS (array
))
2333 args_out_of_range (array
, idx
);
2334 CHECK_NUMBER (newelt
);
2336 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2340 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2341 if (SREF (array
, i
) >= 0x80)
2342 args_out_of_range (array
, newelt
);
2343 /* ARRAY is an ASCII string. Convert it to a multibyte
2344 string, and try `aset' again. */
2345 STRING_SET_MULTIBYTE (array
);
2346 return Faset (array
, idx
, newelt
);
2348 SSET (array
, idxval
, XINT (newelt
));
2354 /* Arithmetic functions */
2356 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2359 arithcompare (num1
, num2
, comparison
)
2360 Lisp_Object num1
, num2
;
2361 enum comparison comparison
;
2363 double f1
= 0, f2
= 0;
2366 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2367 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2369 if (FLOATP (num1
) || FLOATP (num2
))
2372 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2373 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2379 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2384 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2389 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2394 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2399 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2404 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2413 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2414 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2416 register Lisp_Object num1
, num2
;
2418 return arithcompare (num1
, num2
, equal
);
2421 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2422 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2424 register Lisp_Object num1
, num2
;
2426 return arithcompare (num1
, num2
, less
);
2429 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2430 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2432 register Lisp_Object num1
, num2
;
2434 return arithcompare (num1
, num2
, grtr
);
2437 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2438 doc
: /* Return t if first arg is less than or equal to second arg.
2439 Both must be numbers or markers. */)
2441 register Lisp_Object num1
, num2
;
2443 return arithcompare (num1
, num2
, less_or_equal
);
2446 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2447 doc
: /* Return t if first arg is greater than or equal to second arg.
2448 Both must be numbers or markers. */)
2450 register Lisp_Object num1
, num2
;
2452 return arithcompare (num1
, num2
, grtr_or_equal
);
2455 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2456 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2458 register Lisp_Object num1
, num2
;
2460 return arithcompare (num1
, num2
, notequal
);
2463 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2464 doc
: /* Return t if NUMBER is zero. */)
2466 register Lisp_Object number
;
2468 CHECK_NUMBER_OR_FLOAT (number
);
2470 if (FLOATP (number
))
2472 if (XFLOAT_DATA (number
) == 0.0)
2482 /* Convert between long values and pairs of Lisp integers.
2483 Note that long_to_cons returns a single Lisp integer
2484 when the value fits in one. */
2490 unsigned long top
= i
>> 16;
2491 unsigned int bot
= i
& 0xFFFF;
2493 return make_number (bot
);
2494 if (top
== (unsigned long)-1 >> 16)
2495 return Fcons (make_number (-1), make_number (bot
));
2496 return Fcons (make_number (top
), make_number (bot
));
2503 Lisp_Object top
, bot
;
2510 return ((XINT (top
) << 16) | XINT (bot
));
2513 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2514 doc
: /* Return the decimal representation of NUMBER as a string.
2515 Uses a minus sign if negative.
2516 NUMBER may be an integer or a floating point number. */)
2520 char buffer
[VALBITS
];
2522 CHECK_NUMBER_OR_FLOAT (number
);
2524 if (FLOATP (number
))
2526 char pigbuf
[350]; /* see comments in float_to_string */
2528 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2529 return build_string (pigbuf
);
2532 if (sizeof (int) == sizeof (EMACS_INT
))
2533 sprintf (buffer
, "%d", (int) XINT (number
));
2534 else if (sizeof (long) == sizeof (EMACS_INT
))
2535 sprintf (buffer
, "%ld", (long) XINT (number
));
2538 return build_string (buffer
);
2542 digit_to_number (character
, base
)
2543 int character
, base
;
2547 if (character
>= '0' && character
<= '9')
2548 digit
= character
- '0';
2549 else if (character
>= 'a' && character
<= 'z')
2550 digit
= character
- 'a' + 10;
2551 else if (character
>= 'A' && character
<= 'Z')
2552 digit
= character
- 'A' + 10;
2562 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2563 doc
: /* Parse STRING as a decimal number and return the number.
2564 This parses both integers and floating point numbers.
2565 It ignores leading spaces and tabs, and all trailing chars.
2567 If BASE, interpret STRING as a number in that base. If BASE isn't
2568 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2569 If the base used is not 10, STRING is always parsed as integer. */)
2571 register Lisp_Object string
, base
;
2573 register unsigned char *p
;
2578 CHECK_STRING (string
);
2584 CHECK_NUMBER (base
);
2586 if (b
< 2 || b
> 16)
2587 xsignal1 (Qargs_out_of_range
, base
);
2590 /* Skip any whitespace at the front of the number. Some versions of
2591 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2593 while (*p
== ' ' || *p
== '\t')
2604 if (isfloat_string (p
, 1) && b
== 10)
2605 val
= make_float (sign
* atof (p
));
2612 int digit
= digit_to_number (*p
++, b
);
2618 val
= make_fixnum_or_float (sign
* v
);
2638 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2639 int, Lisp_Object
*));
2640 extern Lisp_Object
fmod_float ();
2643 arith_driver (code
, nargs
, args
)
2646 register Lisp_Object
*args
;
2648 register Lisp_Object val
;
2649 register int argnum
;
2650 register EMACS_INT accum
= 0;
2651 register EMACS_INT next
;
2653 switch (SWITCH_ENUM_CAST (code
))
2671 for (argnum
= 0; argnum
< nargs
; argnum
++)
2673 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2675 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2678 return float_arith_driver ((double) accum
, argnum
, code
,
2681 next
= XINT (args
[argnum
]);
2682 switch (SWITCH_ENUM_CAST (code
))
2688 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2699 xsignal0 (Qarith_error
);
2713 if (!argnum
|| next
> accum
)
2717 if (!argnum
|| next
< accum
)
2723 XSETINT (val
, accum
);
2728 #define isnan(x) ((x) != (x))
2731 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2733 register int argnum
;
2736 register Lisp_Object
*args
;
2738 register Lisp_Object val
;
2741 for (; argnum
< nargs
; argnum
++)
2743 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2744 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2748 next
= XFLOAT_DATA (val
);
2752 args
[argnum
] = val
; /* runs into a compiler bug. */
2753 next
= XINT (args
[argnum
]);
2755 switch (SWITCH_ENUM_CAST (code
))
2761 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2771 if (! IEEE_FLOATING_POINT
&& next
== 0)
2772 xsignal0 (Qarith_error
);
2779 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2781 if (!argnum
|| isnan (next
) || next
> accum
)
2785 if (!argnum
|| isnan (next
) || next
< accum
)
2791 return make_float (accum
);
2795 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2796 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2797 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2802 return arith_driver (Aadd
, nargs
, args
);
2805 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2806 doc
: /* Negate number or subtract numbers or markers and return the result.
2807 With one arg, negates it. With more than one arg,
2808 subtracts all but the first from the first.
2809 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2814 return arith_driver (Asub
, nargs
, args
);
2817 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2818 doc
: /* Return product of any number of arguments, which are numbers or markers.
2819 usage: (* &rest NUMBERS-OR-MARKERS) */)
2824 return arith_driver (Amult
, nargs
, args
);
2827 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2828 doc
: /* Return first argument divided by all the remaining arguments.
2829 The arguments must be numbers or markers.
2830 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2836 for (argnum
= 2; argnum
< nargs
; argnum
++)
2837 if (FLOATP (args
[argnum
]))
2838 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2839 return arith_driver (Adiv
, nargs
, args
);
2842 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2843 doc
: /* Return remainder of X divided by Y.
2844 Both must be integers or markers. */)
2846 register Lisp_Object x
, y
;
2850 CHECK_NUMBER_COERCE_MARKER (x
);
2851 CHECK_NUMBER_COERCE_MARKER (y
);
2853 if (XFASTINT (y
) == 0)
2854 xsignal0 (Qarith_error
);
2856 XSETINT (val
, XINT (x
) % XINT (y
));
2870 /* If the magnitude of the result exceeds that of the divisor, or
2871 the sign of the result does not agree with that of the dividend,
2872 iterate with the reduced value. This does not yield a
2873 particularly accurate result, but at least it will be in the
2874 range promised by fmod. */
2876 r
-= f2
* floor (r
/ f2
);
2877 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2881 #endif /* ! HAVE_FMOD */
2883 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2884 doc
: /* Return X modulo Y.
2885 The result falls between zero (inclusive) and Y (exclusive).
2886 Both X and Y must be numbers or markers. */)
2888 register Lisp_Object x
, y
;
2893 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2894 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2896 if (FLOATP (x
) || FLOATP (y
))
2897 return fmod_float (x
, y
);
2903 xsignal0 (Qarith_error
);
2907 /* If the "remainder" comes out with the wrong sign, fix it. */
2908 if (i2
< 0 ? i1
> 0 : i1
< 0)
2915 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2916 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2917 The value is always a number; markers are converted to numbers.
2918 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2923 return arith_driver (Amax
, nargs
, args
);
2926 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2927 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2928 The value is always a number; markers are converted to numbers.
2929 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2934 return arith_driver (Amin
, nargs
, args
);
2937 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2938 doc
: /* Return bitwise-and of all the arguments.
2939 Arguments may be integers, or markers converted to integers.
2940 usage: (logand &rest INTS-OR-MARKERS) */)
2945 return arith_driver (Alogand
, nargs
, args
);
2948 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2949 doc
: /* Return bitwise-or of all the arguments.
2950 Arguments may be integers, or markers converted to integers.
2951 usage: (logior &rest INTS-OR-MARKERS) */)
2956 return arith_driver (Alogior
, nargs
, args
);
2959 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2960 doc
: /* Return bitwise-exclusive-or of all the arguments.
2961 Arguments may be integers, or markers converted to integers.
2962 usage: (logxor &rest INTS-OR-MARKERS) */)
2967 return arith_driver (Alogxor
, nargs
, args
);
2970 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2971 doc
: /* Return VALUE with its bits shifted left by COUNT.
2972 If COUNT is negative, shifting is actually to the right.
2973 In this case, the sign bit is duplicated. */)
2975 register Lisp_Object value
, count
;
2977 register Lisp_Object val
;
2979 CHECK_NUMBER (value
);
2980 CHECK_NUMBER (count
);
2982 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2984 else if (XINT (count
) > 0)
2985 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2986 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2987 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2989 XSETINT (val
, XINT (value
) >> -XINT (count
));
2993 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2994 doc
: /* Return VALUE with its bits shifted left by COUNT.
2995 If COUNT is negative, shifting is actually to the right.
2996 In this case, zeros are shifted in on the left. */)
2998 register Lisp_Object value
, count
;
3000 register Lisp_Object val
;
3002 CHECK_NUMBER (value
);
3003 CHECK_NUMBER (count
);
3005 if (XINT (count
) >= BITS_PER_EMACS_INT
)
3007 else if (XINT (count
) > 0)
3008 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
3009 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
3012 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
3016 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3017 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3018 Markers are converted to integers. */)
3020 register Lisp_Object number
;
3022 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3024 if (FLOATP (number
))
3025 return (make_float (1.0 + XFLOAT_DATA (number
)));
3027 XSETINT (number
, XINT (number
) + 1);
3031 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3032 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3033 Markers are converted to integers. */)
3035 register Lisp_Object number
;
3037 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3039 if (FLOATP (number
))
3040 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3042 XSETINT (number
, XINT (number
) - 1);
3046 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3047 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3049 register Lisp_Object number
;
3051 CHECK_NUMBER (number
);
3052 XSETINT (number
, ~XINT (number
));
3056 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3057 doc
: /* Return the byteorder for the machine.
3058 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3059 lowercase l) for small endian machines. */)
3062 unsigned i
= 0x04030201;
3063 int order
= *(char *)&i
== 1 ? 108 : 66;
3065 return make_number (order
);
3073 Lisp_Object error_tail
, arith_tail
;
3075 Qquote
= intern_c_string ("quote");
3076 Qlambda
= intern_c_string ("lambda");
3077 Qsubr
= intern_c_string ("subr");
3078 Qerror_conditions
= intern_c_string ("error-conditions");
3079 Qerror_message
= intern_c_string ("error-message");
3080 Qtop_level
= intern_c_string ("top-level");
3082 Qerror
= intern_c_string ("error");
3083 Qquit
= intern_c_string ("quit");
3084 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3085 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3086 Qvoid_function
= intern_c_string ("void-function");
3087 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3088 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3089 Qvoid_variable
= intern_c_string ("void-variable");
3090 Qsetting_constant
= intern_c_string ("setting-constant");
3091 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3093 Qinvalid_function
= intern_c_string ("invalid-function");
3094 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3095 Qno_catch
= intern_c_string ("no-catch");
3096 Qend_of_file
= intern_c_string ("end-of-file");
3097 Qarith_error
= intern_c_string ("arith-error");
3098 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3099 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3100 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3101 Qtext_read_only
= intern_c_string ("text-read-only");
3102 Qmark_inactive
= intern_c_string ("mark-inactive");
3104 Qlistp
= intern_c_string ("listp");
3105 Qconsp
= intern_c_string ("consp");
3106 Qsymbolp
= intern_c_string ("symbolp");
3107 Qkeywordp
= intern_c_string ("keywordp");
3108 Qintegerp
= intern_c_string ("integerp");
3109 Qnatnump
= intern_c_string ("natnump");
3110 Qwholenump
= intern_c_string ("wholenump");
3111 Qstringp
= intern_c_string ("stringp");
3112 Qarrayp
= intern_c_string ("arrayp");
3113 Qsequencep
= intern_c_string ("sequencep");
3114 Qbufferp
= intern_c_string ("bufferp");
3115 Qvectorp
= intern_c_string ("vectorp");
3116 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3117 Qmarkerp
= intern_c_string ("markerp");
3118 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3119 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3120 Qboundp
= intern_c_string ("boundp");
3121 Qfboundp
= intern_c_string ("fboundp");
3123 Qfloatp
= intern_c_string ("floatp");
3124 Qnumberp
= intern_c_string ("numberp");
3125 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3127 Qchar_table_p
= intern_c_string ("char-table-p");
3128 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3130 Qsubrp
= intern_c_string ("subrp");
3131 Qunevalled
= intern_c_string ("unevalled");
3132 Qmany
= intern_c_string ("many");
3134 Qcdr
= intern_c_string ("cdr");
3136 /* Handle automatic advice activation */
3137 Qad_advice_info
= intern_c_string ("ad-advice-info");
3138 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3140 error_tail
= pure_cons (Qerror
, Qnil
);
3142 /* ERROR is used as a signaler for random errors for which nothing else is right */
3144 Fput (Qerror
, Qerror_conditions
,
3146 Fput (Qerror
, Qerror_message
,
3147 make_pure_c_string ("error"));
3149 Fput (Qquit
, Qerror_conditions
,
3150 pure_cons (Qquit
, Qnil
));
3151 Fput (Qquit
, Qerror_message
,
3152 make_pure_c_string ("Quit"));
3154 Fput (Qwrong_type_argument
, Qerror_conditions
,
3155 pure_cons (Qwrong_type_argument
, error_tail
));
3156 Fput (Qwrong_type_argument
, Qerror_message
,
3157 make_pure_c_string ("Wrong type argument"));
3159 Fput (Qargs_out_of_range
, Qerror_conditions
,
3160 pure_cons (Qargs_out_of_range
, error_tail
));
3161 Fput (Qargs_out_of_range
, Qerror_message
,
3162 make_pure_c_string ("Args out of range"));
3164 Fput (Qvoid_function
, Qerror_conditions
,
3165 pure_cons (Qvoid_function
, error_tail
));
3166 Fput (Qvoid_function
, Qerror_message
,
3167 make_pure_c_string ("Symbol's function definition is void"));
3169 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3170 pure_cons (Qcyclic_function_indirection
, error_tail
));
3171 Fput (Qcyclic_function_indirection
, Qerror_message
,
3172 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3174 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3175 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3176 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3177 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3179 Qcircular_list
= intern_c_string ("circular-list");
3180 staticpro (&Qcircular_list
);
3181 Fput (Qcircular_list
, Qerror_conditions
,
3182 pure_cons (Qcircular_list
, error_tail
));
3183 Fput (Qcircular_list
, Qerror_message
,
3184 make_pure_c_string ("List contains a loop"));
3186 Fput (Qvoid_variable
, Qerror_conditions
,
3187 pure_cons (Qvoid_variable
, error_tail
));
3188 Fput (Qvoid_variable
, Qerror_message
,
3189 make_pure_c_string ("Symbol's value as variable is void"));
3191 Fput (Qsetting_constant
, Qerror_conditions
,
3192 pure_cons (Qsetting_constant
, error_tail
));
3193 Fput (Qsetting_constant
, Qerror_message
,
3194 make_pure_c_string ("Attempt to set a constant symbol"));
3196 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3197 pure_cons (Qinvalid_read_syntax
, error_tail
));
3198 Fput (Qinvalid_read_syntax
, Qerror_message
,
3199 make_pure_c_string ("Invalid read syntax"));
3201 Fput (Qinvalid_function
, Qerror_conditions
,
3202 pure_cons (Qinvalid_function
, error_tail
));
3203 Fput (Qinvalid_function
, Qerror_message
,
3204 make_pure_c_string ("Invalid function"));
3206 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3207 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3208 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3209 make_pure_c_string ("Wrong number of arguments"));
3211 Fput (Qno_catch
, Qerror_conditions
,
3212 pure_cons (Qno_catch
, error_tail
));
3213 Fput (Qno_catch
, Qerror_message
,
3214 make_pure_c_string ("No catch for tag"));
3216 Fput (Qend_of_file
, Qerror_conditions
,
3217 pure_cons (Qend_of_file
, error_tail
));
3218 Fput (Qend_of_file
, Qerror_message
,
3219 make_pure_c_string ("End of file during parsing"));
3221 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3222 Fput (Qarith_error
, Qerror_conditions
,
3224 Fput (Qarith_error
, Qerror_message
,
3225 make_pure_c_string ("Arithmetic error"));
3227 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3228 pure_cons (Qbeginning_of_buffer
, error_tail
));
3229 Fput (Qbeginning_of_buffer
, Qerror_message
,
3230 make_pure_c_string ("Beginning of buffer"));
3232 Fput (Qend_of_buffer
, Qerror_conditions
,
3233 pure_cons (Qend_of_buffer
, error_tail
));
3234 Fput (Qend_of_buffer
, Qerror_message
,
3235 make_pure_c_string ("End of buffer"));
3237 Fput (Qbuffer_read_only
, Qerror_conditions
,
3238 pure_cons (Qbuffer_read_only
, error_tail
));
3239 Fput (Qbuffer_read_only
, Qerror_message
,
3240 make_pure_c_string ("Buffer is read-only"));
3242 Fput (Qtext_read_only
, Qerror_conditions
,
3243 pure_cons (Qtext_read_only
, error_tail
));
3244 Fput (Qtext_read_only
, Qerror_message
,
3245 make_pure_c_string ("Text is read-only"));
3247 Qrange_error
= intern_c_string ("range-error");
3248 Qdomain_error
= intern_c_string ("domain-error");
3249 Qsingularity_error
= intern_c_string ("singularity-error");
3250 Qoverflow_error
= intern_c_string ("overflow-error");
3251 Qunderflow_error
= intern_c_string ("underflow-error");
3253 Fput (Qdomain_error
, Qerror_conditions
,
3254 pure_cons (Qdomain_error
, arith_tail
));
3255 Fput (Qdomain_error
, Qerror_message
,
3256 make_pure_c_string ("Arithmetic domain error"));
3258 Fput (Qrange_error
, Qerror_conditions
,
3259 pure_cons (Qrange_error
, arith_tail
));
3260 Fput (Qrange_error
, Qerror_message
,
3261 make_pure_c_string ("Arithmetic range error"));
3263 Fput (Qsingularity_error
, Qerror_conditions
,
3264 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3265 Fput (Qsingularity_error
, Qerror_message
,
3266 make_pure_c_string ("Arithmetic singularity error"));
3268 Fput (Qoverflow_error
, Qerror_conditions
,
3269 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3270 Fput (Qoverflow_error
, Qerror_message
,
3271 make_pure_c_string ("Arithmetic overflow error"));
3273 Fput (Qunderflow_error
, Qerror_conditions
,
3274 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3275 Fput (Qunderflow_error
, Qerror_message
,
3276 make_pure_c_string ("Arithmetic underflow error"));
3278 staticpro (&Qrange_error
);
3279 staticpro (&Qdomain_error
);
3280 staticpro (&Qsingularity_error
);
3281 staticpro (&Qoverflow_error
);
3282 staticpro (&Qunderflow_error
);
3286 staticpro (&Qquote
);
3287 staticpro (&Qlambda
);
3289 staticpro (&Qunbound
);
3290 staticpro (&Qerror_conditions
);
3291 staticpro (&Qerror_message
);
3292 staticpro (&Qtop_level
);
3294 staticpro (&Qerror
);
3296 staticpro (&Qwrong_type_argument
);
3297 staticpro (&Qargs_out_of_range
);
3298 staticpro (&Qvoid_function
);
3299 staticpro (&Qcyclic_function_indirection
);
3300 staticpro (&Qcyclic_variable_indirection
);
3301 staticpro (&Qvoid_variable
);
3302 staticpro (&Qsetting_constant
);
3303 staticpro (&Qinvalid_read_syntax
);
3304 staticpro (&Qwrong_number_of_arguments
);
3305 staticpro (&Qinvalid_function
);
3306 staticpro (&Qno_catch
);
3307 staticpro (&Qend_of_file
);
3308 staticpro (&Qarith_error
);
3309 staticpro (&Qbeginning_of_buffer
);
3310 staticpro (&Qend_of_buffer
);
3311 staticpro (&Qbuffer_read_only
);
3312 staticpro (&Qtext_read_only
);
3313 staticpro (&Qmark_inactive
);
3315 staticpro (&Qlistp
);
3316 staticpro (&Qconsp
);
3317 staticpro (&Qsymbolp
);
3318 staticpro (&Qkeywordp
);
3319 staticpro (&Qintegerp
);
3320 staticpro (&Qnatnump
);
3321 staticpro (&Qwholenump
);
3322 staticpro (&Qstringp
);
3323 staticpro (&Qarrayp
);
3324 staticpro (&Qsequencep
);
3325 staticpro (&Qbufferp
);
3326 staticpro (&Qvectorp
);
3327 staticpro (&Qchar_or_string_p
);
3328 staticpro (&Qmarkerp
);
3329 staticpro (&Qbuffer_or_string_p
);
3330 staticpro (&Qinteger_or_marker_p
);
3331 staticpro (&Qfloatp
);
3332 staticpro (&Qnumberp
);
3333 staticpro (&Qnumber_or_marker_p
);
3334 staticpro (&Qchar_table_p
);
3335 staticpro (&Qvector_or_char_table_p
);
3336 staticpro (&Qsubrp
);
3338 staticpro (&Qunevalled
);
3340 staticpro (&Qboundp
);
3341 staticpro (&Qfboundp
);
3343 staticpro (&Qad_advice_info
);
3344 staticpro (&Qad_activate_internal
);
3346 /* Types that type-of returns. */
3347 Qinteger
= intern_c_string ("integer");
3348 Qsymbol
= intern_c_string ("symbol");
3349 Qstring
= intern_c_string ("string");
3350 Qcons
= intern_c_string ("cons");
3351 Qmarker
= intern_c_string ("marker");
3352 Qoverlay
= intern_c_string ("overlay");
3353 Qfloat
= intern_c_string ("float");
3354 Qwindow_configuration
= intern_c_string ("window-configuration");
3355 Qprocess
= intern_c_string ("process");
3356 Qwindow
= intern_c_string ("window");
3357 /* Qsubr = intern_c_string ("subr"); */
3358 Qcompiled_function
= intern_c_string ("compiled-function");
3359 Qbuffer
= intern_c_string ("buffer");
3360 Qframe
= intern_c_string ("frame");
3361 Qvector
= intern_c_string ("vector");
3362 Qchar_table
= intern_c_string ("char-table");
3363 Qbool_vector
= intern_c_string ("bool-vector");
3364 Qhash_table
= intern_c_string ("hash-table");
3366 Qthread_local_mark
= Fmake_symbol (make_pure_string ("thread-local-mark",
3369 DEFSYM (Qfont_spec
, "font-spec");
3370 DEFSYM (Qfont_entity
, "font-entity");
3371 DEFSYM (Qfont_object
, "font-object");
3373 DEFSYM (Qinteractive_form
, "interactive-form");
3375 staticpro (&Qinteger
);
3376 staticpro (&Qsymbol
);
3377 staticpro (&Qstring
);
3379 staticpro (&Qmarker
);
3380 staticpro (&Qoverlay
);
3381 staticpro (&Qfloat
);
3382 staticpro (&Qwindow_configuration
);
3383 staticpro (&Qprocess
);
3384 staticpro (&Qwindow
);
3385 /* staticpro (&Qsubr); */
3386 staticpro (&Qcompiled_function
);
3387 staticpro (&Qbuffer
);
3388 staticpro (&Qframe
);
3389 staticpro (&Qvector
);
3390 staticpro (&Qchar_table
);
3391 staticpro (&Qbool_vector
);
3392 staticpro (&Qhash_table
);
3393 staticpro (&Qthread_local_mark
);
3395 defsubr (&Sindirect_variable
);
3396 defsubr (&Sinteractive_form
);
3399 defsubr (&Stype_of
);
3404 defsubr (&Sintegerp
);
3405 defsubr (&Sinteger_or_marker_p
);
3406 defsubr (&Snumberp
);
3407 defsubr (&Snumber_or_marker_p
);
3409 defsubr (&Snatnump
);
3410 defsubr (&Ssymbolp
);
3411 defsubr (&Skeywordp
);
3412 defsubr (&Sstringp
);
3413 defsubr (&Smultibyte_string_p
);
3414 defsubr (&Svectorp
);
3415 defsubr (&Schar_table_p
);
3416 defsubr (&Svector_or_char_table_p
);
3417 defsubr (&Sbool_vector_p
);
3419 defsubr (&Ssequencep
);
3420 defsubr (&Sbufferp
);
3421 defsubr (&Smarkerp
);
3423 defsubr (&Sbyte_code_function_p
);
3424 defsubr (&Schar_or_string_p
);
3427 defsubr (&Scar_safe
);
3428 defsubr (&Scdr_safe
);
3431 defsubr (&Ssymbol_function
);
3432 defsubr (&Sindirect_function
);
3433 defsubr (&Ssymbol_plist
);
3434 defsubr (&Ssymbol_name
);
3435 defsubr (&Smakunbound
);
3436 defsubr (&Sfmakunbound
);
3438 defsubr (&Sfboundp
);
3440 defsubr (&Sdefalias
);
3441 defsubr (&Ssetplist
);
3442 defsubr (&Ssymbol_value
);
3444 defsubr (&Sdefault_boundp
);
3445 defsubr (&Sdefault_value
);
3446 defsubr (&Sset_default
);
3447 defsubr (&Ssetq_default
);
3448 defsubr (&Smake_variable_buffer_local
);
3449 defsubr (&Smake_local_variable
);
3450 defsubr (&Skill_local_variable
);
3451 defsubr (&Smake_variable_frame_local
);
3452 defsubr (&Slocal_variable_p
);
3453 defsubr (&Slocal_variable_if_set_p
);
3454 defsubr (&Svariable_binding_locus
);
3455 #if 0 /* XXX Remove this. --lorentey */
3456 defsubr (&Sterminal_local_value
);
3457 defsubr (&Sset_terminal_local_value
);
3461 defsubr (&Snumber_to_string
);
3462 defsubr (&Sstring_to_number
);
3463 defsubr (&Seqlsign
);
3486 defsubr (&Sbyteorder
);
3487 defsubr (&Ssubr_arity
);
3488 defsubr (&Ssubr_name
);
3490 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3492 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3493 doc
: /* The largest value that is representable in a Lisp integer. */);
3494 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3495 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3497 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3498 doc
: /* The smallest value that is representable in a Lisp integer. */);
3499 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3500 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3507 sigsetmask (SIGEMPTYMASK
);
3509 SIGNAL_THREAD_CHECK (signo
);
3510 xsignal0 (Qarith_error
);
3516 /* Don't do this if just dumping out.
3517 We don't want to call `signal' in this case
3518 so that we don't have trouble with dumping
3519 signal-delivering routines in an inconsistent state. */
3523 #endif /* CANNOT_DUMP */
3524 signal (SIGFPE
, arith_error
);
3527 signal (SIGEMT
, arith_error
);
3531 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3532 (do not change this comment) */