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
)
819 Lisp_Object ret
= assq_no_quit (get_current_thread (), l
->thread_data
);
822 Lisp_Object tem
, val
= Qnil
, len
, it
, parent
= Qnil
;
824 for (it
= l
->thread_data
; !NILP (it
); it
= XCDR (it
))
826 Lisp_Object head
= XCDR (XCAR (it
));
827 if ((EQ (Fcurrent_buffer (), BLOCAL_BUFFER_VEC (head
)))
829 || EQ (selected_frame
, BLOCAL_FRAME_VEC (head
))))
831 val
= XCDR (BLOCAL_CDR_VEC (head
));
838 XSETFASTINT (len
, 4);
839 ret
= Fmake_vector (len
, Qnil
);
842 XSETFASTINT (AREF (ret
, 0), 0);
844 XSETFASTINT (AREF (ret
, 0), AREF (parent
, 0));
846 BLOCAL_BUFFER_VEC (ret
) = Fcurrent_buffer ();
847 BLOCAL_FRAME_VEC (ret
) = Qnil
;
849 tem
= Fcons (Qnil
, val
);
851 BLOCAL_CDR_VEC (ret
) = tem
;
853 ret
= Fcons (get_current_thread (), ret
);
854 l
->thread_data
= Fcons (ret
, l
->thread_data
);
855 XTHREADLOCAL (l
->realvalue
)->thread_alist
=
856 Fcons (Fcons (get_current_thread (), val
),
857 XTHREADLOCAL (l
->realvalue
)->thread_alist
);
860 return &XCDR_AS_LVALUE (ret
);
864 blocal_set_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object obj
)
866 if (! NILP (l
->thread_data
))
869 l
->thread_data
= Fcons (Fcons (get_current_thread (), obj
), Qnil
);
873 find_variable_location (Lisp_Object
*root
)
875 if (THREADLOCALP (*root
))
877 struct Lisp_ThreadLocal
*thr
= XTHREADLOCAL (*root
);
878 Lisp_Object cons
= assq_no_quit (get_current_thread (),
880 if (!EQ (cons
, Qnil
))
881 return &XCDR_AS_LVALUE (cons
);
890 ensure_thread_local (Lisp_Object
*root
)
894 if (THREADLOCALP (*root
))
895 cons
= assq_no_quit (get_current_thread (),
896 XTHREADLOCAL (*root
)->thread_alist
);
900 newval
= allocate_misc ();
901 XMISCTYPE (newval
) = Lisp_Misc_ThreadLocal
;
902 XTHREADLOCAL (newval
)->global
= *root
;
903 XTHREADLOCAL (newval
)->thread_alist
= Qnil
;
910 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
911 cons
= Fcons (get_current_thread (), XTHREADLOCAL (*root
)->global
);
912 local
->thread_alist
= Fcons (cons
, local
->thread_alist
);
919 remove_thread_local (Lisp_Object
*root
)
921 if (THREADLOCALP (*root
))
923 Lisp_Object iter
, thr
= get_current_thread (), prior
= Qnil
;
924 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
925 for (iter
= local
->thread_alist
; !NILP (iter
); iter
= XCDR (iter
))
927 if (EQ (XCAR (XCAR (iter
)), thr
))
930 local
->thread_alist
= XCDR (iter
);
932 XSETCDR (prior
, XCDR (iter
));
940 /* Return the symbol holding SYMBOL's value. Signal
941 `cyclic-variable-indirection' if SYMBOL's chain of variable
942 indirections contains a loop. */
945 indirect_variable (symbol
)
946 struct Lisp_Symbol
*symbol
;
948 struct Lisp_Symbol
*tortoise
, *hare
;
950 hare
= tortoise
= symbol
;
952 while (hare
->indirect_variable
)
954 hare
= XSYMBOL (hare
->value
);
955 if (!hare
->indirect_variable
)
958 hare
= XSYMBOL (hare
->value
);
959 tortoise
= XSYMBOL (tortoise
->value
);
961 if (hare
== tortoise
)
964 XSETSYMBOL (tem
, symbol
);
965 xsignal1 (Qcyclic_variable_indirection
, tem
);
973 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
974 doc
: /* Return the variable at the end of OBJECT's variable chain.
975 If OBJECT is a symbol, follow all variable indirections and return the final
976 variable. If OBJECT is not a symbol, just return it.
977 Signal a cyclic-variable-indirection error if there is a loop in the
978 variable chain of symbols. */)
982 if (SYMBOLP (object
))
983 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
988 /* Given the raw contents of a symbol value cell,
989 return the Lisp value of the symbol.
990 This does not handle buffer-local variables; use
991 swap_in_symval_forwarding for that. */
994 do_symval_forwarding (valcontents
)
995 Lisp_Object valcontents
;
997 register Lisp_Object val
;
998 if (MISCP (valcontents
))
999 switch (XMISCTYPE (valcontents
))
1001 case Lisp_Misc_Intfwd
:
1002 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1005 case Lisp_Misc_Boolfwd
:
1006 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1008 case Lisp_Misc_Objfwd
:
1009 return *XOBJFWD (valcontents
)->objvar
;
1011 case Lisp_Misc_Buffer_Objfwd
:
1012 return PER_BUFFER_VALUE (current_buffer
,
1013 XBUFFER_OBJFWD (valcontents
)->offset
);
1015 case Lisp_Misc_Kboard_Objfwd
:
1016 /* We used to simply use current_kboard here, but from Lisp
1017 code, it's value is often unexpected. It seems nicer to
1018 allow constructions like this to work as intuitively expected:
1020 (with-selected-frame frame
1021 (define-key local-function-map "\eOP" [f1]))
1023 On the other hand, this affects the semantics of
1024 last-command and real-last-command, and people may rely on
1025 that. I took a quick look at the Lisp codebase, and I
1026 don't think anything will break. --lorentey */
1027 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1028 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1030 case Lisp_Misc_ThreadLocal
:
1031 return *find_variable_location (&valcontents
);
1036 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1037 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1038 buffer-independent contents of the value cell: forwarded just one
1039 step past the buffer-localness.
1041 BUF non-zero means set the value in buffer BUF instead of the
1042 current buffer. This only plays a role for per-buffer variables. */
1045 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
1047 register Lisp_Object valcontents
, newval
;
1050 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
1053 switch (XMISCTYPE (valcontents
))
1055 case Lisp_Misc_Intfwd
:
1056 CHECK_NUMBER (newval
);
1057 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1058 /* This can never happen since intvar points to an EMACS_INT
1059 which is at least large enough to hold a Lisp_Object.
1060 if (*XINTFWD (valcontents)->intvar != XINT (newval))
1061 error ("Value out of range for variable `%s'",
1062 SDATA (SYMBOL_NAME (symbol))); */
1065 case Lisp_Misc_Boolfwd
:
1066 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1069 case Lisp_Misc_Objfwd
:
1070 *find_variable_location (XOBJFWD (valcontents
)->objvar
) = newval
;
1072 /* If this variable is a default for something stored
1073 in the buffer itself, such as default-fill-column,
1074 find the buffers that don't have local values for it
1076 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1077 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1079 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1080 - (char *) &buffer_defaults
);
1081 int idx
= PER_BUFFER_IDX (offset
);
1088 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
1093 buf
= Fcdr (XCAR (tail
));
1094 if (!BUFFERP (buf
)) continue;
1097 if (! PER_BUFFER_VALUE_P (b
, idx
))
1098 SET_PER_BUFFER_VALUE_RAW (b
, offset
, newval
);
1103 case Lisp_Misc_Buffer_Objfwd
:
1105 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1106 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1108 if (!(NILP (type
) || NILP (newval
)
1109 || (XINT (type
) == LISP_INT_TAG
1111 : XTYPE (newval
) == XINT (type
))))
1112 buffer_slot_type_mismatch (newval
, XINT (type
));
1115 buf
= current_buffer
;
1116 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1120 case Lisp_Misc_Kboard_Objfwd
:
1122 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1123 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1124 *(Lisp_Object
*) p
= newval
;
1135 valcontents
= SYMBOL_VALUE (symbol
);
1136 if (BUFFER_LOCAL_VALUEP (valcontents
))
1138 Lisp_Object v
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1139 if (!EQ (v
, XCAR (v
)))
1142 for (it
= XBUFFER_LOCAL_VALUE (valcontents
)->thread_data
;
1143 !NILP (it
); it
= XCDR (it
))
1145 Lisp_Object head
= XCDR (XCAR (it
));
1146 if (EQ (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)),
1147 BLOCAL_BUFFER_VEC (head
))
1148 && (! XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1149 || EQ (selected_frame
, BLOCAL_FRAME_VEC (head
)))
1150 && !EQ (BLOCAL_CDR_VEC (head
),
1151 XCAR (BLOCAL_CDR_VEC (head
))))
1154 = XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1155 Fsetcdr (assq_no_quit (XCAR (XCAR (it
)),
1156 XTHREADLOCAL (rv
)->thread_alist
),
1158 XSETCDR (XCAR (BLOCAL_CDR_VEC (head
), newval
);
1162 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)) = newval
;
1164 else if (THREADLOCALP (valcontents
))
1166 Lisp_Object val
= indirect_variable (XSYMBOL (symbol
))->value
;
1167 val
= ensure_thread_local (&val
);
1168 XSETCDR (val
, newval
);
1171 SET_SYMBOL_VALUE (symbol
, newval
);
1175 /* Set up SYMBOL to refer to its global binding.
1176 This makes it safe to alter the status of other bindings. */
1179 swap_in_global_binding (symbol
)
1182 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1183 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1184 Lisp_Object cdr
= BLOCAL_CDR (blv
);
1186 /* Unload the previously loaded binding. */
1187 Fsetcdr (XCAR (cdr
),
1188 do_symval_forwarding (BLOCAL_REALVALUE (blv
)));
1190 /* Select the global binding in the symbol. */
1192 store_symval_forwarding (symbol
, BLOCAL_REALVALUE (blv
), XCDR (cdr
), NULL
);
1194 /* Indicate that the global binding is set up now. */
1195 BLOCAL_FRAME (blv
) = Qnil
;
1196 BLOCAL_BUFFER (blv
) = Qnil
;
1197 BLOCAL_CLEAR_FLAGS (blv
);
1200 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1201 VALCONTENTS is the contents of its value cell,
1202 which points to a struct Lisp_Buffer_Local_Value.
1204 Return the value forwarded one step past the buffer-local stage.
1205 This could be another forwarding pointer. */
1208 swap_in_symval_forwarding (symbol
, valcontents
)
1209 Lisp_Object symbol
, valcontents
;
1211 register Lisp_Object tem1
;
1213 tem1
= BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1216 || current_buffer
!= XBUFFER (tem1
)
1217 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1218 && ! EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))))
1220 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1221 if (sym
->indirect_variable
)
1223 sym
= indirect_variable (sym
);
1224 XSETSYMBOL (symbol
, sym
);
1227 /* Unload the previously loaded binding. */
1228 tem1
= XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1230 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1232 /* Choose the new binding. */
1233 tem1
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1234 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1237 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1238 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1240 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1242 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1245 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1247 /* Load the new binding. */
1248 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1249 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), current_buffer
);
1250 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1251 store_symval_forwarding (symbol
,
1252 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1256 return BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1260 /* Find the value of a symbol, returning Qunbound if it's not bound.
1261 This is helpful for code which just wants to get a variable's value
1262 if it has one, without signaling an error.
1263 Note that it must not be possible to quit
1264 within this function. Great care is required for this. */
1267 find_symbol_value (symbol
)
1270 register Lisp_Object valcontents
;
1271 register Lisp_Object val
;
1273 CHECK_SYMBOL (symbol
);
1274 valcontents
= SYMBOL_VALUE (symbol
);
1276 if (BUFFER_LOCAL_VALUEP (valcontents
))
1277 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1279 return do_symval_forwarding (valcontents
);
1282 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1283 doc
: /* Return SYMBOL's value. Error if that is void. */)
1289 val
= find_symbol_value (symbol
);
1290 if (!EQ (val
, Qunbound
))
1293 xsignal1 (Qvoid_variable
, symbol
);
1296 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1297 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1299 register Lisp_Object symbol
, newval
;
1301 return set_internal (symbol
, newval
, current_buffer
, 0);
1304 /* Return 1 if SYMBOL currently has a let-binding
1305 which was made in the buffer that is now current. */
1308 let_shadows_buffer_binding_p (symbol
)
1309 struct Lisp_Symbol
*symbol
;
1311 volatile struct specbinding
*p
;
1313 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1315 && CONSP (p
->symbol
))
1317 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1318 if ((symbol
== let_bound_symbol
1319 || (let_bound_symbol
->indirect_variable
1320 && symbol
== indirect_variable (let_bound_symbol
)))
1321 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1325 return p
>= specpdl
;
1328 /* Store the value NEWVAL into SYMBOL.
1329 If buffer-locality is an issue, BUF specifies which buffer to use.
1330 (0 stands for the current buffer.)
1332 If BINDFLAG is zero, then if this symbol is supposed to become
1333 local in every buffer where it is set, then we make it local.
1334 If BINDFLAG is nonzero, we don't do that. */
1337 set_internal (symbol
, newval
, buf
, bindflag
)
1338 register Lisp_Object symbol
, newval
;
1342 int voide
= EQ (newval
, Qunbound
);
1344 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1347 buf
= current_buffer
;
1349 /* If restoring in a dead buffer, do nothing. */
1350 if (NILP (BUF_NAME (buf
)))
1353 CHECK_SYMBOL (symbol
);
1354 if (SYMBOL_CONSTANT_P (symbol
)
1355 && (NILP (Fkeywordp (symbol
))
1356 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1357 xsignal1 (Qsetting_constant
, symbol
);
1359 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1361 if (BUFFER_OBJFWDP (valcontents
))
1363 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1364 int idx
= PER_BUFFER_IDX (offset
);
1367 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1368 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1370 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1372 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1373 if (XSYMBOL (symbol
)->indirect_variable
)
1374 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1376 /* What binding is loaded right now? */
1377 current_alist_element
1378 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1380 /* If the current buffer is not the buffer whose binding is
1381 loaded, or if there may be frame-local bindings and the frame
1382 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1383 the default binding is loaded, the loaded binding may be the
1385 if (!BUFFERP (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1386 || buf
!= XBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1387 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1388 && !EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
))))
1389 /* Also unload a global binding (if the var is local_if_set). */
1390 || (EQ (XCAR (current_alist_element
),
1391 current_alist_element
)))
1393 /* The currently loaded binding is not necessarily valid.
1394 We need to unload it, and choose a new binding. */
1396 /* Write out `realvalue' to the old loaded binding. */
1397 Fsetcdr (current_alist_element
,
1398 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1400 /* Find the new binding. */
1401 tem1
= Fassq (symbol
, BUF_LOCAL_VAR_ALIST (buf
));
1402 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1406 /* This buffer still sees the default value. */
1408 /* If the variable is not local_if_set,
1409 or if this is `let' rather than `set',
1410 make CURRENT-ALIST-ELEMENT point to itself,
1411 indicating that we're seeing the default value.
1412 Likewise if the variable has been let-bound
1413 in the current buffer. */
1414 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1415 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1417 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1419 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1420 tem1
= Fassq (symbol
,
1421 XFRAME (selected_frame
)->param_alist
);
1424 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1426 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1428 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1429 and we're not within a let that was made for this buffer,
1430 create a new buffer-local binding for the variable.
1431 That means, give this buffer a new assoc for a local value
1432 and load that binding. */
1435 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1436 BUF_LOCAL_VAR_ALIST (buf
)
1437 = Fcons (tem1
, BUF_LOCAL_VAR_ALIST (buf
));
1441 /* Record which binding is now loaded. */
1442 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1444 /* Set `buffer' and `frame' slots for the binding now loaded. */
1445 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), buf
);
1446 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1448 innercontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1450 /* Store the new value in the cons-cell. */
1451 XSETCDR (XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
))), newval
);
1454 /* If storing void (making the symbol void), forward only through
1455 buffer-local indicator, not through Lisp_Objfwd, etc. */
1457 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1459 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1464 /* Access or set a buffer-local symbol's default value. */
1466 /* Return the default value of SYMBOL, but don't check for voidness.
1467 Return Qunbound if it is void. */
1470 default_value (symbol
)
1473 register Lisp_Object valcontents
;
1475 CHECK_SYMBOL (symbol
);
1476 valcontents
= SYMBOL_VALUE (symbol
);
1478 /* For a built-in buffer-local variable, get the default value
1479 rather than letting do_symval_forwarding get the current value. */
1480 if (BUFFER_OBJFWDP (valcontents
))
1482 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1483 if (PER_BUFFER_IDX (offset
) != 0)
1484 return PER_BUFFER_DEFAULT (offset
);
1487 /* Handle user-created local variables. */
1488 if (BUFFER_LOCAL_VALUEP (valcontents
))
1490 /* If var is set up for a buffer that lacks a local value for it,
1491 the current value is nominally the default value.
1492 But the `realvalue' slot may be more up to date, since
1493 ordinary setq stores just that slot. So use that. */
1494 Lisp_Object current_alist_element
, alist_element_car
;
1495 current_alist_element
1496 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1497 alist_element_car
= XCAR (current_alist_element
);
1498 if (EQ (alist_element_car
, current_alist_element
))
1499 return do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)));
1501 return XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1503 /* For other variables, get the current value. */
1504 return do_symval_forwarding (valcontents
);
1507 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1508 doc
: /* Return t if SYMBOL has a non-void default value.
1509 This is the value that is seen in buffers that do not have their own values
1510 for this variable. */)
1514 register Lisp_Object value
;
1516 value
= default_value (symbol
);
1517 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1520 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1521 doc
: /* Return SYMBOL's default value.
1522 This is the value that is seen in buffers that do not have their own values
1523 for this variable. The default value is meaningful for variables with
1524 local bindings in certain buffers. */)
1528 register Lisp_Object value
;
1530 value
= default_value (symbol
);
1531 if (!EQ (value
, Qunbound
))
1534 xsignal1 (Qvoid_variable
, symbol
);
1537 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1538 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1539 The default value is seen in buffers that do not have their own values
1540 for this variable. */)
1542 Lisp_Object symbol
, value
;
1544 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1546 CHECK_SYMBOL (symbol
);
1547 valcontents
= SYMBOL_VALUE (symbol
);
1549 /* Handle variables like case-fold-search that have special slots
1550 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1552 if (BUFFER_OBJFWDP (valcontents
))
1554 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1555 int idx
= PER_BUFFER_IDX (offset
);
1557 PER_BUFFER_DEFAULT (offset
) = value
;
1559 /* If this variable is not always local in all buffers,
1560 set it in the buffers that don't nominally have a local value. */
1565 for (b
= all_buffers
; b
; b
= b
->next
)
1566 if (!PER_BUFFER_VALUE_P (b
, idx
))
1567 PER_BUFFER_VALUE (b
, offset
) = value
;
1572 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1573 return Fset (symbol
, value
);
1575 /* Store new value into the DEFAULT-VALUE slot. */
1576 XSETCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), value
);
1578 /* If the default binding is now loaded, set the REALVALUE slot too. */
1579 current_alist_element
1580 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1581 alist_element_buffer
= Fcar (current_alist_element
);
1582 if (EQ (alist_element_buffer
, current_alist_element
))
1583 store_symval_forwarding (symbol
,
1584 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1590 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1591 doc
: /* Set the default value of variable VAR to VALUE.
1592 VAR, the variable name, is literal (not evaluated);
1593 VALUE is an expression: it is evaluated and its value returned.
1594 The default value of a variable is seen in buffers
1595 that do not have their own values for the variable.
1597 More generally, you can use multiple variables and values, as in
1598 (setq-default VAR VALUE VAR VALUE...)
1599 This sets each VAR's default value to the corresponding VALUE.
1600 The VALUE for the Nth VAR can refer to the new default values
1602 usage: (setq-default [VAR VALUE]...) */)
1606 register Lisp_Object args_left
;
1607 register Lisp_Object val
, symbol
;
1608 struct gcpro gcpro1
;
1618 val
= Feval (Fcar (Fcdr (args_left
)));
1619 symbol
= XCAR (args_left
);
1620 Fset_default (symbol
, val
);
1621 args_left
= Fcdr (XCDR (args_left
));
1623 while (!NILP (args_left
));
1629 /* Lisp functions for creating and removing buffer-local variables. */
1631 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1632 1, 1, "vMake Variable Buffer Local: ",
1633 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1634 At any time, the value for the current buffer is in effect,
1635 unless the variable has never been set in this buffer,
1636 in which case the default value is in effect.
1637 Note that binding the variable with `let', or setting it while
1638 a `let'-style binding made in this buffer is in effect,
1639 does not make the variable buffer-local. Return VARIABLE.
1641 In most cases it is better to use `make-local-variable',
1642 which makes a variable local in just one buffer.
1644 The function `default-value' gets the default value and `set-default' sets it. */)
1646 register Lisp_Object variable
;
1648 register Lisp_Object tem
, valcontents
, newval
;
1649 struct Lisp_Symbol
*sym
;
1651 CHECK_SYMBOL (variable
);
1652 sym
= indirect_variable (XSYMBOL (variable
));
1654 valcontents
= sym
->value
;
1655 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1656 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1658 if (BUFFER_OBJFWDP (valcontents
))
1660 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1662 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1663 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1664 newval
= valcontents
;
1668 Lisp_Object len
, val_vec
;
1669 XSETFASTINT (len
, 4);
1670 val_vec
= Fmake_vector (len
, Qnil
);
1671 if (EQ (valcontents
, Qunbound
))
1673 tem
= Fcons (Qnil
, valcontents
);
1675 newval
= allocate_misc ();
1676 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1677 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1678 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1679 BLOCAL_BUFFER_VEC (val_vec
) = Fcurrent_buffer ();
1680 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1681 BLOCAL_CDR_VEC (val_vec
) = tem
;
1682 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1683 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1684 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1685 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1686 = Lisp_Misc_ThreadLocal
;
1687 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1689 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1690 = Fcons (Fcons (get_current_thread (), valcontents
), Qnil
);
1691 sym
->value
= newval
;
1693 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1697 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1698 1, 1, "vMake Local Variable: ",
1699 doc
: /* Make VARIABLE have a separate value in the current buffer.
1700 Other buffers will continue to share a common default value.
1701 \(The buffer-local value of VARIABLE starts out as the same value
1702 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1705 If the variable is already arranged to become local when set,
1706 this function causes a local value to exist for this buffer,
1707 just as setting the variable would do.
1709 This function returns VARIABLE, and therefore
1710 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1713 See also `make-variable-buffer-local'.
1715 Do not use `make-local-variable' to make a hook variable buffer-local.
1716 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1718 register Lisp_Object variable
;
1720 register Lisp_Object tem
, valcontents
;
1721 struct Lisp_Symbol
*sym
;
1723 CHECK_SYMBOL (variable
);
1724 sym
= indirect_variable (XSYMBOL (variable
));
1726 valcontents
= sym
->value
;
1727 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1728 || (BUFFER_LOCAL_VALUEP (valcontents
)
1729 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1730 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1732 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1733 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1734 || BUFFER_OBJFWDP (valcontents
))
1736 tem
= Fboundp (variable
);
1738 /* Make sure the symbol has a local value in this particular buffer,
1739 by setting it to the same value it already has. */
1740 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1743 /* Make sure symbol is set up to hold per-buffer values. */
1744 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1746 Lisp_Object newval
, len
, val_vec
;
1747 XSETFASTINT (len
, 4);
1748 val_vec
= Fmake_vector (len
, Qnil
);
1749 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1751 newval
= allocate_misc ();
1752 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1753 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1754 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1755 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1756 BLOCAL_CDR_VEC (val_vec
) = tem
;
1757 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1758 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1759 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1760 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1761 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1762 = Lisp_Misc_ThreadLocal
;
1763 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
= Qnil
;
1764 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1765 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1766 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1767 sym
->value
= newval
;
1769 /* Make sure this buffer has its own value of symbol. */
1770 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1771 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1774 /* Swap out any local binding for some other buffer, and make
1775 sure the current value is permanently recorded, if it's the
1777 find_symbol_value (variable
);
1779 BUF_LOCAL_VAR_ALIST (current_buffer
)
1780 = Fcons (Fcons (variable
, XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (sym
->value
)))),
1781 BUF_LOCAL_VAR_ALIST (current_buffer
));
1783 /* Make sure symbol does not think it is set up for this buffer;
1784 force it to look once again for this buffer's value. */
1786 Lisp_Object
*pvalbuf
;
1788 valcontents
= sym
->value
;
1790 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1791 if (current_buffer
== XBUFFER (*pvalbuf
))
1793 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1797 /* If the symbol forwards into a C variable, then load the binding
1798 for this buffer now. If C code modifies the variable before we
1799 load the binding in, then that new value will clobber the default
1800 binding the next time we unload it. */
1801 valcontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (sym
->value
));
1802 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1803 swap_in_symval_forwarding (variable
, sym
->value
);
1808 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1809 1, 1, "vKill Local Variable: ",
1810 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1811 From now on the default value will apply in this buffer. Return VARIABLE. */)
1813 register Lisp_Object variable
;
1815 register Lisp_Object tem
, valcontents
;
1816 struct Lisp_Symbol
*sym
;
1818 CHECK_SYMBOL (variable
);
1819 sym
= indirect_variable (XSYMBOL (variable
));
1821 valcontents
= sym
->value
;
1823 if (BUFFER_OBJFWDP (valcontents
))
1825 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1826 int idx
= PER_BUFFER_IDX (offset
);
1830 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1831 PER_BUFFER_VALUE (current_buffer
, offset
)
1832 = PER_BUFFER_DEFAULT (offset
);
1837 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1840 /* Get rid of this buffer's alist element, if any. */
1841 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1842 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1844 BUF_LOCAL_VAR_ALIST (current_buffer
)
1845 = Fdelq (tem
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1847 /* If the symbol is set up with the current buffer's binding
1848 loaded, recompute its value. We have to do it now, or else
1849 forwarded objects won't work right. */
1851 Lisp_Object
*pvalbuf
, buf
;
1852 valcontents
= sym
->value
;
1853 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1854 XSETBUFFER (buf
, current_buffer
);
1855 if (EQ (buf
, *pvalbuf
))
1858 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1859 find_symbol_value (variable
);
1866 /* Lisp functions for creating and removing buffer-local variables. */
1868 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1869 when/if this is removed. */
1871 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1872 1, 1, "vMake Variable Frame Local: ",
1873 doc
: /* Enable VARIABLE to have frame-local bindings.
1874 This does not create any frame-local bindings for VARIABLE,
1875 it just makes them possible.
1877 A frame-local binding is actually a frame parameter value.
1878 If a frame F has a value for the frame parameter named VARIABLE,
1879 that also acts as a frame-local binding for VARIABLE in F--
1880 provided this function has been called to enable VARIABLE
1881 to have frame-local bindings at all.
1883 The only way to create a frame-local binding for VARIABLE in a frame
1884 is to set the VARIABLE frame parameter of that frame. See
1885 `modify-frame-parameters' for how to set frame parameters.
1887 Note that since Emacs 23.1, variables cannot be both buffer-local and
1888 frame-local any more (buffer-local bindings used to take precedence over
1889 frame-local bindings). */)
1891 register Lisp_Object variable
;
1893 register Lisp_Object tem
, valcontents
, newval
, val_vec
, len
;
1894 struct Lisp_Symbol
*sym
;
1896 CHECK_SYMBOL (variable
);
1897 sym
= indirect_variable (XSYMBOL (variable
));
1899 valcontents
= sym
->value
;
1900 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1901 || BUFFER_OBJFWDP (valcontents
))
1902 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1904 if (BUFFER_LOCAL_VALUEP (valcontents
))
1906 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1907 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1911 if (EQ (valcontents
, Qunbound
))
1913 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1915 newval
= allocate_misc ();
1916 XSETFASTINT (len
, 4);
1917 val_vec
= Fmake_vector (len
, Qnil
);
1918 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1919 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1920 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1921 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1922 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1923 BLOCAL_CDR_VEC (val_vec
) = tem
;
1924 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1925 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1926 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1927 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1928 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1929 = Lisp_Misc_ThreadLocal
;
1930 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
= Qnil
;
1931 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1932 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1933 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1934 sym
->value
= newval
;
1938 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1940 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1941 BUFFER defaults to the current buffer. */)
1943 register Lisp_Object variable
, buffer
;
1945 Lisp_Object valcontents
;
1946 register struct buffer
*buf
;
1947 struct Lisp_Symbol
*sym
;
1950 buf
= current_buffer
;
1953 CHECK_BUFFER (buffer
);
1954 buf
= XBUFFER (buffer
);
1957 CHECK_SYMBOL (variable
);
1958 sym
= indirect_variable (XSYMBOL (variable
));
1959 XSETSYMBOL (variable
, sym
);
1961 valcontents
= sym
->value
;
1962 if (BUFFER_LOCAL_VALUEP (valcontents
))
1964 Lisp_Object tail
, elt
;
1966 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
1969 if (EQ (variable
, XCAR (elt
)))
1973 if (BUFFER_OBJFWDP (valcontents
))
1975 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1976 int idx
= PER_BUFFER_IDX (offset
);
1977 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1983 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1985 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1986 More precisely, this means that setting the variable \(with `set' or`setq'),
1987 while it does not have a `let'-style binding that was made in BUFFER,
1988 will produce a buffer local binding. See Info node
1989 `(elisp)Creating Buffer-Local'.
1990 BUFFER defaults to the current buffer. */)
1992 register Lisp_Object variable
, buffer
;
1994 Lisp_Object valcontents
;
1995 register struct buffer
*buf
;
1996 struct Lisp_Symbol
*sym
;
1999 buf
= current_buffer
;
2002 CHECK_BUFFER (buffer
);
2003 buf
= XBUFFER (buffer
);
2006 CHECK_SYMBOL (variable
);
2007 sym
= indirect_variable (XSYMBOL (variable
));
2008 XSETSYMBOL (variable
, sym
);
2010 valcontents
= sym
->value
;
2012 if (BUFFER_OBJFWDP (valcontents
))
2013 /* All these slots become local if they are set. */
2015 else if (BUFFER_LOCAL_VALUEP (valcontents
))
2017 Lisp_Object tail
, elt
;
2018 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
2020 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2023 if (EQ (variable
, XCAR (elt
)))
2030 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2032 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2033 If the current binding is buffer-local, the value is the current buffer.
2034 If the current binding is frame-local, the value is the selected frame.
2035 If the current binding is global (the default), the value is nil. */)
2037 register Lisp_Object variable
;
2039 Lisp_Object valcontents
;
2040 struct Lisp_Symbol
*sym
;
2042 CHECK_SYMBOL (variable
);
2043 sym
= indirect_variable (XSYMBOL (variable
));
2045 /* Make sure the current binding is actually swapped in. */
2046 find_symbol_value (variable
);
2048 valcontents
= sym
->value
;
2050 if (BUFFER_LOCAL_VALUEP (valcontents
)
2051 || BUFFER_OBJFWDP (valcontents
))
2053 /* For a local variable, record both the symbol and which
2054 buffer's or frame's value we are saving. */
2055 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2056 return Fcurrent_buffer ();
2057 else if (BUFFER_LOCAL_VALUEP (valcontents
)
2058 && BLOCAL_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))
2059 return BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
2065 /* This code is disabled now that we use the selected frame to return
2066 keyboard-local-values. */
2068 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2070 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2071 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2072 If SYMBOL is not a terminal-local variable, then return its normal
2073 value, like `symbol-value'.
2075 TERMINAL may be a terminal object, a frame, or nil (meaning the
2076 selected frame's terminal device). */)
2079 Lisp_Object terminal
;
2082 struct terminal
*t
= get_terminal (terminal
, 1);
2083 push_kboard (t
->kboard
);
2084 result
= Fsymbol_value (symbol
);
2089 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2090 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2091 If VARIABLE is not a terminal-local variable, then set its normal
2092 binding, like `set'.
2094 TERMINAL may be a terminal object, a frame, or nil (meaning the
2095 selected frame's terminal device). */)
2096 (symbol
, terminal
, value
)
2098 Lisp_Object terminal
;
2102 struct terminal
*t
= get_terminal (terminal
, 1);
2103 push_kboard (d
->kboard
);
2104 result
= Fset (symbol
, value
);
2110 /* Find the function at the end of a chain of symbol function indirections. */
2112 /* If OBJECT is a symbol, find the end of its function chain and
2113 return the value found there. If OBJECT is not a symbol, just
2114 return it. If there is a cycle in the function chain, signal a
2115 cyclic-function-indirection error.
2117 This is like Findirect_function, except that it doesn't signal an
2118 error if the chain ends up unbound. */
2120 indirect_function (object
)
2121 register Lisp_Object object
;
2123 Lisp_Object tortoise
, hare
;
2125 hare
= tortoise
= object
;
2129 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2131 hare
= XSYMBOL (hare
)->function
;
2132 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2134 hare
= XSYMBOL (hare
)->function
;
2136 tortoise
= XSYMBOL (tortoise
)->function
;
2138 if (EQ (hare
, tortoise
))
2139 xsignal1 (Qcyclic_function_indirection
, object
);
2145 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2146 doc
: /* Return the function at the end of OBJECT's function chain.
2147 If OBJECT is not a symbol, just return it. Otherwise, follow all
2148 function indirections to find the final function binding and return it.
2149 If the final symbol in the chain is unbound, signal a void-function error.
2150 Optional arg NOERROR non-nil means to return nil instead of signalling.
2151 Signal a cyclic-function-indirection error if there is a loop in the
2152 function chain of symbols. */)
2154 register Lisp_Object object
;
2155 Lisp_Object noerror
;
2159 /* Optimize for no indirection. */
2161 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2162 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2163 result
= indirect_function (result
);
2164 if (!EQ (result
, Qunbound
))
2168 xsignal1 (Qvoid_function
, object
);
2173 /* Extract and set vector and string elements */
2175 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2176 doc
: /* Return the element of ARRAY at index IDX.
2177 ARRAY may be a vector, a string, a char-table, a bool-vector,
2178 or a byte-code object. IDX starts at 0. */)
2180 register Lisp_Object array
;
2183 register int idxval
;
2186 idxval
= XINT (idx
);
2187 if (STRINGP (array
))
2191 if (idxval
< 0 || idxval
>= SCHARS (array
))
2192 args_out_of_range (array
, idx
);
2193 if (! STRING_MULTIBYTE (array
))
2194 return make_number ((unsigned char) SREF (array
, idxval
));
2195 idxval_byte
= string_char_to_byte (array
, idxval
);
2197 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2198 return make_number (c
);
2200 else if (BOOL_VECTOR_P (array
))
2204 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2205 args_out_of_range (array
, idx
);
2207 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2208 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2210 else if (CHAR_TABLE_P (array
))
2212 CHECK_CHARACTER (idx
);
2213 return CHAR_TABLE_REF (array
, idxval
);
2218 if (VECTORP (array
))
2219 size
= XVECTOR (array
)->size
;
2220 else if (COMPILEDP (array
))
2221 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2223 wrong_type_argument (Qarrayp
, array
);
2225 if (idxval
< 0 || idxval
>= size
)
2226 args_out_of_range (array
, idx
);
2227 return XVECTOR (array
)->contents
[idxval
];
2231 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2232 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2233 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2234 bool-vector. IDX starts at 0. */)
2235 (array
, idx
, newelt
)
2236 register Lisp_Object array
;
2237 Lisp_Object idx
, newelt
;
2239 register int idxval
;
2242 idxval
= XINT (idx
);
2243 CHECK_ARRAY (array
, Qarrayp
);
2244 CHECK_IMPURE (array
);
2246 if (VECTORP (array
))
2248 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2249 args_out_of_range (array
, idx
);
2250 XVECTOR (array
)->contents
[idxval
] = newelt
;
2252 else if (BOOL_VECTOR_P (array
))
2256 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2257 args_out_of_range (array
, idx
);
2259 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2261 if (! NILP (newelt
))
2262 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2264 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2265 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2267 else if (CHAR_TABLE_P (array
))
2269 CHECK_CHARACTER (idx
);
2270 CHAR_TABLE_SET (array
, idxval
, newelt
);
2272 else if (STRING_MULTIBYTE (array
))
2274 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2275 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2277 if (idxval
< 0 || idxval
>= SCHARS (array
))
2278 args_out_of_range (array
, idx
);
2279 CHECK_CHARACTER (newelt
);
2281 nbytes
= SBYTES (array
);
2283 idxval_byte
= string_char_to_byte (array
, idxval
);
2284 p1
= SDATA (array
) + idxval_byte
;
2285 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2286 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2287 if (prev_bytes
!= new_bytes
)
2289 /* We must relocate the string data. */
2290 int nchars
= SCHARS (array
);
2294 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2295 bcopy (SDATA (array
), str
, nbytes
);
2296 allocate_string_data (XSTRING (array
), nchars
,
2297 nbytes
+ new_bytes
- prev_bytes
);
2298 bcopy (str
, SDATA (array
), idxval_byte
);
2299 p1
= SDATA (array
) + idxval_byte
;
2300 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2301 nbytes
- (idxval_byte
+ prev_bytes
));
2303 clear_string_char_byte_cache ();
2310 if (idxval
< 0 || idxval
>= SCHARS (array
))
2311 args_out_of_range (array
, idx
);
2312 CHECK_NUMBER (newelt
);
2314 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2318 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2319 if (SREF (array
, i
) >= 0x80)
2320 args_out_of_range (array
, newelt
);
2321 /* ARRAY is an ASCII string. Convert it to a multibyte
2322 string, and try `aset' again. */
2323 STRING_SET_MULTIBYTE (array
);
2324 return Faset (array
, idx
, newelt
);
2326 SSET (array
, idxval
, XINT (newelt
));
2332 /* Arithmetic functions */
2334 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2337 arithcompare (num1
, num2
, comparison
)
2338 Lisp_Object num1
, num2
;
2339 enum comparison comparison
;
2341 double f1
= 0, f2
= 0;
2344 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2345 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2347 if (FLOATP (num1
) || FLOATP (num2
))
2350 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2351 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2357 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2362 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2367 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2372 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2377 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2382 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2391 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2392 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2394 register Lisp_Object num1
, num2
;
2396 return arithcompare (num1
, num2
, equal
);
2399 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2400 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2402 register Lisp_Object num1
, num2
;
2404 return arithcompare (num1
, num2
, less
);
2407 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2408 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2410 register Lisp_Object num1
, num2
;
2412 return arithcompare (num1
, num2
, grtr
);
2415 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2416 doc
: /* Return t if first arg is less than or equal to second arg.
2417 Both must be numbers or markers. */)
2419 register Lisp_Object num1
, num2
;
2421 return arithcompare (num1
, num2
, less_or_equal
);
2424 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2425 doc
: /* Return t if first arg is greater than or equal to second arg.
2426 Both must be numbers or markers. */)
2428 register Lisp_Object num1
, num2
;
2430 return arithcompare (num1
, num2
, grtr_or_equal
);
2433 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2434 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2436 register Lisp_Object num1
, num2
;
2438 return arithcompare (num1
, num2
, notequal
);
2441 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2442 doc
: /* Return t if NUMBER is zero. */)
2444 register Lisp_Object number
;
2446 CHECK_NUMBER_OR_FLOAT (number
);
2448 if (FLOATP (number
))
2450 if (XFLOAT_DATA (number
) == 0.0)
2460 /* Convert between long values and pairs of Lisp integers.
2461 Note that long_to_cons returns a single Lisp integer
2462 when the value fits in one. */
2468 unsigned long top
= i
>> 16;
2469 unsigned int bot
= i
& 0xFFFF;
2471 return make_number (bot
);
2472 if (top
== (unsigned long)-1 >> 16)
2473 return Fcons (make_number (-1), make_number (bot
));
2474 return Fcons (make_number (top
), make_number (bot
));
2481 Lisp_Object top
, bot
;
2488 return ((XINT (top
) << 16) | XINT (bot
));
2491 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2492 doc
: /* Return the decimal representation of NUMBER as a string.
2493 Uses a minus sign if negative.
2494 NUMBER may be an integer or a floating point number. */)
2498 char buffer
[VALBITS
];
2500 CHECK_NUMBER_OR_FLOAT (number
);
2502 if (FLOATP (number
))
2504 char pigbuf
[350]; /* see comments in float_to_string */
2506 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2507 return build_string (pigbuf
);
2510 if (sizeof (int) == sizeof (EMACS_INT
))
2511 sprintf (buffer
, "%d", (int) XINT (number
));
2512 else if (sizeof (long) == sizeof (EMACS_INT
))
2513 sprintf (buffer
, "%ld", (long) XINT (number
));
2516 return build_string (buffer
);
2520 digit_to_number (character
, base
)
2521 int character
, base
;
2525 if (character
>= '0' && character
<= '9')
2526 digit
= character
- '0';
2527 else if (character
>= 'a' && character
<= 'z')
2528 digit
= character
- 'a' + 10;
2529 else if (character
>= 'A' && character
<= 'Z')
2530 digit
= character
- 'A' + 10;
2540 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2541 doc
: /* Parse STRING as a decimal number and return the number.
2542 This parses both integers and floating point numbers.
2543 It ignores leading spaces and tabs, and all trailing chars.
2545 If BASE, interpret STRING as a number in that base. If BASE isn't
2546 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2547 If the base used is not 10, STRING is always parsed as integer. */)
2549 register Lisp_Object string
, base
;
2551 register unsigned char *p
;
2556 CHECK_STRING (string
);
2562 CHECK_NUMBER (base
);
2564 if (b
< 2 || b
> 16)
2565 xsignal1 (Qargs_out_of_range
, base
);
2568 /* Skip any whitespace at the front of the number. Some versions of
2569 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2571 while (*p
== ' ' || *p
== '\t')
2582 if (isfloat_string (p
, 1) && b
== 10)
2583 val
= make_float (sign
* atof (p
));
2590 int digit
= digit_to_number (*p
++, b
);
2596 val
= make_fixnum_or_float (sign
* v
);
2616 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2617 int, Lisp_Object
*));
2618 extern Lisp_Object
fmod_float ();
2621 arith_driver (code
, nargs
, args
)
2624 register Lisp_Object
*args
;
2626 register Lisp_Object val
;
2627 register int argnum
;
2628 register EMACS_INT accum
= 0;
2629 register EMACS_INT next
;
2631 switch (SWITCH_ENUM_CAST (code
))
2649 for (argnum
= 0; argnum
< nargs
; argnum
++)
2651 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2653 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2656 return float_arith_driver ((double) accum
, argnum
, code
,
2659 next
= XINT (args
[argnum
]);
2660 switch (SWITCH_ENUM_CAST (code
))
2666 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2677 xsignal0 (Qarith_error
);
2691 if (!argnum
|| next
> accum
)
2695 if (!argnum
|| next
< accum
)
2701 XSETINT (val
, accum
);
2706 #define isnan(x) ((x) != (x))
2709 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2711 register int argnum
;
2714 register Lisp_Object
*args
;
2716 register Lisp_Object val
;
2719 for (; argnum
< nargs
; argnum
++)
2721 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2722 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2726 next
= XFLOAT_DATA (val
);
2730 args
[argnum
] = val
; /* runs into a compiler bug. */
2731 next
= XINT (args
[argnum
]);
2733 switch (SWITCH_ENUM_CAST (code
))
2739 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2749 if (! IEEE_FLOATING_POINT
&& next
== 0)
2750 xsignal0 (Qarith_error
);
2757 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2759 if (!argnum
|| isnan (next
) || next
> accum
)
2763 if (!argnum
|| isnan (next
) || next
< accum
)
2769 return make_float (accum
);
2773 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2774 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2775 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2780 return arith_driver (Aadd
, nargs
, args
);
2783 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2784 doc
: /* Negate number or subtract numbers or markers and return the result.
2785 With one arg, negates it. With more than one arg,
2786 subtracts all but the first from the first.
2787 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2792 return arith_driver (Asub
, nargs
, args
);
2795 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2796 doc
: /* Return product of any number of arguments, which are numbers or markers.
2797 usage: (* &rest NUMBERS-OR-MARKERS) */)
2802 return arith_driver (Amult
, nargs
, args
);
2805 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2806 doc
: /* Return first argument divided by all the remaining arguments.
2807 The arguments must be numbers or markers.
2808 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2814 for (argnum
= 2; argnum
< nargs
; argnum
++)
2815 if (FLOATP (args
[argnum
]))
2816 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2817 return arith_driver (Adiv
, nargs
, args
);
2820 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2821 doc
: /* Return remainder of X divided by Y.
2822 Both must be integers or markers. */)
2824 register Lisp_Object x
, y
;
2828 CHECK_NUMBER_COERCE_MARKER (x
);
2829 CHECK_NUMBER_COERCE_MARKER (y
);
2831 if (XFASTINT (y
) == 0)
2832 xsignal0 (Qarith_error
);
2834 XSETINT (val
, XINT (x
) % XINT (y
));
2848 /* If the magnitude of the result exceeds that of the divisor, or
2849 the sign of the result does not agree with that of the dividend,
2850 iterate with the reduced value. This does not yield a
2851 particularly accurate result, but at least it will be in the
2852 range promised by fmod. */
2854 r
-= f2
* floor (r
/ f2
);
2855 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2859 #endif /* ! HAVE_FMOD */
2861 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2862 doc
: /* Return X modulo Y.
2863 The result falls between zero (inclusive) and Y (exclusive).
2864 Both X and Y must be numbers or markers. */)
2866 register Lisp_Object x
, y
;
2871 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2872 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2874 if (FLOATP (x
) || FLOATP (y
))
2875 return fmod_float (x
, y
);
2881 xsignal0 (Qarith_error
);
2885 /* If the "remainder" comes out with the wrong sign, fix it. */
2886 if (i2
< 0 ? i1
> 0 : i1
< 0)
2893 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2894 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2895 The value is always a number; markers are converted to numbers.
2896 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2901 return arith_driver (Amax
, nargs
, args
);
2904 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2905 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2906 The value is always a number; markers are converted to numbers.
2907 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2912 return arith_driver (Amin
, nargs
, args
);
2915 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2916 doc
: /* Return bitwise-and of all the arguments.
2917 Arguments may be integers, or markers converted to integers.
2918 usage: (logand &rest INTS-OR-MARKERS) */)
2923 return arith_driver (Alogand
, nargs
, args
);
2926 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2927 doc
: /* Return bitwise-or of all the arguments.
2928 Arguments may be integers, or markers converted to integers.
2929 usage: (logior &rest INTS-OR-MARKERS) */)
2934 return arith_driver (Alogior
, nargs
, args
);
2937 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2938 doc
: /* Return bitwise-exclusive-or of all the arguments.
2939 Arguments may be integers, or markers converted to integers.
2940 usage: (logxor &rest INTS-OR-MARKERS) */)
2945 return arith_driver (Alogxor
, nargs
, args
);
2948 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2949 doc
: /* Return VALUE with its bits shifted left by COUNT.
2950 If COUNT is negative, shifting is actually to the right.
2951 In this case, the sign bit is duplicated. */)
2953 register Lisp_Object value
, count
;
2955 register Lisp_Object val
;
2957 CHECK_NUMBER (value
);
2958 CHECK_NUMBER (count
);
2960 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2962 else if (XINT (count
) > 0)
2963 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2964 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2965 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2967 XSETINT (val
, XINT (value
) >> -XINT (count
));
2971 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2972 doc
: /* Return VALUE with its bits shifted left by COUNT.
2973 If COUNT is negative, shifting is actually to the right.
2974 In this case, zeros are shifted in on the left. */)
2976 register Lisp_Object value
, count
;
2978 register Lisp_Object val
;
2980 CHECK_NUMBER (value
);
2981 CHECK_NUMBER (count
);
2983 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2985 else if (XINT (count
) > 0)
2986 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2987 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2990 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2994 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2995 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2996 Markers are converted to integers. */)
2998 register Lisp_Object number
;
3000 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3002 if (FLOATP (number
))
3003 return (make_float (1.0 + XFLOAT_DATA (number
)));
3005 XSETINT (number
, XINT (number
) + 1);
3009 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3010 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3011 Markers are converted to integers. */)
3013 register Lisp_Object number
;
3015 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3017 if (FLOATP (number
))
3018 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3020 XSETINT (number
, XINT (number
) - 1);
3024 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3025 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3027 register Lisp_Object number
;
3029 CHECK_NUMBER (number
);
3030 XSETINT (number
, ~XINT (number
));
3034 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3035 doc
: /* Return the byteorder for the machine.
3036 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3037 lowercase l) for small endian machines. */)
3040 unsigned i
= 0x04030201;
3041 int order
= *(char *)&i
== 1 ? 108 : 66;
3043 return make_number (order
);
3051 Lisp_Object error_tail
, arith_tail
;
3053 Qquote
= intern_c_string ("quote");
3054 Qlambda
= intern_c_string ("lambda");
3055 Qsubr
= intern_c_string ("subr");
3056 Qerror_conditions
= intern_c_string ("error-conditions");
3057 Qerror_message
= intern_c_string ("error-message");
3058 Qtop_level
= intern_c_string ("top-level");
3060 Qerror
= intern_c_string ("error");
3061 Qquit
= intern_c_string ("quit");
3062 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3063 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3064 Qvoid_function
= intern_c_string ("void-function");
3065 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3066 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3067 Qvoid_variable
= intern_c_string ("void-variable");
3068 Qsetting_constant
= intern_c_string ("setting-constant");
3069 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3071 Qinvalid_function
= intern_c_string ("invalid-function");
3072 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3073 Qno_catch
= intern_c_string ("no-catch");
3074 Qend_of_file
= intern_c_string ("end-of-file");
3075 Qarith_error
= intern_c_string ("arith-error");
3076 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3077 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3078 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3079 Qtext_read_only
= intern_c_string ("text-read-only");
3080 Qmark_inactive
= intern_c_string ("mark-inactive");
3082 Qlistp
= intern_c_string ("listp");
3083 Qconsp
= intern_c_string ("consp");
3084 Qsymbolp
= intern_c_string ("symbolp");
3085 Qkeywordp
= intern_c_string ("keywordp");
3086 Qintegerp
= intern_c_string ("integerp");
3087 Qnatnump
= intern_c_string ("natnump");
3088 Qwholenump
= intern_c_string ("wholenump");
3089 Qstringp
= intern_c_string ("stringp");
3090 Qarrayp
= intern_c_string ("arrayp");
3091 Qsequencep
= intern_c_string ("sequencep");
3092 Qbufferp
= intern_c_string ("bufferp");
3093 Qvectorp
= intern_c_string ("vectorp");
3094 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3095 Qmarkerp
= intern_c_string ("markerp");
3096 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3097 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3098 Qboundp
= intern_c_string ("boundp");
3099 Qfboundp
= intern_c_string ("fboundp");
3101 Qfloatp
= intern_c_string ("floatp");
3102 Qnumberp
= intern_c_string ("numberp");
3103 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3105 Qchar_table_p
= intern_c_string ("char-table-p");
3106 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3108 Qsubrp
= intern_c_string ("subrp");
3109 Qunevalled
= intern_c_string ("unevalled");
3110 Qmany
= intern_c_string ("many");
3112 Qcdr
= intern_c_string ("cdr");
3114 /* Handle automatic advice activation */
3115 Qad_advice_info
= intern_c_string ("ad-advice-info");
3116 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3118 error_tail
= pure_cons (Qerror
, Qnil
);
3120 /* ERROR is used as a signaler for random errors for which nothing else is right */
3122 Fput (Qerror
, Qerror_conditions
,
3124 Fput (Qerror
, Qerror_message
,
3125 make_pure_c_string ("error"));
3127 Fput (Qquit
, Qerror_conditions
,
3128 pure_cons (Qquit
, Qnil
));
3129 Fput (Qquit
, Qerror_message
,
3130 make_pure_c_string ("Quit"));
3132 Fput (Qwrong_type_argument
, Qerror_conditions
,
3133 pure_cons (Qwrong_type_argument
, error_tail
));
3134 Fput (Qwrong_type_argument
, Qerror_message
,
3135 make_pure_c_string ("Wrong type argument"));
3137 Fput (Qargs_out_of_range
, Qerror_conditions
,
3138 pure_cons (Qargs_out_of_range
, error_tail
));
3139 Fput (Qargs_out_of_range
, Qerror_message
,
3140 make_pure_c_string ("Args out of range"));
3142 Fput (Qvoid_function
, Qerror_conditions
,
3143 pure_cons (Qvoid_function
, error_tail
));
3144 Fput (Qvoid_function
, Qerror_message
,
3145 make_pure_c_string ("Symbol's function definition is void"));
3147 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3148 pure_cons (Qcyclic_function_indirection
, error_tail
));
3149 Fput (Qcyclic_function_indirection
, Qerror_message
,
3150 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3152 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3153 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3154 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3155 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3157 Qcircular_list
= intern_c_string ("circular-list");
3158 staticpro (&Qcircular_list
);
3159 Fput (Qcircular_list
, Qerror_conditions
,
3160 pure_cons (Qcircular_list
, error_tail
));
3161 Fput (Qcircular_list
, Qerror_message
,
3162 make_pure_c_string ("List contains a loop"));
3164 Fput (Qvoid_variable
, Qerror_conditions
,
3165 pure_cons (Qvoid_variable
, error_tail
));
3166 Fput (Qvoid_variable
, Qerror_message
,
3167 make_pure_c_string ("Symbol's value as variable is void"));
3169 Fput (Qsetting_constant
, Qerror_conditions
,
3170 pure_cons (Qsetting_constant
, error_tail
));
3171 Fput (Qsetting_constant
, Qerror_message
,
3172 make_pure_c_string ("Attempt to set a constant symbol"));
3174 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3175 pure_cons (Qinvalid_read_syntax
, error_tail
));
3176 Fput (Qinvalid_read_syntax
, Qerror_message
,
3177 make_pure_c_string ("Invalid read syntax"));
3179 Fput (Qinvalid_function
, Qerror_conditions
,
3180 pure_cons (Qinvalid_function
, error_tail
));
3181 Fput (Qinvalid_function
, Qerror_message
,
3182 make_pure_c_string ("Invalid function"));
3184 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3185 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3186 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3187 make_pure_c_string ("Wrong number of arguments"));
3189 Fput (Qno_catch
, Qerror_conditions
,
3190 pure_cons (Qno_catch
, error_tail
));
3191 Fput (Qno_catch
, Qerror_message
,
3192 make_pure_c_string ("No catch for tag"));
3194 Fput (Qend_of_file
, Qerror_conditions
,
3195 pure_cons (Qend_of_file
, error_tail
));
3196 Fput (Qend_of_file
, Qerror_message
,
3197 make_pure_c_string ("End of file during parsing"));
3199 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3200 Fput (Qarith_error
, Qerror_conditions
,
3202 Fput (Qarith_error
, Qerror_message
,
3203 make_pure_c_string ("Arithmetic error"));
3205 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3206 pure_cons (Qbeginning_of_buffer
, error_tail
));
3207 Fput (Qbeginning_of_buffer
, Qerror_message
,
3208 make_pure_c_string ("Beginning of buffer"));
3210 Fput (Qend_of_buffer
, Qerror_conditions
,
3211 pure_cons (Qend_of_buffer
, error_tail
));
3212 Fput (Qend_of_buffer
, Qerror_message
,
3213 make_pure_c_string ("End of buffer"));
3215 Fput (Qbuffer_read_only
, Qerror_conditions
,
3216 pure_cons (Qbuffer_read_only
, error_tail
));
3217 Fput (Qbuffer_read_only
, Qerror_message
,
3218 make_pure_c_string ("Buffer is read-only"));
3220 Fput (Qtext_read_only
, Qerror_conditions
,
3221 pure_cons (Qtext_read_only
, error_tail
));
3222 Fput (Qtext_read_only
, Qerror_message
,
3223 make_pure_c_string ("Text is read-only"));
3225 Qrange_error
= intern_c_string ("range-error");
3226 Qdomain_error
= intern_c_string ("domain-error");
3227 Qsingularity_error
= intern_c_string ("singularity-error");
3228 Qoverflow_error
= intern_c_string ("overflow-error");
3229 Qunderflow_error
= intern_c_string ("underflow-error");
3231 Fput (Qdomain_error
, Qerror_conditions
,
3232 pure_cons (Qdomain_error
, arith_tail
));
3233 Fput (Qdomain_error
, Qerror_message
,
3234 make_pure_c_string ("Arithmetic domain error"));
3236 Fput (Qrange_error
, Qerror_conditions
,
3237 pure_cons (Qrange_error
, arith_tail
));
3238 Fput (Qrange_error
, Qerror_message
,
3239 make_pure_c_string ("Arithmetic range error"));
3241 Fput (Qsingularity_error
, Qerror_conditions
,
3242 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3243 Fput (Qsingularity_error
, Qerror_message
,
3244 make_pure_c_string ("Arithmetic singularity error"));
3246 Fput (Qoverflow_error
, Qerror_conditions
,
3247 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3248 Fput (Qoverflow_error
, Qerror_message
,
3249 make_pure_c_string ("Arithmetic overflow error"));
3251 Fput (Qunderflow_error
, Qerror_conditions
,
3252 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3253 Fput (Qunderflow_error
, Qerror_message
,
3254 make_pure_c_string ("Arithmetic underflow error"));
3256 staticpro (&Qrange_error
);
3257 staticpro (&Qdomain_error
);
3258 staticpro (&Qsingularity_error
);
3259 staticpro (&Qoverflow_error
);
3260 staticpro (&Qunderflow_error
);
3264 staticpro (&Qquote
);
3265 staticpro (&Qlambda
);
3267 staticpro (&Qunbound
);
3268 staticpro (&Qerror_conditions
);
3269 staticpro (&Qerror_message
);
3270 staticpro (&Qtop_level
);
3272 staticpro (&Qerror
);
3274 staticpro (&Qwrong_type_argument
);
3275 staticpro (&Qargs_out_of_range
);
3276 staticpro (&Qvoid_function
);
3277 staticpro (&Qcyclic_function_indirection
);
3278 staticpro (&Qcyclic_variable_indirection
);
3279 staticpro (&Qvoid_variable
);
3280 staticpro (&Qsetting_constant
);
3281 staticpro (&Qinvalid_read_syntax
);
3282 staticpro (&Qwrong_number_of_arguments
);
3283 staticpro (&Qinvalid_function
);
3284 staticpro (&Qno_catch
);
3285 staticpro (&Qend_of_file
);
3286 staticpro (&Qarith_error
);
3287 staticpro (&Qbeginning_of_buffer
);
3288 staticpro (&Qend_of_buffer
);
3289 staticpro (&Qbuffer_read_only
);
3290 staticpro (&Qtext_read_only
);
3291 staticpro (&Qmark_inactive
);
3293 staticpro (&Qlistp
);
3294 staticpro (&Qconsp
);
3295 staticpro (&Qsymbolp
);
3296 staticpro (&Qkeywordp
);
3297 staticpro (&Qintegerp
);
3298 staticpro (&Qnatnump
);
3299 staticpro (&Qwholenump
);
3300 staticpro (&Qstringp
);
3301 staticpro (&Qarrayp
);
3302 staticpro (&Qsequencep
);
3303 staticpro (&Qbufferp
);
3304 staticpro (&Qvectorp
);
3305 staticpro (&Qchar_or_string_p
);
3306 staticpro (&Qmarkerp
);
3307 staticpro (&Qbuffer_or_string_p
);
3308 staticpro (&Qinteger_or_marker_p
);
3309 staticpro (&Qfloatp
);
3310 staticpro (&Qnumberp
);
3311 staticpro (&Qnumber_or_marker_p
);
3312 staticpro (&Qchar_table_p
);
3313 staticpro (&Qvector_or_char_table_p
);
3314 staticpro (&Qsubrp
);
3316 staticpro (&Qunevalled
);
3318 staticpro (&Qboundp
);
3319 staticpro (&Qfboundp
);
3321 staticpro (&Qad_advice_info
);
3322 staticpro (&Qad_activate_internal
);
3324 /* Types that type-of returns. */
3325 Qinteger
= intern_c_string ("integer");
3326 Qsymbol
= intern_c_string ("symbol");
3327 Qstring
= intern_c_string ("string");
3328 Qcons
= intern_c_string ("cons");
3329 Qmarker
= intern_c_string ("marker");
3330 Qoverlay
= intern_c_string ("overlay");
3331 Qfloat
= intern_c_string ("float");
3332 Qwindow_configuration
= intern_c_string ("window-configuration");
3333 Qprocess
= intern_c_string ("process");
3334 Qwindow
= intern_c_string ("window");
3335 /* Qsubr = intern_c_string ("subr"); */
3336 Qcompiled_function
= intern_c_string ("compiled-function");
3337 Qbuffer
= intern_c_string ("buffer");
3338 Qframe
= intern_c_string ("frame");
3339 Qvector
= intern_c_string ("vector");
3340 Qchar_table
= intern_c_string ("char-table");
3341 Qbool_vector
= intern_c_string ("bool-vector");
3342 Qhash_table
= intern_c_string ("hash-table");
3344 Qthread_local_mark
= Fmake_symbol (make_pure_string ("thread-local-mark",
3347 DEFSYM (Qfont_spec
, "font-spec");
3348 DEFSYM (Qfont_entity
, "font-entity");
3349 DEFSYM (Qfont_object
, "font-object");
3351 DEFSYM (Qinteractive_form
, "interactive-form");
3353 staticpro (&Qinteger
);
3354 staticpro (&Qsymbol
);
3355 staticpro (&Qstring
);
3357 staticpro (&Qmarker
);
3358 staticpro (&Qoverlay
);
3359 staticpro (&Qfloat
);
3360 staticpro (&Qwindow_configuration
);
3361 staticpro (&Qprocess
);
3362 staticpro (&Qwindow
);
3363 /* staticpro (&Qsubr); */
3364 staticpro (&Qcompiled_function
);
3365 staticpro (&Qbuffer
);
3366 staticpro (&Qframe
);
3367 staticpro (&Qvector
);
3368 staticpro (&Qchar_table
);
3369 staticpro (&Qbool_vector
);
3370 staticpro (&Qhash_table
);
3371 staticpro (&Qthread_local_mark
);
3373 defsubr (&Sindirect_variable
);
3374 defsubr (&Sinteractive_form
);
3377 defsubr (&Stype_of
);
3382 defsubr (&Sintegerp
);
3383 defsubr (&Sinteger_or_marker_p
);
3384 defsubr (&Snumberp
);
3385 defsubr (&Snumber_or_marker_p
);
3387 defsubr (&Snatnump
);
3388 defsubr (&Ssymbolp
);
3389 defsubr (&Skeywordp
);
3390 defsubr (&Sstringp
);
3391 defsubr (&Smultibyte_string_p
);
3392 defsubr (&Svectorp
);
3393 defsubr (&Schar_table_p
);
3394 defsubr (&Svector_or_char_table_p
);
3395 defsubr (&Sbool_vector_p
);
3397 defsubr (&Ssequencep
);
3398 defsubr (&Sbufferp
);
3399 defsubr (&Smarkerp
);
3401 defsubr (&Sbyte_code_function_p
);
3402 defsubr (&Schar_or_string_p
);
3405 defsubr (&Scar_safe
);
3406 defsubr (&Scdr_safe
);
3409 defsubr (&Ssymbol_function
);
3410 defsubr (&Sindirect_function
);
3411 defsubr (&Ssymbol_plist
);
3412 defsubr (&Ssymbol_name
);
3413 defsubr (&Smakunbound
);
3414 defsubr (&Sfmakunbound
);
3416 defsubr (&Sfboundp
);
3418 defsubr (&Sdefalias
);
3419 defsubr (&Ssetplist
);
3420 defsubr (&Ssymbol_value
);
3422 defsubr (&Sdefault_boundp
);
3423 defsubr (&Sdefault_value
);
3424 defsubr (&Sset_default
);
3425 defsubr (&Ssetq_default
);
3426 defsubr (&Smake_variable_buffer_local
);
3427 defsubr (&Smake_local_variable
);
3428 defsubr (&Skill_local_variable
);
3429 defsubr (&Smake_variable_frame_local
);
3430 defsubr (&Slocal_variable_p
);
3431 defsubr (&Slocal_variable_if_set_p
);
3432 defsubr (&Svariable_binding_locus
);
3433 #if 0 /* XXX Remove this. --lorentey */
3434 defsubr (&Sterminal_local_value
);
3435 defsubr (&Sset_terminal_local_value
);
3439 defsubr (&Snumber_to_string
);
3440 defsubr (&Sstring_to_number
);
3441 defsubr (&Seqlsign
);
3464 defsubr (&Sbyteorder
);
3465 defsubr (&Ssubr_arity
);
3466 defsubr (&Ssubr_name
);
3468 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3470 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3471 doc
: /* The largest value that is representable in a Lisp integer. */);
3472 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3473 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3475 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3476 doc
: /* The smallest value that is representable in a Lisp integer. */);
3477 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3478 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3485 sigsetmask (SIGEMPTYMASK
);
3487 SIGNAL_THREAD_CHECK (signo
);
3488 xsignal0 (Qarith_error
);
3494 /* Don't do this if just dumping out.
3495 We don't want to call `signal' in this case
3496 so that we don't have trouble with dumping
3497 signal-delivering routines in an inconsistent state. */
3501 #endif /* CANNOT_DUMP */
3502 signal (SIGFPE
, arith_error
);
3505 signal (SIGEMT
, arith_error
);
3509 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3510 (do not change this comment) */