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
)));
816 /* Retrieve the buffer local data for the caller thread. SYMBOL is used only
817 when the specified buffer local value does not have a binding for the thread
818 and a new one must be created. */
821 blocal_get_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object symbol
)
823 Lisp_Object ret
= assq_no_quit (get_current_thread (), l
->thread_data
);
826 Lisp_Object tem
, val
, len
;
828 if (NILP (symbol
) || !initialized
)
831 XSETFASTINT (len
, 4);
832 ret
= Fmake_vector (len
, Qnil
);
834 BLOCAL_CLEAR_FLAGS_VEC (ret
);
835 tem
= Fcons (Qnil
, Qnil
);
836 val
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
837 if (NILP (val
) || (l
->check_frame
&& ! EQ (selected_frame
, Qnil
)))
839 val
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
841 BLOCAL_SET_FOUND_FOR_FRAME_VEC (ret
);
844 val
= XTHREADLOCAL (l
->realvalue
)->global
;
852 XSETCDR (tem
, XTHREADLOCAL (l
->realvalue
)->global
);
853 BLOCAL_SET_FOUND_FOR_BUFFER_VEC (ret
);
856 BLOCAL_BUFFER_VEC (ret
) = Fcurrent_buffer ();
857 BLOCAL_FRAME_VEC (ret
) = Qnil
;
858 BLOCAL_CDR_VEC (ret
) = tem
;
860 ret
= Fcons (get_current_thread (), ret
);
861 l
->thread_data
= Fcons (ret
, l
->thread_data
);
862 XTHREADLOCAL (l
->realvalue
)->thread_alist
=
863 Fcons (Fcons (get_current_thread (), val
),
864 XTHREADLOCAL (l
->realvalue
)->thread_alist
);
867 return &XCDR_AS_LVALUE (ret
);
870 /* Remove any thread-local data. */
872 blocal_unbind_thread (Lisp_Object thread
)
876 struct Lisp_Vector
*obarray
= XVECTOR (Vobarray
);
877 for (i
= 0; i
< obarray
->size
; i
++)
879 struct Lisp_Symbol
*sym
;
881 if (!SYMBOLP (obarray
->contents
[i
]))
884 sym
= XSYMBOL (obarray
->contents
[i
]);
886 #define UNBIND_LOCAL_VALUE(X) do { \
887 Lisp_Object tem = assq_no_quit (thread, (X)); \
889 (X) = Fdelq (tem, (X)); \
892 if (BUFFER_LOCAL_VALUEP (SYMBOL_VALUE (obarray
->contents
[i
])))
894 struct Lisp_Buffer_Local_Value
*loc
895 = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (obarray
->contents
[i
]));
897 UNBIND_LOCAL_VALUE (loc
->realvalue
);
898 UNBIND_LOCAL_VALUE (loc
->thread_data
);
901 if (THREADLOCALP (SYMBOL_VALUE (obarray
->contents
[i
])))
903 struct Lisp_ThreadLocal
*val
904 = XTHREADLOCAL (SYMBOL_VALUE (obarray
->contents
[i
]));
905 UNBIND_LOCAL_VALUE (val
->thread_alist
);
908 #undef UNBIND_LOCAL_VALUE
912 blocal_set_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object obj
)
914 if (! NILP (l
->thread_data
))
917 l
->thread_data
= Fcons (Fcons (get_current_thread (), obj
), Qnil
);
921 find_variable_location (Lisp_Object
*root
)
923 if (THREADLOCALP (*root
))
925 struct Lisp_ThreadLocal
*thr
= XTHREADLOCAL (*root
);
926 Lisp_Object cons
= assq_no_quit (get_current_thread (),
928 if (!EQ (cons
, Qnil
))
929 return &XCDR_AS_LVALUE (cons
);
938 ensure_thread_local (Lisp_Object
*root
)
942 if (THREADLOCALP (*root
))
943 cons
= assq_no_quit (get_current_thread (),
944 XTHREADLOCAL (*root
)->thread_alist
);
948 newval
= allocate_misc ();
949 XMISCTYPE (newval
) = Lisp_Misc_ThreadLocal
;
950 XTHREADLOCAL (newval
)->global
= *root
;
951 XTHREADLOCAL (newval
)->thread_alist
= Qnil
;
958 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
959 cons
= Fcons (get_current_thread (), Qthread_local_mark
);
960 local
->thread_alist
= Fcons (cons
, local
->thread_alist
);
967 remove_thread_local (Lisp_Object
*root
)
969 if (THREADLOCALP (*root
))
971 Lisp_Object iter
, thr
= get_current_thread (), prior
= Qnil
;
972 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
973 for (iter
= local
->thread_alist
; !NILP (iter
); iter
= XCDR (iter
))
975 if (EQ (XCAR (XCAR (iter
)), thr
))
978 local
->thread_alist
= XCDR (iter
);
980 XSETCDR (prior
, XCDR (iter
));
988 /* Return the symbol holding SYMBOL's value. Signal
989 `cyclic-variable-indirection' if SYMBOL's chain of variable
990 indirections contains a loop. */
993 indirect_variable (symbol
)
994 struct Lisp_Symbol
*symbol
;
996 struct Lisp_Symbol
*tortoise
, *hare
;
998 hare
= tortoise
= symbol
;
1000 while (hare
->indirect_variable
)
1002 hare
= XSYMBOL (hare
->value
);
1003 if (!hare
->indirect_variable
)
1006 hare
= XSYMBOL (hare
->value
);
1007 tortoise
= XSYMBOL (tortoise
->value
);
1009 if (hare
== tortoise
)
1012 XSETSYMBOL (tem
, symbol
);
1013 xsignal1 (Qcyclic_variable_indirection
, tem
);
1021 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
1022 doc
: /* Return the variable at the end of OBJECT's variable chain.
1023 If OBJECT is a symbol, follow all variable indirections and return the final
1024 variable. If OBJECT is not a symbol, just return it.
1025 Signal a cyclic-variable-indirection error if there is a loop in the
1026 variable chain of symbols. */)
1030 if (SYMBOLP (object
))
1031 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
1036 /* Given the raw contents of a symbol value cell,
1037 return the Lisp value of the symbol.
1038 This does not handle buffer-local variables; use
1039 swap_in_symval_forwarding for that. */
1042 do_symval_forwarding (valcontents
)
1043 Lisp_Object valcontents
;
1045 register Lisp_Object val
;
1046 if (MISCP (valcontents
))
1047 switch (XMISCTYPE (valcontents
))
1049 case Lisp_Misc_Intfwd
:
1050 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1053 case Lisp_Misc_Boolfwd
:
1054 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1056 case Lisp_Misc_Objfwd
:
1057 return *XOBJFWD (valcontents
)->objvar
;
1059 case Lisp_Misc_Buffer_Objfwd
:
1060 return PER_BUFFER_VALUE (current_buffer
,
1061 XBUFFER_OBJFWD (valcontents
)->offset
);
1063 case Lisp_Misc_Kboard_Objfwd
:
1064 /* We used to simply use current_kboard here, but from Lisp
1065 code, it's value is often unexpected. It seems nicer to
1066 allow constructions like this to work as intuitively expected:
1068 (with-selected-frame frame
1069 (define-key local-function-map "\eOP" [f1]))
1071 On the other hand, this affects the semantics of
1072 last-command and real-last-command, and people may rely on
1073 that. I took a quick look at the Lisp codebase, and I
1074 don't think anything will break. --lorentey */
1075 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1076 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1078 case Lisp_Misc_ThreadLocal
:
1079 return *find_variable_location (&valcontents
);
1084 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1085 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1086 buffer-independent contents of the value cell: forwarded just one
1087 step past the buffer-localness.
1089 BUF non-zero means set the value in buffer BUF instead of the
1090 current buffer. This only plays a role for per-buffer variables. */
1093 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
1095 register Lisp_Object valcontents
, newval
;
1098 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
1101 switch (XMISCTYPE (valcontents
))
1103 case Lisp_Misc_Intfwd
:
1104 CHECK_NUMBER (newval
);
1105 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1106 /* This can never happen since intvar points to an EMACS_INT
1107 which is at least large enough to hold a Lisp_Object.
1108 if (*XINTFWD (valcontents)->intvar != XINT (newval))
1109 error ("Value out of range for variable `%s'",
1110 SDATA (SYMBOL_NAME (symbol))); */
1113 case Lisp_Misc_Boolfwd
:
1114 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1117 case Lisp_Misc_Objfwd
:
1118 *find_variable_location (XOBJFWD (valcontents
)->objvar
) = newval
;
1120 /* If this variable is a default for something stored
1121 in the buffer itself, such as default-fill-column,
1122 find the buffers that don't have local values for it
1124 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1125 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1127 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1128 - (char *) &buffer_defaults
);
1129 int idx
= PER_BUFFER_IDX (offset
);
1136 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
1141 buf
= Fcdr (XCAR (tail
));
1142 if (!BUFFERP (buf
)) continue;
1145 if (! PER_BUFFER_VALUE_P (b
, idx
))
1146 SET_PER_BUFFER_VALUE_RAW (b
, offset
, newval
);
1151 case Lisp_Misc_Buffer_Objfwd
:
1153 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1154 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1156 if (!(NILP (type
) || NILP (newval
)
1157 || (XINT (type
) == LISP_INT_TAG
1159 : XTYPE (newval
) == XINT (type
))))
1160 buffer_slot_type_mismatch (newval
, XINT (type
));
1163 buf
= current_buffer
;
1164 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1168 case Lisp_Misc_Kboard_Objfwd
:
1170 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1171 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1172 *(Lisp_Object
*) p
= newval
;
1183 valcontents
= SYMBOL_VALUE (symbol
);
1184 if (BUFFER_LOCAL_VALUEP (valcontents
))
1185 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)) = newval
;
1186 else if (THREADLOCALP (valcontents
))
1188 Lisp_Object val
= indirect_variable (XSYMBOL (symbol
))->value
;
1189 val
= ensure_thread_local (&val
);
1190 XSETCDR (val
, newval
);
1193 SET_SYMBOL_VALUE (symbol
, newval
);
1197 /* Set up SYMBOL to refer to its global binding.
1198 This makes it safe to alter the status of other bindings. */
1201 swap_in_global_binding (symbol
)
1204 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1205 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1206 Lisp_Object cdr
= BLOCAL_CDR (blv
);
1208 /* Unload the previously loaded binding. */
1209 Fsetcdr (XCAR (cdr
),
1210 do_symval_forwarding (BLOCAL_REALVALUE (blv
)));
1212 /* Select the global binding in the symbol. */
1214 store_symval_forwarding (symbol
, BLOCAL_REALVALUE (blv
), XCDR (cdr
), NULL
);
1216 /* Indicate that the global binding is set up now. */
1217 BLOCAL_FRAME (blv
) = Qnil
;
1218 BLOCAL_BUFFER (blv
) = Qnil
;
1219 BLOCAL_CLEAR_FLAGS (blv
);
1222 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1223 VALCONTENTS is the contents of its value cell,
1224 which points to a struct Lisp_Buffer_Local_Value.
1226 Return the value forwarded one step past the buffer-local stage.
1227 This could be another forwarding pointer. */
1230 swap_in_symval_forwarding (symbol
, valcontents
)
1231 Lisp_Object symbol
, valcontents
;
1233 register Lisp_Object tem1
;
1235 struct Lisp_Buffer_Local_Value
*local
= XBUFFER_LOCAL_VALUE (valcontents
);
1236 blocal_get_thread_data (local
, symbol
);
1237 tem1
= BLOCAL_BUFFER (local
);
1240 || current_buffer
!= XBUFFER (tem1
)
1241 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1242 && ! EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))))
1244 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1245 if (sym
->indirect_variable
)
1247 sym
= indirect_variable (sym
);
1248 XSETSYMBOL (symbol
, sym
);
1251 /* Unload the previously loaded binding. */
1252 tem1
= XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1254 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1256 /* Choose the new binding. */
1257 tem1
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1258 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1261 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1262 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1264 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1266 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1269 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1271 /* Load the new binding. */
1272 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1273 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), current_buffer
);
1274 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1275 store_symval_forwarding (symbol
,
1276 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1280 return BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1284 /* Find the value of a symbol, returning Qunbound if it's not bound.
1285 This is helpful for code which just wants to get a variable's value
1286 if it has one, without signaling an error.
1287 Note that it must not be possible to quit
1288 within this function. Great care is required for this. */
1291 find_symbol_value (symbol
)
1294 register Lisp_Object valcontents
;
1295 register Lisp_Object val
;
1297 CHECK_SYMBOL (symbol
);
1298 valcontents
= SYMBOL_VALUE (symbol
);
1300 if (BUFFER_LOCAL_VALUEP (valcontents
))
1301 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1303 return do_symval_forwarding (valcontents
);
1306 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1307 doc
: /* Return SYMBOL's value. Error if that is void. */)
1313 val
= find_symbol_value (symbol
);
1314 if (!EQ (val
, Qunbound
))
1317 xsignal1 (Qvoid_variable
, symbol
);
1320 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1321 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1323 register Lisp_Object symbol
, newval
;
1325 return set_internal (symbol
, newval
, current_buffer
, 0);
1328 /* Return 1 if SYMBOL currently has a let-binding
1329 which was made in the buffer that is now current. */
1332 let_shadows_buffer_binding_p (symbol
)
1333 struct Lisp_Symbol
*symbol
;
1335 volatile struct specbinding
*p
;
1337 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1339 && CONSP (p
->symbol
))
1341 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1342 if ((symbol
== let_bound_symbol
1343 || (let_bound_symbol
->indirect_variable
1344 && symbol
== indirect_variable (let_bound_symbol
)))
1345 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1349 return p
>= specpdl
;
1352 /* Store the value NEWVAL into SYMBOL.
1353 If buffer-locality is an issue, BUF specifies which buffer to use.
1354 (0 stands for the current buffer.)
1356 If BINDFLAG is zero, then if this symbol is supposed to become
1357 local in every buffer where it is set, then we make it local.
1358 If BINDFLAG is nonzero, we don't do that. */
1361 set_internal (symbol
, newval
, buf
, bindflag
)
1362 register Lisp_Object symbol
, newval
;
1366 int voide
= EQ (newval
, Qunbound
);
1368 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1371 buf
= current_buffer
;
1373 /* If restoring in a dead buffer, do nothing. */
1374 if (NILP (BUF_NAME (buf
)))
1377 CHECK_SYMBOL (symbol
);
1378 if (SYMBOL_CONSTANT_P (symbol
)
1379 && (NILP (Fkeywordp (symbol
))
1380 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1381 xsignal1 (Qsetting_constant
, symbol
);
1383 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1385 if (BUFFER_OBJFWDP (valcontents
))
1387 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1388 int idx
= PER_BUFFER_IDX (offset
);
1391 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1392 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1394 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1396 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1397 if (XSYMBOL (symbol
)->indirect_variable
)
1398 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1400 blocal_get_thread_data (XBUFFER_LOCAL_VALUE (valcontents
), symbol
);
1402 /* What binding is loaded right now? */
1403 current_alist_element
1404 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1406 /* If the current buffer is not the buffer whose binding is
1407 loaded, or if there may be frame-local bindings and the frame
1408 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1409 the default binding is loaded, the loaded binding may be the
1411 if (!BUFFERP (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1412 || buf
!= XBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1413 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1414 && !EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
))))
1415 /* Also unload a global binding (if the var is local_if_set). */
1416 || (EQ (XCAR (current_alist_element
),
1417 current_alist_element
)))
1419 /* The currently loaded binding is not necessarily valid.
1420 We need to unload it, and choose a new binding. */
1422 /* Write out `realvalue' to the old loaded binding. */
1423 Fsetcdr (current_alist_element
,
1424 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1426 /* Find the new binding. */
1427 tem1
= Fassq (symbol
, BUF_LOCAL_VAR_ALIST (buf
));
1428 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1432 /* This buffer still sees the default value. */
1434 /* If the variable is not local_if_set,
1435 or if this is `let' rather than `set',
1436 make CURRENT-ALIST-ELEMENT point to itself,
1437 indicating that we're seeing the default value.
1438 Likewise if the variable has been let-bound
1439 in the current buffer. */
1440 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1441 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1443 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1445 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1446 tem1
= Fassq (symbol
,
1447 XFRAME (selected_frame
)->param_alist
);
1450 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1452 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1454 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1455 and we're not within a let that was made for this buffer,
1456 create a new buffer-local binding for the variable.
1457 That means, give this buffer a new assoc for a local value
1458 and load that binding. */
1461 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1462 BUF_LOCAL_VAR_ALIST (buf
)
1463 = Fcons (tem1
, BUF_LOCAL_VAR_ALIST (buf
));
1467 /* Record which binding is now loaded. */
1468 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1470 /* Set `buffer' and `frame' slots for the binding now loaded. */
1471 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), buf
);
1472 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1474 innercontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1476 /* Store the new value in the cons-cell. */
1477 XSETCDR (XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
))), newval
);
1480 /* If storing void (making the symbol void), forward only through
1481 buffer-local indicator, not through Lisp_Objfwd, etc. */
1483 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1485 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1490 /* Access or set a buffer-local symbol's default value. */
1492 /* Return the default value of SYMBOL, but don't check for voidness.
1493 Return Qunbound if it is void. */
1496 default_value (symbol
)
1499 register Lisp_Object valcontents
;
1501 CHECK_SYMBOL (symbol
);
1502 valcontents
= SYMBOL_VALUE (symbol
);
1504 /* For a built-in buffer-local variable, get the default value
1505 rather than letting do_symval_forwarding get the current value. */
1506 if (BUFFER_OBJFWDP (valcontents
))
1508 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1509 if (PER_BUFFER_IDX (offset
) != 0)
1510 return PER_BUFFER_DEFAULT (offset
);
1513 /* Handle user-created local variables. */
1514 if (BUFFER_LOCAL_VALUEP (valcontents
))
1516 /* If var is set up for a buffer that lacks a local value for it,
1517 the current value is nominally the default value.
1518 But the `realvalue' slot may be more up to date, since
1519 ordinary setq stores just that slot. So use that. */
1520 Lisp_Object current_alist_element
, alist_element_car
;
1522 blocal_get_thread_data (XBUFFER_LOCAL_VALUE (valcontents
), symbol
);
1524 current_alist_element
1525 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1526 alist_element_car
= XCAR (current_alist_element
);
1527 if (EQ (alist_element_car
, current_alist_element
))
1528 return do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)));
1530 return XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1532 /* For other variables, get the current value. */
1533 return do_symval_forwarding (valcontents
);
1536 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1537 doc
: /* Return t if SYMBOL has a non-void default value.
1538 This is the value that is seen in buffers that do not have their own values
1539 for this variable. */)
1543 register Lisp_Object value
;
1545 value
= default_value (symbol
);
1546 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1549 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1550 doc
: /* Return SYMBOL's default value.
1551 This is the value that is seen in buffers that do not have their own values
1552 for this variable. The default value is meaningful for variables with
1553 local bindings in certain buffers. */)
1557 register Lisp_Object value
;
1559 value
= default_value (symbol
);
1560 if (!EQ (value
, Qunbound
))
1563 xsignal1 (Qvoid_variable
, symbol
);
1566 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1567 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1568 The default value is seen in buffers that do not have their own values
1569 for this variable. */)
1571 Lisp_Object symbol
, value
;
1573 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1575 CHECK_SYMBOL (symbol
);
1576 valcontents
= SYMBOL_VALUE (symbol
);
1578 /* Handle variables like case-fold-search that have special slots
1579 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1581 if (BUFFER_OBJFWDP (valcontents
))
1583 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1584 int idx
= PER_BUFFER_IDX (offset
);
1586 PER_BUFFER_DEFAULT (offset
) = value
;
1588 /* If this variable is not always local in all buffers,
1589 set it in the buffers that don't nominally have a local value. */
1594 for (b
= all_buffers
; b
; b
= b
->next
)
1595 if (!PER_BUFFER_VALUE_P (b
, idx
))
1596 PER_BUFFER_VALUE (b
, offset
) = value
;
1601 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1602 return Fset (symbol
, value
);
1604 /* Store new value into the DEFAULT-VALUE slot. */
1605 XSETCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), value
);
1607 /* If the default binding is now loaded, set the REALVALUE slot too. */
1608 current_alist_element
1609 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1610 alist_element_buffer
= Fcar (current_alist_element
);
1611 if (EQ (alist_element_buffer
, current_alist_element
))
1612 store_symval_forwarding (symbol
,
1613 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1619 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1620 doc
: /* Set the default value of variable VAR to VALUE.
1621 VAR, the variable name, is literal (not evaluated);
1622 VALUE is an expression: it is evaluated and its value returned.
1623 The default value of a variable is seen in buffers
1624 that do not have their own values for the variable.
1626 More generally, you can use multiple variables and values, as in
1627 (setq-default VAR VALUE VAR VALUE...)
1628 This sets each VAR's default value to the corresponding VALUE.
1629 The VALUE for the Nth VAR can refer to the new default values
1631 usage: (setq-default [VAR VALUE]...) */)
1635 register Lisp_Object args_left
;
1636 register Lisp_Object val
, symbol
;
1637 struct gcpro gcpro1
;
1647 val
= Feval (Fcar (Fcdr (args_left
)));
1648 symbol
= XCAR (args_left
);
1649 Fset_default (symbol
, val
);
1650 args_left
= Fcdr (XCDR (args_left
));
1652 while (!NILP (args_left
));
1658 /* Lisp functions for creating and removing buffer-local variables. */
1660 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1661 1, 1, "vMake Variable Buffer Local: ",
1662 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1663 At any time, the value for the current buffer is in effect,
1664 unless the variable has never been set in this buffer,
1665 in which case the default value is in effect.
1666 Note that binding the variable with `let', or setting it while
1667 a `let'-style binding made in this buffer is in effect,
1668 does not make the variable buffer-local. Return VARIABLE.
1670 In most cases it is better to use `make-local-variable',
1671 which makes a variable local in just one buffer.
1673 The function `default-value' gets the default value and `set-default' sets it. */)
1675 register Lisp_Object variable
;
1677 register Lisp_Object tem
, valcontents
, newval
;
1678 struct Lisp_Symbol
*sym
;
1680 CHECK_SYMBOL (variable
);
1681 sym
= indirect_variable (XSYMBOL (variable
));
1683 valcontents
= sym
->value
;
1684 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1685 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1687 if (BUFFER_OBJFWDP (valcontents
))
1689 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1691 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1692 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1693 newval
= valcontents
;
1697 Lisp_Object len
, val_vec
;
1698 XSETFASTINT (len
, 4);
1699 val_vec
= Fmake_vector (len
, Qnil
);
1700 if (EQ (valcontents
, Qunbound
))
1702 tem
= Fcons (Qnil
, valcontents
);
1704 newval
= allocate_misc ();
1705 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1706 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1707 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1708 BLOCAL_BUFFER_VEC (val_vec
) = Fcurrent_buffer ();
1709 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1710 BLOCAL_CDR_VEC (val_vec
) = tem
;
1711 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1712 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1713 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1714 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1715 = Lisp_Misc_ThreadLocal
;
1716 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1718 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1719 = Fcons (Fcons (get_current_thread (), valcontents
), Qnil
);
1720 sym
->value
= newval
;
1722 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1726 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1727 1, 1, "vMake Local Variable: ",
1728 doc
: /* Make VARIABLE have a separate value in the current buffer.
1729 Other buffers will continue to share a common default value.
1730 \(The buffer-local value of VARIABLE starts out as the same value
1731 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1734 If the variable is already arranged to become local when set,
1735 this function causes a local value to exist for this buffer,
1736 just as setting the variable would do.
1738 This function returns VARIABLE, and therefore
1739 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1742 See also `make-variable-buffer-local'.
1744 Do not use `make-local-variable' to make a hook variable buffer-local.
1745 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1747 register Lisp_Object variable
;
1749 register Lisp_Object tem
, valcontents
;
1750 struct Lisp_Symbol
*sym
;
1752 CHECK_SYMBOL (variable
);
1753 sym
= indirect_variable (XSYMBOL (variable
));
1755 valcontents
= sym
->value
;
1756 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1757 || (BUFFER_LOCAL_VALUEP (valcontents
)
1758 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1759 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1761 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1762 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1763 || BUFFER_OBJFWDP (valcontents
))
1765 tem
= Fboundp (variable
);
1767 /* Make sure the symbol has a local value in this particular buffer,
1768 by setting it to the same value it already has. */
1769 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1772 /* Make sure symbol is set up to hold per-buffer values. */
1773 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1775 Lisp_Object newval
, len
, val_vec
;
1776 XSETFASTINT (len
, 4);
1777 val_vec
= Fmake_vector (len
, Qnil
);
1778 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1780 newval
= allocate_misc ();
1781 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1782 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1783 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1784 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1785 BLOCAL_CDR_VEC (val_vec
) = tem
;
1786 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1787 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1788 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1789 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1790 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1791 = Lisp_Misc_ThreadLocal
;
1792 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1794 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1795 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1796 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1797 sym
->value
= newval
;
1799 /* Make sure this buffer has its own value of symbol. */
1800 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1801 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1804 /* Swap out any local binding for some other buffer, and make
1805 sure the current value is permanently recorded, if it's the
1807 find_symbol_value (variable
);
1809 BUF_LOCAL_VAR_ALIST (current_buffer
)
1810 = Fcons (Fcons (variable
, XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (sym
->value
)))),
1811 BUF_LOCAL_VAR_ALIST (current_buffer
));
1813 /* Make sure symbol does not think it is set up for this buffer;
1814 force it to look once again for this buffer's value. */
1816 Lisp_Object
*pvalbuf
;
1818 valcontents
= sym
->value
;
1820 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1821 if (current_buffer
== XBUFFER (*pvalbuf
))
1823 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1827 /* If the symbol forwards into a C variable, then load the binding
1828 for this buffer now. If C code modifies the variable before we
1829 load the binding in, then that new value will clobber the default
1830 binding the next time we unload it. */
1831 valcontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (sym
->value
));
1832 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1833 swap_in_symval_forwarding (variable
, sym
->value
);
1838 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1839 1, 1, "vKill Local Variable: ",
1840 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1841 From now on the default value will apply in this buffer. Return VARIABLE. */)
1843 register Lisp_Object variable
;
1845 register Lisp_Object tem
, valcontents
;
1846 struct Lisp_Symbol
*sym
;
1848 CHECK_SYMBOL (variable
);
1849 sym
= indirect_variable (XSYMBOL (variable
));
1851 valcontents
= sym
->value
;
1853 if (BUFFER_OBJFWDP (valcontents
))
1855 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1856 int idx
= PER_BUFFER_IDX (offset
);
1860 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1861 PER_BUFFER_VALUE (current_buffer
, offset
)
1862 = PER_BUFFER_DEFAULT (offset
);
1867 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1870 /* Get rid of this buffer's alist element, if any. */
1871 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1872 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1874 BUF_LOCAL_VAR_ALIST (current_buffer
)
1875 = Fdelq (tem
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1877 /* If the symbol is set up with the current buffer's binding
1878 loaded, recompute its value. We have to do it now, or else
1879 forwarded objects won't work right. */
1881 Lisp_Object
*pvalbuf
, buf
;
1882 valcontents
= sym
->value
;
1883 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1884 XSETBUFFER (buf
, current_buffer
);
1885 if (EQ (buf
, *pvalbuf
))
1888 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1889 find_symbol_value (variable
);
1896 /* Lisp functions for creating and removing buffer-local variables. */
1898 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1899 when/if this is removed. */
1901 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1902 1, 1, "vMake Variable Frame Local: ",
1903 doc
: /* Enable VARIABLE to have frame-local bindings.
1904 This does not create any frame-local bindings for VARIABLE,
1905 it just makes them possible.
1907 A frame-local binding is actually a frame parameter value.
1908 If a frame F has a value for the frame parameter named VARIABLE,
1909 that also acts as a frame-local binding for VARIABLE in F--
1910 provided this function has been called to enable VARIABLE
1911 to have frame-local bindings at all.
1913 The only way to create a frame-local binding for VARIABLE in a frame
1914 is to set the VARIABLE frame parameter of that frame. See
1915 `modify-frame-parameters' for how to set frame parameters.
1917 Note that since Emacs 23.1, variables cannot be both buffer-local and
1918 frame-local any more (buffer-local bindings used to take precedence over
1919 frame-local bindings). */)
1921 register Lisp_Object variable
;
1923 register Lisp_Object tem
, valcontents
, newval
, val_vec
, len
;
1924 struct Lisp_Symbol
*sym
;
1926 CHECK_SYMBOL (variable
);
1927 sym
= indirect_variable (XSYMBOL (variable
));
1929 valcontents
= sym
->value
;
1930 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1931 || BUFFER_OBJFWDP (valcontents
))
1932 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1934 if (BUFFER_LOCAL_VALUEP (valcontents
))
1936 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1937 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1941 if (EQ (valcontents
, Qunbound
))
1943 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1945 newval
= allocate_misc ();
1946 XSETFASTINT (len
, 4);
1947 val_vec
= Fmake_vector (len
, Qnil
);
1948 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1949 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1950 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1951 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1952 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1953 BLOCAL_CDR_VEC (val_vec
) = tem
;
1954 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1955 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1956 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1957 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1958 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1959 = Lisp_Misc_ThreadLocal
;
1960 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1962 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1963 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1964 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1965 sym
->value
= newval
;
1969 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1971 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1972 BUFFER defaults to the current buffer. */)
1974 register Lisp_Object variable
, buffer
;
1976 Lisp_Object valcontents
;
1977 register struct buffer
*buf
;
1978 struct Lisp_Symbol
*sym
;
1981 buf
= current_buffer
;
1984 CHECK_BUFFER (buffer
);
1985 buf
= XBUFFER (buffer
);
1988 CHECK_SYMBOL (variable
);
1989 sym
= indirect_variable (XSYMBOL (variable
));
1990 XSETSYMBOL (variable
, sym
);
1992 valcontents
= sym
->value
;
1993 if (BUFFER_LOCAL_VALUEP (valcontents
))
1995 Lisp_Object tail
, elt
;
1997 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2000 if (EQ (variable
, XCAR (elt
)))
2004 if (BUFFER_OBJFWDP (valcontents
))
2006 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2007 int idx
= PER_BUFFER_IDX (offset
);
2008 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2014 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2016 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
2017 More precisely, this means that setting the variable \(with `set' or`setq'),
2018 while it does not have a `let'-style binding that was made in BUFFER,
2019 will produce a buffer local binding. See Info node
2020 `(elisp)Creating Buffer-Local'.
2021 BUFFER defaults to the current buffer. */)
2023 register Lisp_Object variable
, buffer
;
2025 Lisp_Object valcontents
;
2026 register struct buffer
*buf
;
2027 struct Lisp_Symbol
*sym
;
2030 buf
= current_buffer
;
2033 CHECK_BUFFER (buffer
);
2034 buf
= XBUFFER (buffer
);
2037 CHECK_SYMBOL (variable
);
2038 sym
= indirect_variable (XSYMBOL (variable
));
2039 XSETSYMBOL (variable
, sym
);
2041 valcontents
= sym
->value
;
2043 if (BUFFER_OBJFWDP (valcontents
))
2044 /* All these slots become local if they are set. */
2046 else if (BUFFER_LOCAL_VALUEP (valcontents
))
2048 Lisp_Object tail
, elt
;
2049 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
2051 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2054 if (EQ (variable
, XCAR (elt
)))
2061 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2063 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2064 If the current binding is buffer-local, the value is the current buffer.
2065 If the current binding is frame-local, the value is the selected frame.
2066 If the current binding is global (the default), the value is nil. */)
2068 register Lisp_Object variable
;
2070 Lisp_Object valcontents
;
2071 struct Lisp_Symbol
*sym
;
2073 CHECK_SYMBOL (variable
);
2074 sym
= indirect_variable (XSYMBOL (variable
));
2076 /* Make sure the current binding is actually swapped in. */
2077 find_symbol_value (variable
);
2079 valcontents
= sym
->value
;
2081 if (BUFFER_LOCAL_VALUEP (valcontents
)
2082 || BUFFER_OBJFWDP (valcontents
))
2084 /* For a local variable, record both the symbol and which
2085 buffer's or frame's value we are saving. */
2086 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2087 return Fcurrent_buffer ();
2088 else if (BUFFER_LOCAL_VALUEP (valcontents
)
2089 && BLOCAL_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))
2090 return BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
2096 /* This code is disabled now that we use the selected frame to return
2097 keyboard-local-values. */
2099 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2101 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2102 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2103 If SYMBOL is not a terminal-local variable, then return its normal
2104 value, like `symbol-value'.
2106 TERMINAL may be a terminal object, a frame, or nil (meaning the
2107 selected frame's terminal device). */)
2110 Lisp_Object terminal
;
2113 struct terminal
*t
= get_terminal (terminal
, 1);
2114 push_kboard (t
->kboard
);
2115 result
= Fsymbol_value (symbol
);
2120 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2121 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2122 If VARIABLE is not a terminal-local variable, then set its normal
2123 binding, like `set'.
2125 TERMINAL may be a terminal object, a frame, or nil (meaning the
2126 selected frame's terminal device). */)
2127 (symbol
, terminal
, value
)
2129 Lisp_Object terminal
;
2133 struct terminal
*t
= get_terminal (terminal
, 1);
2134 push_kboard (d
->kboard
);
2135 result
= Fset (symbol
, value
);
2141 /* Find the function at the end of a chain of symbol function indirections. */
2143 /* If OBJECT is a symbol, find the end of its function chain and
2144 return the value found there. If OBJECT is not a symbol, just
2145 return it. If there is a cycle in the function chain, signal a
2146 cyclic-function-indirection error.
2148 This is like Findirect_function, except that it doesn't signal an
2149 error if the chain ends up unbound. */
2151 indirect_function (object
)
2152 register Lisp_Object object
;
2154 Lisp_Object tortoise
, hare
;
2156 hare
= tortoise
= object
;
2160 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2162 hare
= XSYMBOL (hare
)->function
;
2163 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2165 hare
= XSYMBOL (hare
)->function
;
2167 tortoise
= XSYMBOL (tortoise
)->function
;
2169 if (EQ (hare
, tortoise
))
2170 xsignal1 (Qcyclic_function_indirection
, object
);
2176 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2177 doc
: /* Return the function at the end of OBJECT's function chain.
2178 If OBJECT is not a symbol, just return it. Otherwise, follow all
2179 function indirections to find the final function binding and return it.
2180 If the final symbol in the chain is unbound, signal a void-function error.
2181 Optional arg NOERROR non-nil means to return nil instead of signalling.
2182 Signal a cyclic-function-indirection error if there is a loop in the
2183 function chain of symbols. */)
2185 register Lisp_Object object
;
2186 Lisp_Object noerror
;
2190 /* Optimize for no indirection. */
2192 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2193 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2194 result
= indirect_function (result
);
2195 if (!EQ (result
, Qunbound
))
2199 xsignal1 (Qvoid_function
, object
);
2204 /* Extract and set vector and string elements */
2206 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2207 doc
: /* Return the element of ARRAY at index IDX.
2208 ARRAY may be a vector, a string, a char-table, a bool-vector,
2209 or a byte-code object. IDX starts at 0. */)
2211 register Lisp_Object array
;
2214 register int idxval
;
2217 idxval
= XINT (idx
);
2218 if (STRINGP (array
))
2222 if (idxval
< 0 || idxval
>= SCHARS (array
))
2223 args_out_of_range (array
, idx
);
2224 if (! STRING_MULTIBYTE (array
))
2225 return make_number ((unsigned char) SREF (array
, idxval
));
2226 idxval_byte
= string_char_to_byte (array
, idxval
);
2228 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2229 return make_number (c
);
2231 else if (BOOL_VECTOR_P (array
))
2235 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2236 args_out_of_range (array
, idx
);
2238 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2239 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2241 else if (CHAR_TABLE_P (array
))
2243 CHECK_CHARACTER (idx
);
2244 return CHAR_TABLE_REF (array
, idxval
);
2249 if (VECTORP (array
))
2250 size
= XVECTOR (array
)->size
;
2251 else if (COMPILEDP (array
))
2252 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2254 wrong_type_argument (Qarrayp
, array
);
2256 if (idxval
< 0 || idxval
>= size
)
2257 args_out_of_range (array
, idx
);
2258 return XVECTOR (array
)->contents
[idxval
];
2262 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2263 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2264 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2265 bool-vector. IDX starts at 0. */)
2266 (array
, idx
, newelt
)
2267 register Lisp_Object array
;
2268 Lisp_Object idx
, newelt
;
2270 register int idxval
;
2273 idxval
= XINT (idx
);
2274 CHECK_ARRAY (array
, Qarrayp
);
2275 CHECK_IMPURE (array
);
2277 if (VECTORP (array
))
2279 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2280 args_out_of_range (array
, idx
);
2281 XVECTOR (array
)->contents
[idxval
] = newelt
;
2283 else if (BOOL_VECTOR_P (array
))
2287 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2288 args_out_of_range (array
, idx
);
2290 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2292 if (! NILP (newelt
))
2293 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2295 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2296 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2298 else if (CHAR_TABLE_P (array
))
2300 CHECK_CHARACTER (idx
);
2301 CHAR_TABLE_SET (array
, idxval
, newelt
);
2303 else if (STRING_MULTIBYTE (array
))
2305 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2306 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2308 if (idxval
< 0 || idxval
>= SCHARS (array
))
2309 args_out_of_range (array
, idx
);
2310 CHECK_CHARACTER (newelt
);
2312 nbytes
= SBYTES (array
);
2314 idxval_byte
= string_char_to_byte (array
, idxval
);
2315 p1
= SDATA (array
) + idxval_byte
;
2316 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2317 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2318 if (prev_bytes
!= new_bytes
)
2320 /* We must relocate the string data. */
2321 int nchars
= SCHARS (array
);
2325 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2326 bcopy (SDATA (array
), str
, nbytes
);
2327 allocate_string_data (XSTRING (array
), nchars
,
2328 nbytes
+ new_bytes
- prev_bytes
);
2329 bcopy (str
, SDATA (array
), idxval_byte
);
2330 p1
= SDATA (array
) + idxval_byte
;
2331 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2332 nbytes
- (idxval_byte
+ prev_bytes
));
2334 clear_string_char_byte_cache ();
2341 if (idxval
< 0 || idxval
>= SCHARS (array
))
2342 args_out_of_range (array
, idx
);
2343 CHECK_NUMBER (newelt
);
2345 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2349 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2350 if (SREF (array
, i
) >= 0x80)
2351 args_out_of_range (array
, newelt
);
2352 /* ARRAY is an ASCII string. Convert it to a multibyte
2353 string, and try `aset' again. */
2354 STRING_SET_MULTIBYTE (array
);
2355 return Faset (array
, idx
, newelt
);
2357 SSET (array
, idxval
, XINT (newelt
));
2363 /* Arithmetic functions */
2365 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2368 arithcompare (num1
, num2
, comparison
)
2369 Lisp_Object num1
, num2
;
2370 enum comparison comparison
;
2372 double f1
= 0, f2
= 0;
2375 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2376 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2378 if (FLOATP (num1
) || FLOATP (num2
))
2381 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2382 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2388 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2393 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2398 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2403 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2408 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2413 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2422 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2423 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2425 register Lisp_Object num1
, num2
;
2427 return arithcompare (num1
, num2
, equal
);
2430 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2431 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2433 register Lisp_Object num1
, num2
;
2435 return arithcompare (num1
, num2
, less
);
2438 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2439 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2441 register Lisp_Object num1
, num2
;
2443 return arithcompare (num1
, num2
, grtr
);
2446 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2447 doc
: /* Return t if first arg is less than or equal to second arg.
2448 Both must be numbers or markers. */)
2450 register Lisp_Object num1
, num2
;
2452 return arithcompare (num1
, num2
, less_or_equal
);
2455 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2456 doc
: /* Return t if first arg is greater than or equal to second arg.
2457 Both must be numbers or markers. */)
2459 register Lisp_Object num1
, num2
;
2461 return arithcompare (num1
, num2
, grtr_or_equal
);
2464 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2465 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2467 register Lisp_Object num1
, num2
;
2469 return arithcompare (num1
, num2
, notequal
);
2472 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2473 doc
: /* Return t if NUMBER is zero. */)
2475 register Lisp_Object number
;
2477 CHECK_NUMBER_OR_FLOAT (number
);
2479 if (FLOATP (number
))
2481 if (XFLOAT_DATA (number
) == 0.0)
2491 /* Convert between long values and pairs of Lisp integers.
2492 Note that long_to_cons returns a single Lisp integer
2493 when the value fits in one. */
2499 unsigned long top
= i
>> 16;
2500 unsigned int bot
= i
& 0xFFFF;
2502 return make_number (bot
);
2503 if (top
== (unsigned long)-1 >> 16)
2504 return Fcons (make_number (-1), make_number (bot
));
2505 return Fcons (make_number (top
), make_number (bot
));
2512 Lisp_Object top
, bot
;
2519 return ((XINT (top
) << 16) | XINT (bot
));
2522 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2523 doc
: /* Return the decimal representation of NUMBER as a string.
2524 Uses a minus sign if negative.
2525 NUMBER may be an integer or a floating point number. */)
2529 char buffer
[VALBITS
];
2531 CHECK_NUMBER_OR_FLOAT (number
);
2533 if (FLOATP (number
))
2535 char pigbuf
[350]; /* see comments in float_to_string */
2537 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2538 return build_string (pigbuf
);
2541 if (sizeof (int) == sizeof (EMACS_INT
))
2542 sprintf (buffer
, "%d", (int) XINT (number
));
2543 else if (sizeof (long) == sizeof (EMACS_INT
))
2544 sprintf (buffer
, "%ld", (long) XINT (number
));
2547 return build_string (buffer
);
2551 digit_to_number (character
, base
)
2552 int character
, base
;
2556 if (character
>= '0' && character
<= '9')
2557 digit
= character
- '0';
2558 else if (character
>= 'a' && character
<= 'z')
2559 digit
= character
- 'a' + 10;
2560 else if (character
>= 'A' && character
<= 'Z')
2561 digit
= character
- 'A' + 10;
2571 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2572 doc
: /* Parse STRING as a decimal number and return the number.
2573 This parses both integers and floating point numbers.
2574 It ignores leading spaces and tabs, and all trailing chars.
2576 If BASE, interpret STRING as a number in that base. If BASE isn't
2577 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2578 If the base used is not 10, STRING is always parsed as integer. */)
2580 register Lisp_Object string
, base
;
2582 register unsigned char *p
;
2587 CHECK_STRING (string
);
2593 CHECK_NUMBER (base
);
2595 if (b
< 2 || b
> 16)
2596 xsignal1 (Qargs_out_of_range
, base
);
2599 /* Skip any whitespace at the front of the number. Some versions of
2600 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2602 while (*p
== ' ' || *p
== '\t')
2613 if (isfloat_string (p
, 1) && b
== 10)
2614 val
= make_float (sign
* atof (p
));
2621 int digit
= digit_to_number (*p
++, b
);
2627 val
= make_fixnum_or_float (sign
* v
);
2647 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2648 int, Lisp_Object
*));
2649 extern Lisp_Object
fmod_float ();
2652 arith_driver (code
, nargs
, args
)
2655 register Lisp_Object
*args
;
2657 register Lisp_Object val
;
2658 register int argnum
;
2659 register EMACS_INT accum
= 0;
2660 register EMACS_INT next
;
2662 switch (SWITCH_ENUM_CAST (code
))
2680 for (argnum
= 0; argnum
< nargs
; argnum
++)
2682 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2684 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2687 return float_arith_driver ((double) accum
, argnum
, code
,
2690 next
= XINT (args
[argnum
]);
2691 switch (SWITCH_ENUM_CAST (code
))
2697 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2708 xsignal0 (Qarith_error
);
2722 if (!argnum
|| next
> accum
)
2726 if (!argnum
|| next
< accum
)
2732 XSETINT (val
, accum
);
2737 #define isnan(x) ((x) != (x))
2740 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2742 register int argnum
;
2745 register Lisp_Object
*args
;
2747 register Lisp_Object val
;
2750 for (; argnum
< nargs
; argnum
++)
2752 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2753 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2757 next
= XFLOAT_DATA (val
);
2761 args
[argnum
] = val
; /* runs into a compiler bug. */
2762 next
= XINT (args
[argnum
]);
2764 switch (SWITCH_ENUM_CAST (code
))
2770 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2780 if (! IEEE_FLOATING_POINT
&& next
== 0)
2781 xsignal0 (Qarith_error
);
2788 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2790 if (!argnum
|| isnan (next
) || next
> accum
)
2794 if (!argnum
|| isnan (next
) || next
< accum
)
2800 return make_float (accum
);
2804 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2805 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2806 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2811 return arith_driver (Aadd
, nargs
, args
);
2814 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2815 doc
: /* Negate number or subtract numbers or markers and return the result.
2816 With one arg, negates it. With more than one arg,
2817 subtracts all but the first from the first.
2818 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2823 return arith_driver (Asub
, nargs
, args
);
2826 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2827 doc
: /* Return product of any number of arguments, which are numbers or markers.
2828 usage: (* &rest NUMBERS-OR-MARKERS) */)
2833 return arith_driver (Amult
, nargs
, args
);
2836 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2837 doc
: /* Return first argument divided by all the remaining arguments.
2838 The arguments must be numbers or markers.
2839 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2845 for (argnum
= 2; argnum
< nargs
; argnum
++)
2846 if (FLOATP (args
[argnum
]))
2847 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2848 return arith_driver (Adiv
, nargs
, args
);
2851 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2852 doc
: /* Return remainder of X divided by Y.
2853 Both must be integers or markers. */)
2855 register Lisp_Object x
, y
;
2859 CHECK_NUMBER_COERCE_MARKER (x
);
2860 CHECK_NUMBER_COERCE_MARKER (y
);
2862 if (XFASTINT (y
) == 0)
2863 xsignal0 (Qarith_error
);
2865 XSETINT (val
, XINT (x
) % XINT (y
));
2879 /* If the magnitude of the result exceeds that of the divisor, or
2880 the sign of the result does not agree with that of the dividend,
2881 iterate with the reduced value. This does not yield a
2882 particularly accurate result, but at least it will be in the
2883 range promised by fmod. */
2885 r
-= f2
* floor (r
/ f2
);
2886 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2890 #endif /* ! HAVE_FMOD */
2892 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2893 doc
: /* Return X modulo Y.
2894 The result falls between zero (inclusive) and Y (exclusive).
2895 Both X and Y must be numbers or markers. */)
2897 register Lisp_Object x
, y
;
2902 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2903 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2905 if (FLOATP (x
) || FLOATP (y
))
2906 return fmod_float (x
, y
);
2912 xsignal0 (Qarith_error
);
2916 /* If the "remainder" comes out with the wrong sign, fix it. */
2917 if (i2
< 0 ? i1
> 0 : i1
< 0)
2924 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2925 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2926 The value is always a number; markers are converted to numbers.
2927 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2932 return arith_driver (Amax
, nargs
, args
);
2935 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2936 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2937 The value is always a number; markers are converted to numbers.
2938 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2943 return arith_driver (Amin
, nargs
, args
);
2946 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2947 doc
: /* Return bitwise-and of all the arguments.
2948 Arguments may be integers, or markers converted to integers.
2949 usage: (logand &rest INTS-OR-MARKERS) */)
2954 return arith_driver (Alogand
, nargs
, args
);
2957 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2958 doc
: /* Return bitwise-or of all the arguments.
2959 Arguments may be integers, or markers converted to integers.
2960 usage: (logior &rest INTS-OR-MARKERS) */)
2965 return arith_driver (Alogior
, nargs
, args
);
2968 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2969 doc
: /* Return bitwise-exclusive-or of all the arguments.
2970 Arguments may be integers, or markers converted to integers.
2971 usage: (logxor &rest INTS-OR-MARKERS) */)
2976 return arith_driver (Alogxor
, nargs
, args
);
2979 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2980 doc
: /* Return VALUE with its bits shifted left by COUNT.
2981 If COUNT is negative, shifting is actually to the right.
2982 In this case, the sign bit is duplicated. */)
2984 register Lisp_Object value
, count
;
2986 register Lisp_Object val
;
2988 CHECK_NUMBER (value
);
2989 CHECK_NUMBER (count
);
2991 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2993 else if (XINT (count
) > 0)
2994 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2995 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2996 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2998 XSETINT (val
, XINT (value
) >> -XINT (count
));
3002 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
3003 doc
: /* Return VALUE with its bits shifted left by COUNT.
3004 If COUNT is negative, shifting is actually to the right.
3005 In this case, zeros are shifted in on the left. */)
3007 register Lisp_Object value
, count
;
3009 register Lisp_Object val
;
3011 CHECK_NUMBER (value
);
3012 CHECK_NUMBER (count
);
3014 if (XINT (count
) >= BITS_PER_EMACS_INT
)
3016 else if (XINT (count
) > 0)
3017 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
3018 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
3021 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
3025 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3026 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3027 Markers are converted to integers. */)
3029 register Lisp_Object number
;
3031 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3033 if (FLOATP (number
))
3034 return (make_float (1.0 + XFLOAT_DATA (number
)));
3036 XSETINT (number
, XINT (number
) + 1);
3040 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3041 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3042 Markers are converted to integers. */)
3044 register Lisp_Object number
;
3046 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3048 if (FLOATP (number
))
3049 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3051 XSETINT (number
, XINT (number
) - 1);
3055 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3056 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3058 register Lisp_Object number
;
3060 CHECK_NUMBER (number
);
3061 XSETINT (number
, ~XINT (number
));
3065 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3066 doc
: /* Return the byteorder for the machine.
3067 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3068 lowercase l) for small endian machines. */)
3071 unsigned i
= 0x04030201;
3072 int order
= *(char *)&i
== 1 ? 108 : 66;
3074 return make_number (order
);
3082 Lisp_Object error_tail
, arith_tail
;
3084 Qquote
= intern_c_string ("quote");
3085 Qlambda
= intern_c_string ("lambda");
3086 Qsubr
= intern_c_string ("subr");
3087 Qerror_conditions
= intern_c_string ("error-conditions");
3088 Qerror_message
= intern_c_string ("error-message");
3089 Qtop_level
= intern_c_string ("top-level");
3091 Qerror
= intern_c_string ("error");
3092 Qquit
= intern_c_string ("quit");
3093 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3094 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3095 Qvoid_function
= intern_c_string ("void-function");
3096 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3097 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3098 Qvoid_variable
= intern_c_string ("void-variable");
3099 Qsetting_constant
= intern_c_string ("setting-constant");
3100 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3102 Qinvalid_function
= intern_c_string ("invalid-function");
3103 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3104 Qno_catch
= intern_c_string ("no-catch");
3105 Qend_of_file
= intern_c_string ("end-of-file");
3106 Qarith_error
= intern_c_string ("arith-error");
3107 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3108 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3109 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3110 Qtext_read_only
= intern_c_string ("text-read-only");
3111 Qmark_inactive
= intern_c_string ("mark-inactive");
3113 Qlistp
= intern_c_string ("listp");
3114 Qconsp
= intern_c_string ("consp");
3115 Qsymbolp
= intern_c_string ("symbolp");
3116 Qkeywordp
= intern_c_string ("keywordp");
3117 Qintegerp
= intern_c_string ("integerp");
3118 Qnatnump
= intern_c_string ("natnump");
3119 Qwholenump
= intern_c_string ("wholenump");
3120 Qstringp
= intern_c_string ("stringp");
3121 Qarrayp
= intern_c_string ("arrayp");
3122 Qsequencep
= intern_c_string ("sequencep");
3123 Qbufferp
= intern_c_string ("bufferp");
3124 Qvectorp
= intern_c_string ("vectorp");
3125 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3126 Qmarkerp
= intern_c_string ("markerp");
3127 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3128 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3129 Qboundp
= intern_c_string ("boundp");
3130 Qfboundp
= intern_c_string ("fboundp");
3132 Qfloatp
= intern_c_string ("floatp");
3133 Qnumberp
= intern_c_string ("numberp");
3134 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3136 Qchar_table_p
= intern_c_string ("char-table-p");
3137 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3139 Qsubrp
= intern_c_string ("subrp");
3140 Qunevalled
= intern_c_string ("unevalled");
3141 Qmany
= intern_c_string ("many");
3143 Qcdr
= intern_c_string ("cdr");
3145 /* Handle automatic advice activation */
3146 Qad_advice_info
= intern_c_string ("ad-advice-info");
3147 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3149 error_tail
= pure_cons (Qerror
, Qnil
);
3151 /* ERROR is used as a signaler for random errors for which nothing else is right */
3153 Fput (Qerror
, Qerror_conditions
,
3155 Fput (Qerror
, Qerror_message
,
3156 make_pure_c_string ("error"));
3158 Fput (Qquit
, Qerror_conditions
,
3159 pure_cons (Qquit
, Qnil
));
3160 Fput (Qquit
, Qerror_message
,
3161 make_pure_c_string ("Quit"));
3163 Fput (Qwrong_type_argument
, Qerror_conditions
,
3164 pure_cons (Qwrong_type_argument
, error_tail
));
3165 Fput (Qwrong_type_argument
, Qerror_message
,
3166 make_pure_c_string ("Wrong type argument"));
3168 Fput (Qargs_out_of_range
, Qerror_conditions
,
3169 pure_cons (Qargs_out_of_range
, error_tail
));
3170 Fput (Qargs_out_of_range
, Qerror_message
,
3171 make_pure_c_string ("Args out of range"));
3173 Fput (Qvoid_function
, Qerror_conditions
,
3174 pure_cons (Qvoid_function
, error_tail
));
3175 Fput (Qvoid_function
, Qerror_message
,
3176 make_pure_c_string ("Symbol's function definition is void"));
3178 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3179 pure_cons (Qcyclic_function_indirection
, error_tail
));
3180 Fput (Qcyclic_function_indirection
, Qerror_message
,
3181 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3183 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3184 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3185 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3186 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3188 Qcircular_list
= intern_c_string ("circular-list");
3189 staticpro (&Qcircular_list
);
3190 Fput (Qcircular_list
, Qerror_conditions
,
3191 pure_cons (Qcircular_list
, error_tail
));
3192 Fput (Qcircular_list
, Qerror_message
,
3193 make_pure_c_string ("List contains a loop"));
3195 Fput (Qvoid_variable
, Qerror_conditions
,
3196 pure_cons (Qvoid_variable
, error_tail
));
3197 Fput (Qvoid_variable
, Qerror_message
,
3198 make_pure_c_string ("Symbol's value as variable is void"));
3200 Fput (Qsetting_constant
, Qerror_conditions
,
3201 pure_cons (Qsetting_constant
, error_tail
));
3202 Fput (Qsetting_constant
, Qerror_message
,
3203 make_pure_c_string ("Attempt to set a constant symbol"));
3205 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3206 pure_cons (Qinvalid_read_syntax
, error_tail
));
3207 Fput (Qinvalid_read_syntax
, Qerror_message
,
3208 make_pure_c_string ("Invalid read syntax"));
3210 Fput (Qinvalid_function
, Qerror_conditions
,
3211 pure_cons (Qinvalid_function
, error_tail
));
3212 Fput (Qinvalid_function
, Qerror_message
,
3213 make_pure_c_string ("Invalid function"));
3215 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3216 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3217 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3218 make_pure_c_string ("Wrong number of arguments"));
3220 Fput (Qno_catch
, Qerror_conditions
,
3221 pure_cons (Qno_catch
, error_tail
));
3222 Fput (Qno_catch
, Qerror_message
,
3223 make_pure_c_string ("No catch for tag"));
3225 Fput (Qend_of_file
, Qerror_conditions
,
3226 pure_cons (Qend_of_file
, error_tail
));
3227 Fput (Qend_of_file
, Qerror_message
,
3228 make_pure_c_string ("End of file during parsing"));
3230 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3231 Fput (Qarith_error
, Qerror_conditions
,
3233 Fput (Qarith_error
, Qerror_message
,
3234 make_pure_c_string ("Arithmetic error"));
3236 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3237 pure_cons (Qbeginning_of_buffer
, error_tail
));
3238 Fput (Qbeginning_of_buffer
, Qerror_message
,
3239 make_pure_c_string ("Beginning of buffer"));
3241 Fput (Qend_of_buffer
, Qerror_conditions
,
3242 pure_cons (Qend_of_buffer
, error_tail
));
3243 Fput (Qend_of_buffer
, Qerror_message
,
3244 make_pure_c_string ("End of buffer"));
3246 Fput (Qbuffer_read_only
, Qerror_conditions
,
3247 pure_cons (Qbuffer_read_only
, error_tail
));
3248 Fput (Qbuffer_read_only
, Qerror_message
,
3249 make_pure_c_string ("Buffer is read-only"));
3251 Fput (Qtext_read_only
, Qerror_conditions
,
3252 pure_cons (Qtext_read_only
, error_tail
));
3253 Fput (Qtext_read_only
, Qerror_message
,
3254 make_pure_c_string ("Text is read-only"));
3256 Qrange_error
= intern_c_string ("range-error");
3257 Qdomain_error
= intern_c_string ("domain-error");
3258 Qsingularity_error
= intern_c_string ("singularity-error");
3259 Qoverflow_error
= intern_c_string ("overflow-error");
3260 Qunderflow_error
= intern_c_string ("underflow-error");
3262 Fput (Qdomain_error
, Qerror_conditions
,
3263 pure_cons (Qdomain_error
, arith_tail
));
3264 Fput (Qdomain_error
, Qerror_message
,
3265 make_pure_c_string ("Arithmetic domain error"));
3267 Fput (Qrange_error
, Qerror_conditions
,
3268 pure_cons (Qrange_error
, arith_tail
));
3269 Fput (Qrange_error
, Qerror_message
,
3270 make_pure_c_string ("Arithmetic range error"));
3272 Fput (Qsingularity_error
, Qerror_conditions
,
3273 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3274 Fput (Qsingularity_error
, Qerror_message
,
3275 make_pure_c_string ("Arithmetic singularity error"));
3277 Fput (Qoverflow_error
, Qerror_conditions
,
3278 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3279 Fput (Qoverflow_error
, Qerror_message
,
3280 make_pure_c_string ("Arithmetic overflow error"));
3282 Fput (Qunderflow_error
, Qerror_conditions
,
3283 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3284 Fput (Qunderflow_error
, Qerror_message
,
3285 make_pure_c_string ("Arithmetic underflow error"));
3287 staticpro (&Qrange_error
);
3288 staticpro (&Qdomain_error
);
3289 staticpro (&Qsingularity_error
);
3290 staticpro (&Qoverflow_error
);
3291 staticpro (&Qunderflow_error
);
3295 staticpro (&Qquote
);
3296 staticpro (&Qlambda
);
3298 staticpro (&Qunbound
);
3299 staticpro (&Qerror_conditions
);
3300 staticpro (&Qerror_message
);
3301 staticpro (&Qtop_level
);
3303 staticpro (&Qerror
);
3305 staticpro (&Qwrong_type_argument
);
3306 staticpro (&Qargs_out_of_range
);
3307 staticpro (&Qvoid_function
);
3308 staticpro (&Qcyclic_function_indirection
);
3309 staticpro (&Qcyclic_variable_indirection
);
3310 staticpro (&Qvoid_variable
);
3311 staticpro (&Qsetting_constant
);
3312 staticpro (&Qinvalid_read_syntax
);
3313 staticpro (&Qwrong_number_of_arguments
);
3314 staticpro (&Qinvalid_function
);
3315 staticpro (&Qno_catch
);
3316 staticpro (&Qend_of_file
);
3317 staticpro (&Qarith_error
);
3318 staticpro (&Qbeginning_of_buffer
);
3319 staticpro (&Qend_of_buffer
);
3320 staticpro (&Qbuffer_read_only
);
3321 staticpro (&Qtext_read_only
);
3322 staticpro (&Qmark_inactive
);
3324 staticpro (&Qlistp
);
3325 staticpro (&Qconsp
);
3326 staticpro (&Qsymbolp
);
3327 staticpro (&Qkeywordp
);
3328 staticpro (&Qintegerp
);
3329 staticpro (&Qnatnump
);
3330 staticpro (&Qwholenump
);
3331 staticpro (&Qstringp
);
3332 staticpro (&Qarrayp
);
3333 staticpro (&Qsequencep
);
3334 staticpro (&Qbufferp
);
3335 staticpro (&Qvectorp
);
3336 staticpro (&Qchar_or_string_p
);
3337 staticpro (&Qmarkerp
);
3338 staticpro (&Qbuffer_or_string_p
);
3339 staticpro (&Qinteger_or_marker_p
);
3340 staticpro (&Qfloatp
);
3341 staticpro (&Qnumberp
);
3342 staticpro (&Qnumber_or_marker_p
);
3343 staticpro (&Qchar_table_p
);
3344 staticpro (&Qvector_or_char_table_p
);
3345 staticpro (&Qsubrp
);
3347 staticpro (&Qunevalled
);
3349 staticpro (&Qboundp
);
3350 staticpro (&Qfboundp
);
3352 staticpro (&Qad_advice_info
);
3353 staticpro (&Qad_activate_internal
);
3355 /* Types that type-of returns. */
3356 Qinteger
= intern_c_string ("integer");
3357 Qsymbol
= intern_c_string ("symbol");
3358 Qstring
= intern_c_string ("string");
3359 Qcons
= intern_c_string ("cons");
3360 Qmarker
= intern_c_string ("marker");
3361 Qoverlay
= intern_c_string ("overlay");
3362 Qfloat
= intern_c_string ("float");
3363 Qwindow_configuration
= intern_c_string ("window-configuration");
3364 Qprocess
= intern_c_string ("process");
3365 Qwindow
= intern_c_string ("window");
3366 /* Qsubr = intern_c_string ("subr"); */
3367 Qcompiled_function
= intern_c_string ("compiled-function");
3368 Qbuffer
= intern_c_string ("buffer");
3369 Qframe
= intern_c_string ("frame");
3370 Qvector
= intern_c_string ("vector");
3371 Qchar_table
= intern_c_string ("char-table");
3372 Qbool_vector
= intern_c_string ("bool-vector");
3373 Qhash_table
= intern_c_string ("hash-table");
3375 Qthread_local_mark
= Fmake_symbol (make_pure_string ("thread-local-mark",
3378 DEFSYM (Qfont_spec
, "font-spec");
3379 DEFSYM (Qfont_entity
, "font-entity");
3380 DEFSYM (Qfont_object
, "font-object");
3382 DEFSYM (Qinteractive_form
, "interactive-form");
3384 staticpro (&Qinteger
);
3385 staticpro (&Qsymbol
);
3386 staticpro (&Qstring
);
3388 staticpro (&Qmarker
);
3389 staticpro (&Qoverlay
);
3390 staticpro (&Qfloat
);
3391 staticpro (&Qwindow_configuration
);
3392 staticpro (&Qprocess
);
3393 staticpro (&Qwindow
);
3394 /* staticpro (&Qsubr); */
3395 staticpro (&Qcompiled_function
);
3396 staticpro (&Qbuffer
);
3397 staticpro (&Qframe
);
3398 staticpro (&Qvector
);
3399 staticpro (&Qchar_table
);
3400 staticpro (&Qbool_vector
);
3401 staticpro (&Qhash_table
);
3402 staticpro (&Qthread_local_mark
);
3404 defsubr (&Sindirect_variable
);
3405 defsubr (&Sinteractive_form
);
3408 defsubr (&Stype_of
);
3413 defsubr (&Sintegerp
);
3414 defsubr (&Sinteger_or_marker_p
);
3415 defsubr (&Snumberp
);
3416 defsubr (&Snumber_or_marker_p
);
3418 defsubr (&Snatnump
);
3419 defsubr (&Ssymbolp
);
3420 defsubr (&Skeywordp
);
3421 defsubr (&Sstringp
);
3422 defsubr (&Smultibyte_string_p
);
3423 defsubr (&Svectorp
);
3424 defsubr (&Schar_table_p
);
3425 defsubr (&Svector_or_char_table_p
);
3426 defsubr (&Sbool_vector_p
);
3428 defsubr (&Ssequencep
);
3429 defsubr (&Sbufferp
);
3430 defsubr (&Smarkerp
);
3432 defsubr (&Sbyte_code_function_p
);
3433 defsubr (&Schar_or_string_p
);
3436 defsubr (&Scar_safe
);
3437 defsubr (&Scdr_safe
);
3440 defsubr (&Ssymbol_function
);
3441 defsubr (&Sindirect_function
);
3442 defsubr (&Ssymbol_plist
);
3443 defsubr (&Ssymbol_name
);
3444 defsubr (&Smakunbound
);
3445 defsubr (&Sfmakunbound
);
3447 defsubr (&Sfboundp
);
3449 defsubr (&Sdefalias
);
3450 defsubr (&Ssetplist
);
3451 defsubr (&Ssymbol_value
);
3453 defsubr (&Sdefault_boundp
);
3454 defsubr (&Sdefault_value
);
3455 defsubr (&Sset_default
);
3456 defsubr (&Ssetq_default
);
3457 defsubr (&Smake_variable_buffer_local
);
3458 defsubr (&Smake_local_variable
);
3459 defsubr (&Skill_local_variable
);
3460 defsubr (&Smake_variable_frame_local
);
3461 defsubr (&Slocal_variable_p
);
3462 defsubr (&Slocal_variable_if_set_p
);
3463 defsubr (&Svariable_binding_locus
);
3464 #if 0 /* XXX Remove this. --lorentey */
3465 defsubr (&Sterminal_local_value
);
3466 defsubr (&Sset_terminal_local_value
);
3470 defsubr (&Snumber_to_string
);
3471 defsubr (&Sstring_to_number
);
3472 defsubr (&Seqlsign
);
3495 defsubr (&Sbyteorder
);
3496 defsubr (&Ssubr_arity
);
3497 defsubr (&Ssubr_name
);
3499 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3501 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3502 doc
: /* The largest value that is representable in a Lisp integer. */);
3503 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3504 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3506 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3507 doc
: /* The smallest value that is representable in a Lisp integer. */);
3508 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3509 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3516 sigsetmask (SIGEMPTYMASK
);
3518 SIGNAL_THREAD_CHECK (signo
);
3519 xsignal0 (Qarith_error
);
3525 /* Don't do this if just dumping out.
3526 We don't want to call `signal' in this case
3527 so that we don't have trouble with dumping
3528 signal-delivering routines in an inconsistent state. */
3532 #endif /* CANNOT_DUMP */
3533 signal (SIGFPE
, arith_error
);
3536 signal (SIGEMT
, arith_error
);
3540 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3541 (do not change this comment) */