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
));
95 static int let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
);
97 Lisp_Object impl_Vmost_positive_fixnum
, impl_Vmost_negative_fixnum
;
100 circular_list_error (list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (predicate
, value
)
109 register Lisp_Object predicate
, value
;
111 /* If VALUE is not even a valid Lisp object, we'd want to abort here
112 where we can get a backtrace showing where it came from. We used
113 to try and do that by checking the tagbits, but nowadays all
114 tagbits are potentially valid. */
115 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
118 xsignal2 (Qwrong_type_argument
, predicate
, value
);
124 error ("Attempt to modify read-only object");
128 args_out_of_range (a1
, a2
)
131 xsignal2 (Qargs_out_of_range
, a1
, a2
);
135 args_out_of_range_3 (a1
, a2
, a3
)
136 Lisp_Object a1
, a2
, a3
;
138 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
141 /* On some machines, XINT needs a temporary location.
142 Here it is, in case it is needed. */
144 int sign_extend_temp
;
146 /* On a few machines, XINT can only be done by calling this. */
149 sign_extend_lisp_int (num
)
152 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
153 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
155 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
158 /* Data type predicates */
160 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
161 doc
: /* Return t if the two args are the same Lisp object. */)
163 Lisp_Object obj1
, obj2
;
170 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
171 doc
: /* Return t if OBJECT is nil. */)
180 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
181 doc
: /* Return a symbol representing the type of OBJECT.
182 The symbol returned names the object's basic type;
183 for example, (type-of 1) returns `integer'. */)
187 switch (XTYPE (object
))
202 switch (XMISCTYPE (object
))
204 case Lisp_Misc_Marker
:
206 case Lisp_Misc_Overlay
:
208 case Lisp_Misc_Float
:
213 case Lisp_Vectorlike
:
214 if (WINDOW_CONFIGURATIONP (object
))
215 return Qwindow_configuration
;
216 if (PROCESSP (object
))
218 if (WINDOWP (object
))
222 if (COMPILEDP (object
))
223 return Qcompiled_function
;
224 if (BUFFERP (object
))
226 if (CHAR_TABLE_P (object
))
228 if (BOOL_VECTOR_P (object
))
232 if (HASH_TABLE_P (object
))
234 if (FONT_SPEC_P (object
))
236 if (FONT_ENTITY_P (object
))
238 if (FONT_OBJECT_P (object
))
250 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
251 doc
: /* Return t if OBJECT is a cons cell. */)
260 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
261 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
270 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
271 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
272 Otherwise, return nil. */)
276 if (CONSP (object
) || NILP (object
))
281 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
282 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
286 if (CONSP (object
) || NILP (object
))
291 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
292 doc
: /* Return t if OBJECT is a symbol. */)
296 if (SYMBOLP (object
))
301 /* Define this in C to avoid unnecessarily consing up the symbol
303 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
304 doc
: /* Return t if OBJECT is a keyword.
305 This means that it is a symbol with a print name beginning with `:'
306 interned in the initial obarray. */)
311 && SREF (SYMBOL_NAME (object
), 0) == ':'
312 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
317 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
318 doc
: /* Return t if OBJECT is a vector. */)
322 if (VECTORP (object
))
327 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
328 doc
: /* Return t if OBJECT is a string. */)
332 if (STRINGP (object
))
337 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
339 doc
: /* Return t if OBJECT is a multibyte string. */)
343 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
348 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
349 doc
: /* Return t if OBJECT is a char-table. */)
353 if (CHAR_TABLE_P (object
))
358 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
359 Svector_or_char_table_p
, 1, 1, 0,
360 doc
: /* Return t if OBJECT is a char-table or vector. */)
364 if (VECTORP (object
) || CHAR_TABLE_P (object
))
369 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a bool-vector. */)
374 if (BOOL_VECTOR_P (object
))
379 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
380 doc
: /* Return t if OBJECT is an array (string or vector). */)
389 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
390 doc
: /* Return t if OBJECT is a sequence (list or array). */)
392 register Lisp_Object object
;
394 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
399 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
400 doc
: /* Return t if OBJECT is an editor buffer. */)
404 if (BUFFERP (object
))
409 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
410 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
414 if (MARKERP (object
))
419 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
420 doc
: /* Return t if OBJECT is a built-in function. */)
429 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
431 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
435 if (COMPILEDP (object
))
440 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
441 doc
: /* Return t if OBJECT is a character or a string. */)
443 register Lisp_Object object
;
445 if (CHARACTERP (object
) || STRINGP (object
))
450 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
451 doc
: /* Return t if OBJECT is an integer. */)
455 if (INTEGERP (object
))
460 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
461 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
463 register Lisp_Object object
;
465 if (MARKERP (object
) || INTEGERP (object
))
470 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
471 doc
: /* Return t if OBJECT is a nonnegative integer. */)
475 if (NATNUMP (object
))
480 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
481 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
485 if (NUMBERP (object
))
491 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
492 Snumber_or_marker_p
, 1, 1, 0,
493 doc
: /* Return t if OBJECT is a number or a marker. */)
497 if (NUMBERP (object
) || MARKERP (object
))
502 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
503 doc
: /* Return t if OBJECT is a floating point number. */)
513 /* Extract and set components of lists */
515 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
516 doc
: /* Return the car of LIST. If arg is nil, return nil.
517 Error if arg is not nil and not a cons cell. See also `car-safe'.
519 See Info node `(elisp)Cons Cells' for a discussion of related basic
520 Lisp concepts such as car, cdr, cons cell and list. */)
522 register Lisp_Object list
;
527 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
528 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
532 return CAR_SAFE (object
);
535 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
536 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
537 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
539 See Info node `(elisp)Cons Cells' for a discussion of related basic
540 Lisp concepts such as cdr, car, cons cell and list. */)
542 register Lisp_Object list
;
547 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
548 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
552 return CDR_SAFE (object
);
555 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
556 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
558 register Lisp_Object cell
, newcar
;
562 XSETCAR (cell
, newcar
);
566 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
567 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
569 register Lisp_Object cell
, newcdr
;
573 XSETCDR (cell
, newcdr
);
577 /* Extract and set components of symbols */
579 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
580 doc
: /* Return t if SYMBOL's value is not void. */)
582 register Lisp_Object symbol
;
584 Lisp_Object valcontents
;
586 valcontents
= find_symbol_value (symbol
);
588 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
591 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
592 doc
: /* Return t if SYMBOL's function definition is not void. */)
594 register Lisp_Object symbol
;
596 CHECK_SYMBOL (symbol
);
597 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
600 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
601 doc
: /* Make SYMBOL's value be void.
604 register Lisp_Object symbol
;
606 CHECK_SYMBOL (symbol
);
607 if (SYMBOL_CONSTANT_P (symbol
))
608 xsignal1 (Qsetting_constant
, symbol
);
609 Fset (symbol
, Qunbound
);
613 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
614 doc
: /* Make SYMBOL's function definition be void.
617 register Lisp_Object symbol
;
619 CHECK_SYMBOL (symbol
);
620 if (NILP (symbol
) || EQ (symbol
, Qt
))
621 xsignal1 (Qsetting_constant
, symbol
);
622 XSYMBOL (symbol
)->function
= Qunbound
;
626 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
627 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
629 register Lisp_Object symbol
;
631 CHECK_SYMBOL (symbol
);
632 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
633 return XSYMBOL (symbol
)->function
;
634 xsignal1 (Qvoid_function
, symbol
);
637 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
638 doc
: /* Return SYMBOL's property list. */)
640 register Lisp_Object symbol
;
642 CHECK_SYMBOL (symbol
);
643 return XSYMBOL (symbol
)->plist
;
646 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
647 doc
: /* Return SYMBOL's name, a string. */)
649 register Lisp_Object symbol
;
651 register Lisp_Object name
;
653 CHECK_SYMBOL (symbol
);
654 name
= SYMBOL_NAME (symbol
);
658 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
659 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
661 register Lisp_Object symbol
, definition
;
663 register Lisp_Object function
;
665 CHECK_SYMBOL (symbol
);
666 if (NILP (symbol
) || EQ (symbol
, Qt
))
667 xsignal1 (Qsetting_constant
, symbol
);
669 function
= XSYMBOL (symbol
)->function
;
671 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
672 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
674 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
675 Fput (symbol
, Qautoload
, XCDR (function
));
677 XSYMBOL (symbol
)->function
= definition
;
678 /* Handle automatic advice activation */
679 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
681 call2 (Qad_activate_internal
, symbol
, Qnil
);
682 definition
= XSYMBOL (symbol
)->function
;
687 extern Lisp_Object Qfunction_documentation
;
689 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
690 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
691 Associates the function with the current load file, if any.
692 The optional third argument DOCSTRING specifies the documentation string
693 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
694 determined by DEFINITION. */)
695 (symbol
, definition
, docstring
)
696 register Lisp_Object symbol
, definition
, docstring
;
698 CHECK_SYMBOL (symbol
);
699 if (CONSP (XSYMBOL (symbol
)->function
)
700 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
701 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
702 definition
= Ffset (symbol
, definition
);
703 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
704 if (!NILP (docstring
))
705 Fput (symbol
, Qfunction_documentation
, docstring
);
709 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
710 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
712 register Lisp_Object symbol
, newplist
;
714 CHECK_SYMBOL (symbol
);
715 XSYMBOL (symbol
)->plist
= newplist
;
719 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
720 doc
: /* Return minimum and maximum number of args allowed for SUBR.
721 SUBR must be a built-in function.
722 The returned value is a pair (MIN . MAX). MIN is the minimum number
723 of args. MAX is the maximum number or the symbol `many', for a
724 function with `&rest' args, or `unevalled' for a special form. */)
728 short minargs
, maxargs
;
730 minargs
= XSUBR (subr
)->min_args
;
731 maxargs
= XSUBR (subr
)->max_args
;
733 return Fcons (make_number (minargs
), Qmany
);
734 else if (maxargs
== UNEVALLED
)
735 return Fcons (make_number (minargs
), Qunevalled
);
737 return Fcons (make_number (minargs
), make_number (maxargs
));
740 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
741 doc
: /* Return name of subroutine SUBR.
742 SUBR must be a built-in function. */)
748 name
= XSUBR (subr
)->symbol_name
;
749 return make_string (name
, strlen (name
));
752 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
753 doc
: /* Return the interactive form of CMD or nil if none.
754 If CMD is not a command, the return value is nil.
755 Value, if non-nil, is a list \(interactive SPEC). */)
759 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
761 if (NILP (fun
) || EQ (fun
, Qunbound
))
764 /* Use an `interactive-form' property if present, analogous to the
765 function-documentation property. */
767 while (SYMBOLP (fun
))
769 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
773 fun
= Fsymbol_function (fun
);
778 char *spec
= XSUBR (fun
)->intspec
;
780 return list2 (Qinteractive
,
781 (*spec
!= '(') ? build_string (spec
) :
782 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
784 else if (COMPILEDP (fun
))
786 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
787 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
789 else if (CONSP (fun
))
791 Lisp_Object funcar
= XCAR (fun
);
792 if (EQ (funcar
, Qlambda
))
793 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
794 else if (EQ (funcar
, Qautoload
))
798 do_autoload (fun
, cmd
);
800 return Finteractive_form (cmd
);
807 /***********************************************************************
808 Getting and Setting Values of Symbols
809 ***********************************************************************/
812 blocal_getrealvalue (struct Lisp_Buffer_Local_Value
*blv
)
814 return &XCDR_AS_LVALUE (ensure_thread_local (&(blv
->realvalue
)));
817 /* Retrieve the buffer local data for the caller thread. SYMBOL is used only
818 when the specified buffer local value does not have a binding for the thread
819 and a new one must be created. */
822 blocal_get_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object symbol
)
824 Lisp_Object ret
= assq_no_quit (get_current_thread (), l
->thread_data
);
827 Lisp_Object tem
, val
, len
;
829 if (NILP (symbol
) || !initialized
)
832 XSETFASTINT (len
, 4);
833 ret
= Fmake_vector (len
, Qnil
);
835 BLOCAL_CLEAR_FLAGS_VEC (ret
);
836 tem
= Fcons (Qnil
, Qnil
);
837 val
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
838 if (NILP (val
) || (l
->check_frame
&& ! EQ (selected_frame
, Qnil
)))
840 val
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
842 BLOCAL_SET_FOUND_FOR_FRAME_VEC (ret
);
845 val
= XTHREADLOCAL (l
->realvalue
)->global
;
853 XSETCDR (tem
, XTHREADLOCAL (l
->realvalue
)->global
);
854 BLOCAL_SET_FOUND_FOR_BUFFER_VEC (ret
);
857 BLOCAL_BUFFER_VEC (ret
) = Fcurrent_buffer ();
858 BLOCAL_FRAME_VEC (ret
) = Qnil
;
859 BLOCAL_CDR_VEC (ret
) = tem
;
861 ret
= Fcons (get_current_thread (), ret
);
862 l
->thread_data
= Fcons (ret
, l
->thread_data
);
863 XTHREADLOCAL (l
->realvalue
)->thread_alist
=
864 Fcons (Fcons (get_current_thread (), val
),
865 XTHREADLOCAL (l
->realvalue
)->thread_alist
);
868 return &XCDR_AS_LVALUE (ret
);
871 /* Remove any thread-local data. */
873 blocal_unbind_thread (Lisp_Object thread
)
877 struct Lisp_Vector
*obarray
= XVECTOR (Vobarray
);
878 for (i
= 0; i
< obarray
->size
; i
++)
880 struct Lisp_Symbol
*sym
;
882 if (!SYMBOLP (obarray
->contents
[i
]))
885 sym
= XSYMBOL (obarray
->contents
[i
]);
887 #define UNBIND_LOCAL_VALUE(X) do { \
888 Lisp_Object tem = assq_no_quit (thread, (X)); \
890 (X) = Fdelq (tem, (X)); \
893 if (BUFFER_LOCAL_VALUEP (SYMBOL_VALUE (obarray
->contents
[i
])))
895 struct Lisp_Buffer_Local_Value
*loc
896 = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (obarray
->contents
[i
]));
898 UNBIND_LOCAL_VALUE (loc
->realvalue
);
899 UNBIND_LOCAL_VALUE (loc
->thread_data
);
902 if (THREADLOCALP (SYMBOL_VALUE (obarray
->contents
[i
])))
904 struct Lisp_ThreadLocal
*val
905 = XTHREADLOCAL (SYMBOL_VALUE (obarray
->contents
[i
]));
906 UNBIND_LOCAL_VALUE (val
->thread_alist
);
909 #undef UNBIND_LOCAL_VALUE
913 blocal_set_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object obj
)
915 if (! NILP (l
->thread_data
))
918 l
->thread_data
= Fcons (Fcons (get_current_thread (), obj
), Qnil
);
922 find_variable_location (Lisp_Object
*root
)
924 if (THREADLOCALP (*root
))
926 struct Lisp_ThreadLocal
*thr
= XTHREADLOCAL (*root
);
927 Lisp_Object cons
= assq_no_quit (get_current_thread (),
929 if (!EQ (cons
, Qnil
))
930 return &XCDR_AS_LVALUE (cons
);
939 ensure_thread_local (Lisp_Object
*root
)
943 if (THREADLOCALP (*root
))
944 cons
= assq_no_quit (get_current_thread (),
945 XTHREADLOCAL (*root
)->thread_alist
);
949 newval
= allocate_misc ();
950 XMISCTYPE (newval
) = Lisp_Misc_ThreadLocal
;
951 XTHREADLOCAL (newval
)->global
= *root
;
952 XTHREADLOCAL (newval
)->thread_alist
= Qnil
;
959 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
960 cons
= Fcons (get_current_thread (), Qthread_local_mark
);
961 local
->thread_alist
= Fcons (cons
, local
->thread_alist
);
968 remove_thread_local (Lisp_Object
*root
)
970 if (THREADLOCALP (*root
))
972 Lisp_Object iter
, thr
= get_current_thread (), prior
= Qnil
;
973 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
974 for (iter
= local
->thread_alist
; !NILP (iter
); iter
= XCDR (iter
))
976 if (EQ (XCAR (XCAR (iter
)), thr
))
979 local
->thread_alist
= XCDR (iter
);
981 XSETCDR (prior
, XCDR (iter
));
989 /* Return the symbol holding SYMBOL's value. Signal
990 `cyclic-variable-indirection' if SYMBOL's chain of variable
991 indirections contains a loop. */
994 indirect_variable (symbol
)
995 struct Lisp_Symbol
*symbol
;
997 struct Lisp_Symbol
*tortoise
, *hare
;
999 hare
= tortoise
= symbol
;
1001 while (hare
->indirect_variable
)
1003 hare
= XSYMBOL (hare
->value
);
1004 if (!hare
->indirect_variable
)
1007 hare
= XSYMBOL (hare
->value
);
1008 tortoise
= XSYMBOL (tortoise
->value
);
1010 if (hare
== tortoise
)
1013 XSETSYMBOL (tem
, symbol
);
1014 xsignal1 (Qcyclic_variable_indirection
, tem
);
1022 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
1023 doc
: /* Return the variable at the end of OBJECT's variable chain.
1024 If OBJECT is a symbol, follow all variable indirections and return the final
1025 variable. If OBJECT is not a symbol, just return it.
1026 Signal a cyclic-variable-indirection error if there is a loop in the
1027 variable chain of symbols. */)
1031 if (SYMBOLP (object
))
1032 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
1037 /* Given the raw contents of a symbol value cell,
1038 return the Lisp value of the symbol.
1039 This does not handle buffer-local variables; use
1040 swap_in_symval_forwarding for that. */
1043 do_symval_forwarding (valcontents
)
1044 Lisp_Object valcontents
;
1046 register Lisp_Object val
;
1047 if (MISCP (valcontents
))
1048 switch (XMISCTYPE (valcontents
))
1050 case Lisp_Misc_Intfwd
:
1051 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1054 case Lisp_Misc_Boolfwd
:
1055 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1057 case Lisp_Misc_Objfwd
:
1058 return *XOBJFWD (valcontents
)->objvar
;
1060 case Lisp_Misc_Buffer_Objfwd
:
1061 return PER_BUFFER_VALUE (current_buffer
,
1062 XBUFFER_OBJFWD (valcontents
)->offset
);
1064 case Lisp_Misc_Kboard_Objfwd
:
1065 /* We used to simply use current_kboard here, but from Lisp
1066 code, it's value is often unexpected. It seems nicer to
1067 allow constructions like this to work as intuitively expected:
1069 (with-selected-frame frame
1070 (define-key local-function-map "\eOP" [f1]))
1072 On the other hand, this affects the semantics of
1073 last-command and real-last-command, and people may rely on
1074 that. I took a quick look at the Lisp codebase, and I
1075 don't think anything will break. --lorentey */
1076 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1077 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1079 case Lisp_Misc_ThreadLocal
:
1080 return *find_variable_location (&valcontents
);
1085 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1086 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1087 buffer-independent contents of the value cell: forwarded just one
1088 step past the buffer-localness.
1090 BUF non-zero means set the value in buffer BUF instead of the
1091 current buffer. This only plays a role for per-buffer variables. */
1094 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
1096 register Lisp_Object valcontents
, newval
;
1099 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
1102 switch (XMISCTYPE (valcontents
))
1104 case Lisp_Misc_Intfwd
:
1105 CHECK_NUMBER (newval
);
1106 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1107 /* This can never happen since intvar points to an EMACS_INT
1108 which is at least large enough to hold a Lisp_Object.
1109 if (*XINTFWD (valcontents)->intvar != XINT (newval))
1110 error ("Value out of range for variable `%s'",
1111 SDATA (SYMBOL_NAME (symbol))); */
1114 case Lisp_Misc_Boolfwd
:
1115 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1118 case Lisp_Misc_Objfwd
:
1119 *find_variable_location (XOBJFWD (valcontents
)->objvar
) = newval
;
1121 /* If this variable is a default for something stored
1122 in the buffer itself, such as default-fill-column,
1123 find the buffers that don't have local values for it
1125 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1126 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1128 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1129 - (char *) &buffer_defaults
);
1130 int idx
= PER_BUFFER_IDX (offset
);
1137 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
1142 buf
= Fcdr (XCAR (tail
));
1143 if (!BUFFERP (buf
)) continue;
1146 if (! PER_BUFFER_VALUE_P (b
, idx
))
1147 SET_PER_BUFFER_VALUE_RAW (b
, offset
, newval
);
1152 case Lisp_Misc_Buffer_Objfwd
:
1154 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1155 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1157 if (!(NILP (type
) || NILP (newval
)
1158 || (XINT (type
) == LISP_INT_TAG
1160 : XTYPE (newval
) == XINT (type
))))
1161 buffer_slot_type_mismatch (newval
, XINT (type
));
1164 buf
= current_buffer
;
1165 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1169 case Lisp_Misc_Kboard_Objfwd
:
1171 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1172 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1173 *(Lisp_Object
*) p
= newval
;
1184 valcontents
= SYMBOL_VALUE (symbol
);
1185 if (BUFFER_LOCAL_VALUEP (valcontents
))
1187 Lisp_Object v
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1188 if (! let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1191 for (it
= XBUFFER_LOCAL_VALUE (valcontents
)->thread_data
;
1192 !NILP (it
); it
= XCDR (it
))
1194 Lisp_Object head
= XCDR (XCAR (it
));
1195 if (EQ (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)),
1196 BLOCAL_BUFFER_VEC (head
))
1197 && (! XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1198 || EQ (selected_frame
, BLOCAL_FRAME_VEC (head
))))
1201 = XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1202 Fsetcdr (assq_no_quit (XCAR (XCAR (it
)),
1203 XTHREADLOCAL (rv
)->thread_alist
),
1205 Fsetcdr (XCAR (BLOCAL_CDR_VEC (head
)), newval
);
1209 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)) = newval
;
1211 else if (THREADLOCALP (valcontents
))
1213 Lisp_Object val
= indirect_variable (XSYMBOL (symbol
))->value
;
1214 val
= ensure_thread_local (&val
);
1215 XSETCDR (val
, newval
);
1218 SET_SYMBOL_VALUE (symbol
, newval
);
1222 /* Set up SYMBOL to refer to its global binding.
1223 This makes it safe to alter the status of other bindings. */
1226 swap_in_global_binding (symbol
)
1229 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1230 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1231 Lisp_Object cdr
= BLOCAL_CDR (blv
);
1233 /* Unload the previously loaded binding. */
1234 Fsetcdr (XCAR (cdr
),
1235 do_symval_forwarding (BLOCAL_REALVALUE (blv
)));
1237 /* Select the global binding in the symbol. */
1239 store_symval_forwarding (symbol
, BLOCAL_REALVALUE (blv
), XCDR (cdr
), NULL
);
1241 /* Indicate that the global binding is set up now. */
1242 BLOCAL_FRAME (blv
) = Qnil
;
1243 BLOCAL_BUFFER (blv
) = Qnil
;
1244 BLOCAL_CLEAR_FLAGS (blv
);
1247 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1248 VALCONTENTS is the contents of its value cell,
1249 which points to a struct Lisp_Buffer_Local_Value.
1251 Return the value forwarded one step past the buffer-local stage.
1252 This could be another forwarding pointer. */
1255 swap_in_symval_forwarding (symbol
, valcontents
)
1256 Lisp_Object symbol
, valcontents
;
1258 register Lisp_Object tem1
;
1260 struct Lisp_Buffer_Local_Value
*local
= XBUFFER_LOCAL_VALUE (valcontents
);
1261 blocal_get_thread_data (local
, symbol
);
1262 tem1
= BLOCAL_BUFFER (local
);
1265 || current_buffer
!= XBUFFER (tem1
)
1266 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1267 && ! EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))))
1269 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1270 if (sym
->indirect_variable
)
1272 sym
= indirect_variable (sym
);
1273 XSETSYMBOL (symbol
, sym
);
1276 /* Unload the previously loaded binding. */
1277 tem1
= XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1279 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1281 /* Choose the new binding. */
1282 tem1
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1283 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1286 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1287 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1289 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1291 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1294 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1296 /* Load the new binding. */
1297 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1298 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), current_buffer
);
1299 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1300 store_symval_forwarding (symbol
,
1301 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1305 return BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1309 /* Find the value of a symbol, returning Qunbound if it's not bound.
1310 This is helpful for code which just wants to get a variable's value
1311 if it has one, without signaling an error.
1312 Note that it must not be possible to quit
1313 within this function. Great care is required for this. */
1316 find_symbol_value (symbol
)
1319 register Lisp_Object valcontents
;
1320 register Lisp_Object val
;
1322 CHECK_SYMBOL (symbol
);
1323 valcontents
= SYMBOL_VALUE (symbol
);
1325 if (BUFFER_LOCAL_VALUEP (valcontents
))
1326 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1328 return do_symval_forwarding (valcontents
);
1331 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1332 doc
: /* Return SYMBOL's value. Error if that is void. */)
1338 val
= find_symbol_value (symbol
);
1339 if (!EQ (val
, Qunbound
))
1342 xsignal1 (Qvoid_variable
, symbol
);
1345 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1346 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1348 register Lisp_Object symbol
, newval
;
1350 return set_internal (symbol
, newval
, current_buffer
, 0);
1353 /* Return 1 if SYMBOL currently has a let-binding
1354 which was made in the buffer that is now current. */
1357 let_shadows_buffer_binding_p (symbol
)
1358 struct Lisp_Symbol
*symbol
;
1360 volatile struct specbinding
*p
;
1362 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1364 && CONSP (p
->symbol
))
1366 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1367 if ((symbol
== let_bound_symbol
1368 || (let_bound_symbol
->indirect_variable
1369 && symbol
== indirect_variable (let_bound_symbol
)))
1370 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1374 return p
>= specpdl
;
1377 /* Store the value NEWVAL into SYMBOL.
1378 If buffer-locality is an issue, BUF specifies which buffer to use.
1379 (0 stands for the current buffer.)
1381 If BINDFLAG is zero, then if this symbol is supposed to become
1382 local in every buffer where it is set, then we make it local.
1383 If BINDFLAG is nonzero, we don't do that. */
1386 set_internal (symbol
, newval
, buf
, bindflag
)
1387 register Lisp_Object symbol
, newval
;
1391 int voide
= EQ (newval
, Qunbound
);
1393 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1396 buf
= current_buffer
;
1398 /* If restoring in a dead buffer, do nothing. */
1399 if (NILP (BUF_NAME (buf
)))
1402 CHECK_SYMBOL (symbol
);
1403 if (SYMBOL_CONSTANT_P (symbol
)
1404 && (NILP (Fkeywordp (symbol
))
1405 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1406 xsignal1 (Qsetting_constant
, symbol
);
1408 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1410 if (BUFFER_OBJFWDP (valcontents
))
1412 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1413 int idx
= PER_BUFFER_IDX (offset
);
1416 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1417 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1419 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1421 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1422 if (XSYMBOL (symbol
)->indirect_variable
)
1423 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1425 blocal_get_thread_data (XBUFFER_LOCAL_VALUE (valcontents
), symbol
);
1427 /* What binding is loaded right now? */
1428 current_alist_element
1429 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1431 /* If the current buffer is not the buffer whose binding is
1432 loaded, or if there may be frame-local bindings and the frame
1433 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1434 the default binding is loaded, the loaded binding may be the
1436 if (!BUFFERP (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1437 || buf
!= XBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1438 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1439 && !EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
))))
1440 /* Also unload a global binding (if the var is local_if_set). */
1441 || (EQ (XCAR (current_alist_element
),
1442 current_alist_element
)))
1444 /* The currently loaded binding is not necessarily valid.
1445 We need to unload it, and choose a new binding. */
1447 /* Write out `realvalue' to the old loaded binding. */
1448 Fsetcdr (current_alist_element
,
1449 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1451 /* Find the new binding. */
1452 tem1
= Fassq (symbol
, BUF_LOCAL_VAR_ALIST (buf
));
1453 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1457 /* This buffer still sees the default value. */
1459 /* If the variable is not local_if_set,
1460 or if this is `let' rather than `set',
1461 make CURRENT-ALIST-ELEMENT point to itself,
1462 indicating that we're seeing the default value.
1463 Likewise if the variable has been let-bound
1464 in the current buffer. */
1465 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1466 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1468 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1470 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1471 tem1
= Fassq (symbol
,
1472 XFRAME (selected_frame
)->param_alist
);
1475 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1477 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1479 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1480 and we're not within a let that was made for this buffer,
1481 create a new buffer-local binding for the variable.
1482 That means, give this buffer a new assoc for a local value
1483 and load that binding. */
1486 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1487 BUF_LOCAL_VAR_ALIST (buf
)
1488 = Fcons (tem1
, BUF_LOCAL_VAR_ALIST (buf
));
1492 /* Record which binding is now loaded. */
1493 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1495 /* Set `buffer' and `frame' slots for the binding now loaded. */
1496 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), buf
);
1497 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1499 innercontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1501 /* Store the new value in the cons-cell. */
1502 XSETCDR (XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
))), newval
);
1505 /* If storing void (making the symbol void), forward only through
1506 buffer-local indicator, not through Lisp_Objfwd, etc. */
1508 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1510 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1515 /* Access or set a buffer-local symbol's default value. */
1517 /* Return the default value of SYMBOL, but don't check for voidness.
1518 Return Qunbound if it is void. */
1521 default_value (symbol
)
1524 register Lisp_Object valcontents
;
1526 CHECK_SYMBOL (symbol
);
1527 valcontents
= SYMBOL_VALUE (symbol
);
1529 /* For a built-in buffer-local variable, get the default value
1530 rather than letting do_symval_forwarding get the current value. */
1531 if (BUFFER_OBJFWDP (valcontents
))
1533 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1534 if (PER_BUFFER_IDX (offset
) != 0)
1535 return PER_BUFFER_DEFAULT (offset
);
1538 /* Handle user-created local variables. */
1539 if (BUFFER_LOCAL_VALUEP (valcontents
))
1541 /* If var is set up for a buffer that lacks a local value for it,
1542 the current value is nominally the default value.
1543 But the `realvalue' slot may be more up to date, since
1544 ordinary setq stores just that slot. So use that. */
1545 Lisp_Object current_alist_element
, alist_element_car
;
1547 blocal_get_thread_data (XBUFFER_LOCAL_VALUE (valcontents
), symbol
);
1549 current_alist_element
1550 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1551 alist_element_car
= XCAR (current_alist_element
);
1552 if (EQ (alist_element_car
, current_alist_element
))
1553 return do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)));
1555 return XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1557 /* For other variables, get the current value. */
1558 return do_symval_forwarding (valcontents
);
1561 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1562 doc
: /* Return t if SYMBOL has a non-void default value.
1563 This is the value that is seen in buffers that do not have their own values
1564 for this variable. */)
1568 register Lisp_Object value
;
1570 value
= default_value (symbol
);
1571 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1574 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1575 doc
: /* Return SYMBOL's default value.
1576 This is the value that is seen in buffers that do not have their own values
1577 for this variable. The default value is meaningful for variables with
1578 local bindings in certain buffers. */)
1582 register Lisp_Object value
;
1584 value
= default_value (symbol
);
1585 if (!EQ (value
, Qunbound
))
1588 xsignal1 (Qvoid_variable
, symbol
);
1591 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1592 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1593 The default value is seen in buffers that do not have their own values
1594 for this variable. */)
1596 Lisp_Object symbol
, value
;
1598 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1600 CHECK_SYMBOL (symbol
);
1601 valcontents
= SYMBOL_VALUE (symbol
);
1603 /* Handle variables like case-fold-search that have special slots
1604 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1606 if (BUFFER_OBJFWDP (valcontents
))
1608 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1609 int idx
= PER_BUFFER_IDX (offset
);
1611 PER_BUFFER_DEFAULT (offset
) = value
;
1613 /* If this variable is not always local in all buffers,
1614 set it in the buffers that don't nominally have a local value. */
1619 for (b
= all_buffers
; b
; b
= b
->next
)
1620 if (!PER_BUFFER_VALUE_P (b
, idx
))
1621 PER_BUFFER_VALUE (b
, offset
) = value
;
1626 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1627 return Fset (symbol
, value
);
1629 /* Store new value into the DEFAULT-VALUE slot. */
1630 XSETCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), value
);
1632 /* If the default binding is now loaded, set the REALVALUE slot too. */
1633 current_alist_element
1634 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1635 alist_element_buffer
= Fcar (current_alist_element
);
1636 if (EQ (alist_element_buffer
, current_alist_element
))
1637 store_symval_forwarding (symbol
,
1638 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1644 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1645 doc
: /* Set the default value of variable VAR to VALUE.
1646 VAR, the variable name, is literal (not evaluated);
1647 VALUE is an expression: it is evaluated and its value returned.
1648 The default value of a variable is seen in buffers
1649 that do not have their own values for the variable.
1651 More generally, you can use multiple variables and values, as in
1652 (setq-default VAR VALUE VAR VALUE...)
1653 This sets each VAR's default value to the corresponding VALUE.
1654 The VALUE for the Nth VAR can refer to the new default values
1656 usage: (setq-default [VAR VALUE]...) */)
1660 register Lisp_Object args_left
;
1661 register Lisp_Object val
, symbol
;
1662 struct gcpro gcpro1
;
1672 val
= Feval (Fcar (Fcdr (args_left
)));
1673 symbol
= XCAR (args_left
);
1674 Fset_default (symbol
, val
);
1675 args_left
= Fcdr (XCDR (args_left
));
1677 while (!NILP (args_left
));
1683 /* Lisp functions for creating and removing buffer-local variables. */
1685 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1686 1, 1, "vMake Variable Buffer Local: ",
1687 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1688 At any time, the value for the current buffer is in effect,
1689 unless the variable has never been set in this buffer,
1690 in which case the default value is in effect.
1691 Note that binding the variable with `let', or setting it while
1692 a `let'-style binding made in this buffer is in effect,
1693 does not make the variable buffer-local. Return VARIABLE.
1695 In most cases it is better to use `make-local-variable',
1696 which makes a variable local in just one buffer.
1698 The function `default-value' gets the default value and `set-default' sets it. */)
1700 register Lisp_Object variable
;
1702 register Lisp_Object tem
, valcontents
, newval
;
1703 struct Lisp_Symbol
*sym
;
1705 CHECK_SYMBOL (variable
);
1706 sym
= indirect_variable (XSYMBOL (variable
));
1708 valcontents
= sym
->value
;
1709 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1710 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1712 if (BUFFER_OBJFWDP (valcontents
))
1714 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1716 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1717 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1718 newval
= valcontents
;
1722 Lisp_Object len
, val_vec
;
1723 XSETFASTINT (len
, 4);
1724 val_vec
= Fmake_vector (len
, Qnil
);
1725 if (EQ (valcontents
, Qunbound
))
1727 tem
= Fcons (Qnil
, valcontents
);
1729 newval
= allocate_misc ();
1730 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1731 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1732 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1733 BLOCAL_BUFFER_VEC (val_vec
) = Fcurrent_buffer ();
1734 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1735 BLOCAL_CDR_VEC (val_vec
) = tem
;
1736 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1737 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1738 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1739 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1740 = Lisp_Misc_ThreadLocal
;
1741 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1743 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1744 = Fcons (Fcons (get_current_thread (), valcontents
), Qnil
);
1745 sym
->value
= newval
;
1747 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1751 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1752 1, 1, "vMake Local Variable: ",
1753 doc
: /* Make VARIABLE have a separate value in the current buffer.
1754 Other buffers will continue to share a common default value.
1755 \(The buffer-local value of VARIABLE starts out as the same value
1756 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1759 If the variable is already arranged to become local when set,
1760 this function causes a local value to exist for this buffer,
1761 just as setting the variable would do.
1763 This function returns VARIABLE, and therefore
1764 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1767 See also `make-variable-buffer-local'.
1769 Do not use `make-local-variable' to make a hook variable buffer-local.
1770 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1772 register Lisp_Object variable
;
1774 register Lisp_Object tem
, valcontents
;
1775 struct Lisp_Symbol
*sym
;
1777 CHECK_SYMBOL (variable
);
1778 sym
= indirect_variable (XSYMBOL (variable
));
1780 valcontents
= sym
->value
;
1781 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1782 || (BUFFER_LOCAL_VALUEP (valcontents
)
1783 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1784 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1786 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1787 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1788 || BUFFER_OBJFWDP (valcontents
))
1790 tem
= Fboundp (variable
);
1792 /* Make sure the symbol has a local value in this particular buffer,
1793 by setting it to the same value it already has. */
1794 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1797 /* Make sure symbol is set up to hold per-buffer values. */
1798 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1800 Lisp_Object newval
, len
, val_vec
;
1801 XSETFASTINT (len
, 4);
1802 val_vec
= Fmake_vector (len
, Qnil
);
1803 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1805 newval
= allocate_misc ();
1806 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1807 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1808 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1809 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1810 BLOCAL_CDR_VEC (val_vec
) = tem
;
1811 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1812 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1813 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1814 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1815 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1816 = Lisp_Misc_ThreadLocal
;
1817 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1819 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1820 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1821 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1822 sym
->value
= newval
;
1824 /* Make sure this buffer has its own value of symbol. */
1825 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1826 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1829 /* Swap out any local binding for some other buffer, and make
1830 sure the current value is permanently recorded, if it's the
1832 find_symbol_value (variable
);
1834 BUF_LOCAL_VAR_ALIST (current_buffer
)
1835 = Fcons (Fcons (variable
, XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (sym
->value
)))),
1836 BUF_LOCAL_VAR_ALIST (current_buffer
));
1838 /* Make sure symbol does not think it is set up for this buffer;
1839 force it to look once again for this buffer's value. */
1841 Lisp_Object
*pvalbuf
;
1843 valcontents
= sym
->value
;
1845 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1846 if (current_buffer
== XBUFFER (*pvalbuf
))
1848 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1852 /* If the symbol forwards into a C variable, then load the binding
1853 for this buffer now. If C code modifies the variable before we
1854 load the binding in, then that new value will clobber the default
1855 binding the next time we unload it. */
1856 valcontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (sym
->value
));
1857 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1858 swap_in_symval_forwarding (variable
, sym
->value
);
1863 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1864 1, 1, "vKill Local Variable: ",
1865 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1866 From now on the default value will apply in this buffer. Return VARIABLE. */)
1868 register Lisp_Object variable
;
1870 register Lisp_Object tem
, valcontents
;
1871 struct Lisp_Symbol
*sym
;
1873 CHECK_SYMBOL (variable
);
1874 sym
= indirect_variable (XSYMBOL (variable
));
1876 valcontents
= sym
->value
;
1878 if (BUFFER_OBJFWDP (valcontents
))
1880 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1881 int idx
= PER_BUFFER_IDX (offset
);
1885 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1886 PER_BUFFER_VALUE (current_buffer
, offset
)
1887 = PER_BUFFER_DEFAULT (offset
);
1892 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1895 /* Get rid of this buffer's alist element, if any. */
1896 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1897 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1899 BUF_LOCAL_VAR_ALIST (current_buffer
)
1900 = Fdelq (tem
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1902 /* If the symbol is set up with the current buffer's binding
1903 loaded, recompute its value. We have to do it now, or else
1904 forwarded objects won't work right. */
1906 Lisp_Object
*pvalbuf
, buf
;
1907 valcontents
= sym
->value
;
1908 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1909 XSETBUFFER (buf
, current_buffer
);
1910 if (EQ (buf
, *pvalbuf
))
1913 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1914 find_symbol_value (variable
);
1921 /* Lisp functions for creating and removing buffer-local variables. */
1923 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1924 when/if this is removed. */
1926 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1927 1, 1, "vMake Variable Frame Local: ",
1928 doc
: /* Enable VARIABLE to have frame-local bindings.
1929 This does not create any frame-local bindings for VARIABLE,
1930 it just makes them possible.
1932 A frame-local binding is actually a frame parameter value.
1933 If a frame F has a value for the frame parameter named VARIABLE,
1934 that also acts as a frame-local binding for VARIABLE in F--
1935 provided this function has been called to enable VARIABLE
1936 to have frame-local bindings at all.
1938 The only way to create a frame-local binding for VARIABLE in a frame
1939 is to set the VARIABLE frame parameter of that frame. See
1940 `modify-frame-parameters' for how to set frame parameters.
1942 Note that since Emacs 23.1, variables cannot be both buffer-local and
1943 frame-local any more (buffer-local bindings used to take precedence over
1944 frame-local bindings). */)
1946 register Lisp_Object variable
;
1948 register Lisp_Object tem
, valcontents
, newval
, val_vec
, len
;
1949 struct Lisp_Symbol
*sym
;
1951 CHECK_SYMBOL (variable
);
1952 sym
= indirect_variable (XSYMBOL (variable
));
1954 valcontents
= sym
->value
;
1955 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1956 || BUFFER_OBJFWDP (valcontents
))
1957 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1959 if (BUFFER_LOCAL_VALUEP (valcontents
))
1961 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1962 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1966 if (EQ (valcontents
, Qunbound
))
1968 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1970 newval
= allocate_misc ();
1971 XSETFASTINT (len
, 4);
1972 val_vec
= Fmake_vector (len
, Qnil
);
1973 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1974 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1975 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1976 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1977 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1978 BLOCAL_CDR_VEC (val_vec
) = tem
;
1979 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1980 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1981 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1982 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1983 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1984 = Lisp_Misc_ThreadLocal
;
1985 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1987 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1988 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1989 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1990 sym
->value
= newval
;
1994 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1996 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1997 BUFFER defaults to the current buffer. */)
1999 register Lisp_Object variable
, buffer
;
2001 Lisp_Object valcontents
;
2002 register struct buffer
*buf
;
2003 struct Lisp_Symbol
*sym
;
2006 buf
= current_buffer
;
2009 CHECK_BUFFER (buffer
);
2010 buf
= XBUFFER (buffer
);
2013 CHECK_SYMBOL (variable
);
2014 sym
= indirect_variable (XSYMBOL (variable
));
2015 XSETSYMBOL (variable
, sym
);
2017 valcontents
= sym
->value
;
2018 if (BUFFER_LOCAL_VALUEP (valcontents
))
2020 Lisp_Object tail
, elt
;
2022 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2025 if (EQ (variable
, XCAR (elt
)))
2029 if (BUFFER_OBJFWDP (valcontents
))
2031 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2032 int idx
= PER_BUFFER_IDX (offset
);
2033 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2039 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2041 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
2042 More precisely, this means that setting the variable \(with `set' or`setq'),
2043 while it does not have a `let'-style binding that was made in BUFFER,
2044 will produce a buffer local binding. See Info node
2045 `(elisp)Creating Buffer-Local'.
2046 BUFFER defaults to the current buffer. */)
2048 register Lisp_Object variable
, buffer
;
2050 Lisp_Object valcontents
;
2051 register struct buffer
*buf
;
2052 struct Lisp_Symbol
*sym
;
2055 buf
= current_buffer
;
2058 CHECK_BUFFER (buffer
);
2059 buf
= XBUFFER (buffer
);
2062 CHECK_SYMBOL (variable
);
2063 sym
= indirect_variable (XSYMBOL (variable
));
2064 XSETSYMBOL (variable
, sym
);
2066 valcontents
= sym
->value
;
2068 if (BUFFER_OBJFWDP (valcontents
))
2069 /* All these slots become local if they are set. */
2071 else if (BUFFER_LOCAL_VALUEP (valcontents
))
2073 Lisp_Object tail
, elt
;
2074 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
2076 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2079 if (EQ (variable
, XCAR (elt
)))
2086 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2088 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2089 If the current binding is buffer-local, the value is the current buffer.
2090 If the current binding is frame-local, the value is the selected frame.
2091 If the current binding is global (the default), the value is nil. */)
2093 register Lisp_Object variable
;
2095 Lisp_Object valcontents
;
2096 struct Lisp_Symbol
*sym
;
2098 CHECK_SYMBOL (variable
);
2099 sym
= indirect_variable (XSYMBOL (variable
));
2101 /* Make sure the current binding is actually swapped in. */
2102 find_symbol_value (variable
);
2104 valcontents
= sym
->value
;
2106 if (BUFFER_LOCAL_VALUEP (valcontents
)
2107 || BUFFER_OBJFWDP (valcontents
))
2109 /* For a local variable, record both the symbol and which
2110 buffer's or frame's value we are saving. */
2111 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2112 return Fcurrent_buffer ();
2113 else if (BUFFER_LOCAL_VALUEP (valcontents
)
2114 && BLOCAL_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))
2115 return BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
2121 /* This code is disabled now that we use the selected frame to return
2122 keyboard-local-values. */
2124 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2126 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2127 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2128 If SYMBOL is not a terminal-local variable, then return its normal
2129 value, like `symbol-value'.
2131 TERMINAL may be a terminal object, a frame, or nil (meaning the
2132 selected frame's terminal device). */)
2135 Lisp_Object terminal
;
2138 struct terminal
*t
= get_terminal (terminal
, 1);
2139 push_kboard (t
->kboard
);
2140 result
= Fsymbol_value (symbol
);
2145 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2146 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2147 If VARIABLE is not a terminal-local variable, then set its normal
2148 binding, like `set'.
2150 TERMINAL may be a terminal object, a frame, or nil (meaning the
2151 selected frame's terminal device). */)
2152 (symbol
, terminal
, value
)
2154 Lisp_Object terminal
;
2158 struct terminal
*t
= get_terminal (terminal
, 1);
2159 push_kboard (d
->kboard
);
2160 result
= Fset (symbol
, value
);
2166 /* Find the function at the end of a chain of symbol function indirections. */
2168 /* If OBJECT is a symbol, find the end of its function chain and
2169 return the value found there. If OBJECT is not a symbol, just
2170 return it. If there is a cycle in the function chain, signal a
2171 cyclic-function-indirection error.
2173 This is like Findirect_function, except that it doesn't signal an
2174 error if the chain ends up unbound. */
2176 indirect_function (object
)
2177 register Lisp_Object object
;
2179 Lisp_Object tortoise
, hare
;
2181 hare
= tortoise
= object
;
2185 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2187 hare
= XSYMBOL (hare
)->function
;
2188 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2190 hare
= XSYMBOL (hare
)->function
;
2192 tortoise
= XSYMBOL (tortoise
)->function
;
2194 if (EQ (hare
, tortoise
))
2195 xsignal1 (Qcyclic_function_indirection
, object
);
2201 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2202 doc
: /* Return the function at the end of OBJECT's function chain.
2203 If OBJECT is not a symbol, just return it. Otherwise, follow all
2204 function indirections to find the final function binding and return it.
2205 If the final symbol in the chain is unbound, signal a void-function error.
2206 Optional arg NOERROR non-nil means to return nil instead of signalling.
2207 Signal a cyclic-function-indirection error if there is a loop in the
2208 function chain of symbols. */)
2210 register Lisp_Object object
;
2211 Lisp_Object noerror
;
2215 /* Optimize for no indirection. */
2217 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2218 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2219 result
= indirect_function (result
);
2220 if (!EQ (result
, Qunbound
))
2224 xsignal1 (Qvoid_function
, object
);
2229 /* Extract and set vector and string elements */
2231 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2232 doc
: /* Return the element of ARRAY at index IDX.
2233 ARRAY may be a vector, a string, a char-table, a bool-vector,
2234 or a byte-code object. IDX starts at 0. */)
2236 register Lisp_Object array
;
2239 register int idxval
;
2242 idxval
= XINT (idx
);
2243 if (STRINGP (array
))
2247 if (idxval
< 0 || idxval
>= SCHARS (array
))
2248 args_out_of_range (array
, idx
);
2249 if (! STRING_MULTIBYTE (array
))
2250 return make_number ((unsigned char) SREF (array
, idxval
));
2251 idxval_byte
= string_char_to_byte (array
, idxval
);
2253 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2254 return make_number (c
);
2256 else if (BOOL_VECTOR_P (array
))
2260 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2261 args_out_of_range (array
, idx
);
2263 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2264 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2266 else if (CHAR_TABLE_P (array
))
2268 CHECK_CHARACTER (idx
);
2269 return CHAR_TABLE_REF (array
, idxval
);
2274 if (VECTORP (array
))
2275 size
= XVECTOR (array
)->size
;
2276 else if (COMPILEDP (array
))
2277 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2279 wrong_type_argument (Qarrayp
, array
);
2281 if (idxval
< 0 || idxval
>= size
)
2282 args_out_of_range (array
, idx
);
2283 return XVECTOR (array
)->contents
[idxval
];
2287 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2288 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2289 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2290 bool-vector. IDX starts at 0. */)
2291 (array
, idx
, newelt
)
2292 register Lisp_Object array
;
2293 Lisp_Object idx
, newelt
;
2295 register int idxval
;
2298 idxval
= XINT (idx
);
2299 CHECK_ARRAY (array
, Qarrayp
);
2300 CHECK_IMPURE (array
);
2302 if (VECTORP (array
))
2304 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2305 args_out_of_range (array
, idx
);
2306 XVECTOR (array
)->contents
[idxval
] = newelt
;
2308 else if (BOOL_VECTOR_P (array
))
2312 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2313 args_out_of_range (array
, idx
);
2315 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2317 if (! NILP (newelt
))
2318 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2320 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2321 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2323 else if (CHAR_TABLE_P (array
))
2325 CHECK_CHARACTER (idx
);
2326 CHAR_TABLE_SET (array
, idxval
, newelt
);
2328 else if (STRING_MULTIBYTE (array
))
2330 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2331 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2333 if (idxval
< 0 || idxval
>= SCHARS (array
))
2334 args_out_of_range (array
, idx
);
2335 CHECK_CHARACTER (newelt
);
2337 nbytes
= SBYTES (array
);
2339 idxval_byte
= string_char_to_byte (array
, idxval
);
2340 p1
= SDATA (array
) + idxval_byte
;
2341 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2342 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2343 if (prev_bytes
!= new_bytes
)
2345 /* We must relocate the string data. */
2346 int nchars
= SCHARS (array
);
2350 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2351 bcopy (SDATA (array
), str
, nbytes
);
2352 allocate_string_data (XSTRING (array
), nchars
,
2353 nbytes
+ new_bytes
- prev_bytes
);
2354 bcopy (str
, SDATA (array
), idxval_byte
);
2355 p1
= SDATA (array
) + idxval_byte
;
2356 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2357 nbytes
- (idxval_byte
+ prev_bytes
));
2359 clear_string_char_byte_cache ();
2366 if (idxval
< 0 || idxval
>= SCHARS (array
))
2367 args_out_of_range (array
, idx
);
2368 CHECK_NUMBER (newelt
);
2370 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2374 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2375 if (SREF (array
, i
) >= 0x80)
2376 args_out_of_range (array
, newelt
);
2377 /* ARRAY is an ASCII string. Convert it to a multibyte
2378 string, and try `aset' again. */
2379 STRING_SET_MULTIBYTE (array
);
2380 return Faset (array
, idx
, newelt
);
2382 SSET (array
, idxval
, XINT (newelt
));
2388 /* Arithmetic functions */
2390 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2393 arithcompare (num1
, num2
, comparison
)
2394 Lisp_Object num1
, num2
;
2395 enum comparison comparison
;
2397 double f1
= 0, f2
= 0;
2400 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2401 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2403 if (FLOATP (num1
) || FLOATP (num2
))
2406 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2407 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2413 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2418 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2423 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2428 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2433 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2438 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2447 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2448 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2450 register Lisp_Object num1
, num2
;
2452 return arithcompare (num1
, num2
, equal
);
2455 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2456 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2458 register Lisp_Object num1
, num2
;
2460 return arithcompare (num1
, num2
, less
);
2463 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2464 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2466 register Lisp_Object num1
, num2
;
2468 return arithcompare (num1
, num2
, grtr
);
2471 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2472 doc
: /* Return t if first arg is less than or equal to second arg.
2473 Both must be numbers or markers. */)
2475 register Lisp_Object num1
, num2
;
2477 return arithcompare (num1
, num2
, less_or_equal
);
2480 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2481 doc
: /* Return t if first arg is greater than or equal to second arg.
2482 Both must be numbers or markers. */)
2484 register Lisp_Object num1
, num2
;
2486 return arithcompare (num1
, num2
, grtr_or_equal
);
2489 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2490 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2492 register Lisp_Object num1
, num2
;
2494 return arithcompare (num1
, num2
, notequal
);
2497 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2498 doc
: /* Return t if NUMBER is zero. */)
2500 register Lisp_Object number
;
2502 CHECK_NUMBER_OR_FLOAT (number
);
2504 if (FLOATP (number
))
2506 if (XFLOAT_DATA (number
) == 0.0)
2516 /* Convert between long values and pairs of Lisp integers.
2517 Note that long_to_cons returns a single Lisp integer
2518 when the value fits in one. */
2524 unsigned long top
= i
>> 16;
2525 unsigned int bot
= i
& 0xFFFF;
2527 return make_number (bot
);
2528 if (top
== (unsigned long)-1 >> 16)
2529 return Fcons (make_number (-1), make_number (bot
));
2530 return Fcons (make_number (top
), make_number (bot
));
2537 Lisp_Object top
, bot
;
2544 return ((XINT (top
) << 16) | XINT (bot
));
2547 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2548 doc
: /* Return the decimal representation of NUMBER as a string.
2549 Uses a minus sign if negative.
2550 NUMBER may be an integer or a floating point number. */)
2554 char buffer
[VALBITS
];
2556 CHECK_NUMBER_OR_FLOAT (number
);
2558 if (FLOATP (number
))
2560 char pigbuf
[350]; /* see comments in float_to_string */
2562 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2563 return build_string (pigbuf
);
2566 if (sizeof (int) == sizeof (EMACS_INT
))
2567 sprintf (buffer
, "%d", (int) XINT (number
));
2568 else if (sizeof (long) == sizeof (EMACS_INT
))
2569 sprintf (buffer
, "%ld", (long) XINT (number
));
2572 return build_string (buffer
);
2576 digit_to_number (character
, base
)
2577 int character
, base
;
2581 if (character
>= '0' && character
<= '9')
2582 digit
= character
- '0';
2583 else if (character
>= 'a' && character
<= 'z')
2584 digit
= character
- 'a' + 10;
2585 else if (character
>= 'A' && character
<= 'Z')
2586 digit
= character
- 'A' + 10;
2596 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2597 doc
: /* Parse STRING as a decimal number and return the number.
2598 This parses both integers and floating point numbers.
2599 It ignores leading spaces and tabs, and all trailing chars.
2601 If BASE, interpret STRING as a number in that base. If BASE isn't
2602 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2603 If the base used is not 10, STRING is always parsed as integer. */)
2605 register Lisp_Object string
, base
;
2607 register unsigned char *p
;
2612 CHECK_STRING (string
);
2618 CHECK_NUMBER (base
);
2620 if (b
< 2 || b
> 16)
2621 xsignal1 (Qargs_out_of_range
, base
);
2624 /* Skip any whitespace at the front of the number. Some versions of
2625 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2627 while (*p
== ' ' || *p
== '\t')
2638 if (isfloat_string (p
, 1) && b
== 10)
2639 val
= make_float (sign
* atof (p
));
2646 int digit
= digit_to_number (*p
++, b
);
2652 val
= make_fixnum_or_float (sign
* v
);
2672 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2673 int, Lisp_Object
*));
2674 extern Lisp_Object
fmod_float ();
2677 arith_driver (code
, nargs
, args
)
2680 register Lisp_Object
*args
;
2682 register Lisp_Object val
;
2683 register int argnum
;
2684 register EMACS_INT accum
= 0;
2685 register EMACS_INT next
;
2687 switch (SWITCH_ENUM_CAST (code
))
2705 for (argnum
= 0; argnum
< nargs
; argnum
++)
2707 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2709 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2712 return float_arith_driver ((double) accum
, argnum
, code
,
2715 next
= XINT (args
[argnum
]);
2716 switch (SWITCH_ENUM_CAST (code
))
2722 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2733 xsignal0 (Qarith_error
);
2747 if (!argnum
|| next
> accum
)
2751 if (!argnum
|| next
< accum
)
2757 XSETINT (val
, accum
);
2762 #define isnan(x) ((x) != (x))
2765 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2767 register int argnum
;
2770 register Lisp_Object
*args
;
2772 register Lisp_Object val
;
2775 for (; argnum
< nargs
; argnum
++)
2777 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2778 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2782 next
= XFLOAT_DATA (val
);
2786 args
[argnum
] = val
; /* runs into a compiler bug. */
2787 next
= XINT (args
[argnum
]);
2789 switch (SWITCH_ENUM_CAST (code
))
2795 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2805 if (! IEEE_FLOATING_POINT
&& next
== 0)
2806 xsignal0 (Qarith_error
);
2813 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2815 if (!argnum
|| isnan (next
) || next
> accum
)
2819 if (!argnum
|| isnan (next
) || next
< accum
)
2825 return make_float (accum
);
2829 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2830 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2831 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2836 return arith_driver (Aadd
, nargs
, args
);
2839 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2840 doc
: /* Negate number or subtract numbers or markers and return the result.
2841 With one arg, negates it. With more than one arg,
2842 subtracts all but the first from the first.
2843 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2848 return arith_driver (Asub
, nargs
, args
);
2851 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2852 doc
: /* Return product of any number of arguments, which are numbers or markers.
2853 usage: (* &rest NUMBERS-OR-MARKERS) */)
2858 return arith_driver (Amult
, nargs
, args
);
2861 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2862 doc
: /* Return first argument divided by all the remaining arguments.
2863 The arguments must be numbers or markers.
2864 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2870 for (argnum
= 2; argnum
< nargs
; argnum
++)
2871 if (FLOATP (args
[argnum
]))
2872 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2873 return arith_driver (Adiv
, nargs
, args
);
2876 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2877 doc
: /* Return remainder of X divided by Y.
2878 Both must be integers or markers. */)
2880 register Lisp_Object x
, y
;
2884 CHECK_NUMBER_COERCE_MARKER (x
);
2885 CHECK_NUMBER_COERCE_MARKER (y
);
2887 if (XFASTINT (y
) == 0)
2888 xsignal0 (Qarith_error
);
2890 XSETINT (val
, XINT (x
) % XINT (y
));
2904 /* If the magnitude of the result exceeds that of the divisor, or
2905 the sign of the result does not agree with that of the dividend,
2906 iterate with the reduced value. This does not yield a
2907 particularly accurate result, but at least it will be in the
2908 range promised by fmod. */
2910 r
-= f2
* floor (r
/ f2
);
2911 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2915 #endif /* ! HAVE_FMOD */
2917 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2918 doc
: /* Return X modulo Y.
2919 The result falls between zero (inclusive) and Y (exclusive).
2920 Both X and Y must be numbers or markers. */)
2922 register Lisp_Object x
, y
;
2927 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2928 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2930 if (FLOATP (x
) || FLOATP (y
))
2931 return fmod_float (x
, y
);
2937 xsignal0 (Qarith_error
);
2941 /* If the "remainder" comes out with the wrong sign, fix it. */
2942 if (i2
< 0 ? i1
> 0 : i1
< 0)
2949 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2950 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2951 The value is always a number; markers are converted to numbers.
2952 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2957 return arith_driver (Amax
, nargs
, args
);
2960 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2961 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2962 The value is always a number; markers are converted to numbers.
2963 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2968 return arith_driver (Amin
, nargs
, args
);
2971 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2972 doc
: /* Return bitwise-and of all the arguments.
2973 Arguments may be integers, or markers converted to integers.
2974 usage: (logand &rest INTS-OR-MARKERS) */)
2979 return arith_driver (Alogand
, nargs
, args
);
2982 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2983 doc
: /* Return bitwise-or of all the arguments.
2984 Arguments may be integers, or markers converted to integers.
2985 usage: (logior &rest INTS-OR-MARKERS) */)
2990 return arith_driver (Alogior
, nargs
, args
);
2993 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2994 doc
: /* Return bitwise-exclusive-or of all the arguments.
2995 Arguments may be integers, or markers converted to integers.
2996 usage: (logxor &rest INTS-OR-MARKERS) */)
3001 return arith_driver (Alogxor
, nargs
, args
);
3004 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
3005 doc
: /* Return VALUE with its bits shifted left by COUNT.
3006 If COUNT is negative, shifting is actually to the right.
3007 In this case, the sign bit is duplicated. */)
3009 register Lisp_Object value
, count
;
3011 register Lisp_Object val
;
3013 CHECK_NUMBER (value
);
3014 CHECK_NUMBER (count
);
3016 if (XINT (count
) >= BITS_PER_EMACS_INT
)
3018 else if (XINT (count
) > 0)
3019 XSETINT (val
, XINT (value
) << XFASTINT (count
));
3020 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
3021 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
3023 XSETINT (val
, XINT (value
) >> -XINT (count
));
3027 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
3028 doc
: /* Return VALUE with its bits shifted left by COUNT.
3029 If COUNT is negative, shifting is actually to the right.
3030 In this case, zeros are shifted in on the left. */)
3032 register Lisp_Object value
, count
;
3034 register Lisp_Object val
;
3036 CHECK_NUMBER (value
);
3037 CHECK_NUMBER (count
);
3039 if (XINT (count
) >= BITS_PER_EMACS_INT
)
3041 else if (XINT (count
) > 0)
3042 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
3043 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
3046 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
3050 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3051 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3052 Markers are converted to integers. */)
3054 register Lisp_Object number
;
3056 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3058 if (FLOATP (number
))
3059 return (make_float (1.0 + XFLOAT_DATA (number
)));
3061 XSETINT (number
, XINT (number
) + 1);
3065 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3066 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3067 Markers are converted to integers. */)
3069 register Lisp_Object number
;
3071 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3073 if (FLOATP (number
))
3074 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3076 XSETINT (number
, XINT (number
) - 1);
3080 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3081 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3083 register Lisp_Object number
;
3085 CHECK_NUMBER (number
);
3086 XSETINT (number
, ~XINT (number
));
3090 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3091 doc
: /* Return the byteorder for the machine.
3092 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3093 lowercase l) for small endian machines. */)
3096 unsigned i
= 0x04030201;
3097 int order
= *(char *)&i
== 1 ? 108 : 66;
3099 return make_number (order
);
3107 Lisp_Object error_tail
, arith_tail
;
3109 Qquote
= intern_c_string ("quote");
3110 Qlambda
= intern_c_string ("lambda");
3111 Qsubr
= intern_c_string ("subr");
3112 Qerror_conditions
= intern_c_string ("error-conditions");
3113 Qerror_message
= intern_c_string ("error-message");
3114 Qtop_level
= intern_c_string ("top-level");
3116 Qerror
= intern_c_string ("error");
3117 Qquit
= intern_c_string ("quit");
3118 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3119 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3120 Qvoid_function
= intern_c_string ("void-function");
3121 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3122 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3123 Qvoid_variable
= intern_c_string ("void-variable");
3124 Qsetting_constant
= intern_c_string ("setting-constant");
3125 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3127 Qinvalid_function
= intern_c_string ("invalid-function");
3128 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3129 Qno_catch
= intern_c_string ("no-catch");
3130 Qend_of_file
= intern_c_string ("end-of-file");
3131 Qarith_error
= intern_c_string ("arith-error");
3132 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3133 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3134 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3135 Qtext_read_only
= intern_c_string ("text-read-only");
3136 Qmark_inactive
= intern_c_string ("mark-inactive");
3138 Qlistp
= intern_c_string ("listp");
3139 Qconsp
= intern_c_string ("consp");
3140 Qsymbolp
= intern_c_string ("symbolp");
3141 Qkeywordp
= intern_c_string ("keywordp");
3142 Qintegerp
= intern_c_string ("integerp");
3143 Qnatnump
= intern_c_string ("natnump");
3144 Qwholenump
= intern_c_string ("wholenump");
3145 Qstringp
= intern_c_string ("stringp");
3146 Qarrayp
= intern_c_string ("arrayp");
3147 Qsequencep
= intern_c_string ("sequencep");
3148 Qbufferp
= intern_c_string ("bufferp");
3149 Qvectorp
= intern_c_string ("vectorp");
3150 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3151 Qmarkerp
= intern_c_string ("markerp");
3152 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3153 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3154 Qboundp
= intern_c_string ("boundp");
3155 Qfboundp
= intern_c_string ("fboundp");
3157 Qfloatp
= intern_c_string ("floatp");
3158 Qnumberp
= intern_c_string ("numberp");
3159 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3161 Qchar_table_p
= intern_c_string ("char-table-p");
3162 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3164 Qsubrp
= intern_c_string ("subrp");
3165 Qunevalled
= intern_c_string ("unevalled");
3166 Qmany
= intern_c_string ("many");
3168 Qcdr
= intern_c_string ("cdr");
3170 /* Handle automatic advice activation */
3171 Qad_advice_info
= intern_c_string ("ad-advice-info");
3172 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3174 error_tail
= pure_cons (Qerror
, Qnil
);
3176 /* ERROR is used as a signaler for random errors for which nothing else is right */
3178 Fput (Qerror
, Qerror_conditions
,
3180 Fput (Qerror
, Qerror_message
,
3181 make_pure_c_string ("error"));
3183 Fput (Qquit
, Qerror_conditions
,
3184 pure_cons (Qquit
, Qnil
));
3185 Fput (Qquit
, Qerror_message
,
3186 make_pure_c_string ("Quit"));
3188 Fput (Qwrong_type_argument
, Qerror_conditions
,
3189 pure_cons (Qwrong_type_argument
, error_tail
));
3190 Fput (Qwrong_type_argument
, Qerror_message
,
3191 make_pure_c_string ("Wrong type argument"));
3193 Fput (Qargs_out_of_range
, Qerror_conditions
,
3194 pure_cons (Qargs_out_of_range
, error_tail
));
3195 Fput (Qargs_out_of_range
, Qerror_message
,
3196 make_pure_c_string ("Args out of range"));
3198 Fput (Qvoid_function
, Qerror_conditions
,
3199 pure_cons (Qvoid_function
, error_tail
));
3200 Fput (Qvoid_function
, Qerror_message
,
3201 make_pure_c_string ("Symbol's function definition is void"));
3203 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3204 pure_cons (Qcyclic_function_indirection
, error_tail
));
3205 Fput (Qcyclic_function_indirection
, Qerror_message
,
3206 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3208 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3209 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3210 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3211 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3213 Qcircular_list
= intern_c_string ("circular-list");
3214 staticpro (&Qcircular_list
);
3215 Fput (Qcircular_list
, Qerror_conditions
,
3216 pure_cons (Qcircular_list
, error_tail
));
3217 Fput (Qcircular_list
, Qerror_message
,
3218 make_pure_c_string ("List contains a loop"));
3220 Fput (Qvoid_variable
, Qerror_conditions
,
3221 pure_cons (Qvoid_variable
, error_tail
));
3222 Fput (Qvoid_variable
, Qerror_message
,
3223 make_pure_c_string ("Symbol's value as variable is void"));
3225 Fput (Qsetting_constant
, Qerror_conditions
,
3226 pure_cons (Qsetting_constant
, error_tail
));
3227 Fput (Qsetting_constant
, Qerror_message
,
3228 make_pure_c_string ("Attempt to set a constant symbol"));
3230 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3231 pure_cons (Qinvalid_read_syntax
, error_tail
));
3232 Fput (Qinvalid_read_syntax
, Qerror_message
,
3233 make_pure_c_string ("Invalid read syntax"));
3235 Fput (Qinvalid_function
, Qerror_conditions
,
3236 pure_cons (Qinvalid_function
, error_tail
));
3237 Fput (Qinvalid_function
, Qerror_message
,
3238 make_pure_c_string ("Invalid function"));
3240 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3241 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3242 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3243 make_pure_c_string ("Wrong number of arguments"));
3245 Fput (Qno_catch
, Qerror_conditions
,
3246 pure_cons (Qno_catch
, error_tail
));
3247 Fput (Qno_catch
, Qerror_message
,
3248 make_pure_c_string ("No catch for tag"));
3250 Fput (Qend_of_file
, Qerror_conditions
,
3251 pure_cons (Qend_of_file
, error_tail
));
3252 Fput (Qend_of_file
, Qerror_message
,
3253 make_pure_c_string ("End of file during parsing"));
3255 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3256 Fput (Qarith_error
, Qerror_conditions
,
3258 Fput (Qarith_error
, Qerror_message
,
3259 make_pure_c_string ("Arithmetic error"));
3261 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3262 pure_cons (Qbeginning_of_buffer
, error_tail
));
3263 Fput (Qbeginning_of_buffer
, Qerror_message
,
3264 make_pure_c_string ("Beginning of buffer"));
3266 Fput (Qend_of_buffer
, Qerror_conditions
,
3267 pure_cons (Qend_of_buffer
, error_tail
));
3268 Fput (Qend_of_buffer
, Qerror_message
,
3269 make_pure_c_string ("End of buffer"));
3271 Fput (Qbuffer_read_only
, Qerror_conditions
,
3272 pure_cons (Qbuffer_read_only
, error_tail
));
3273 Fput (Qbuffer_read_only
, Qerror_message
,
3274 make_pure_c_string ("Buffer is read-only"));
3276 Fput (Qtext_read_only
, Qerror_conditions
,
3277 pure_cons (Qtext_read_only
, error_tail
));
3278 Fput (Qtext_read_only
, Qerror_message
,
3279 make_pure_c_string ("Text is read-only"));
3281 Qrange_error
= intern_c_string ("range-error");
3282 Qdomain_error
= intern_c_string ("domain-error");
3283 Qsingularity_error
= intern_c_string ("singularity-error");
3284 Qoverflow_error
= intern_c_string ("overflow-error");
3285 Qunderflow_error
= intern_c_string ("underflow-error");
3287 Fput (Qdomain_error
, Qerror_conditions
,
3288 pure_cons (Qdomain_error
, arith_tail
));
3289 Fput (Qdomain_error
, Qerror_message
,
3290 make_pure_c_string ("Arithmetic domain error"));
3292 Fput (Qrange_error
, Qerror_conditions
,
3293 pure_cons (Qrange_error
, arith_tail
));
3294 Fput (Qrange_error
, Qerror_message
,
3295 make_pure_c_string ("Arithmetic range error"));
3297 Fput (Qsingularity_error
, Qerror_conditions
,
3298 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3299 Fput (Qsingularity_error
, Qerror_message
,
3300 make_pure_c_string ("Arithmetic singularity error"));
3302 Fput (Qoverflow_error
, Qerror_conditions
,
3303 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3304 Fput (Qoverflow_error
, Qerror_message
,
3305 make_pure_c_string ("Arithmetic overflow error"));
3307 Fput (Qunderflow_error
, Qerror_conditions
,
3308 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3309 Fput (Qunderflow_error
, Qerror_message
,
3310 make_pure_c_string ("Arithmetic underflow error"));
3312 staticpro (&Qrange_error
);
3313 staticpro (&Qdomain_error
);
3314 staticpro (&Qsingularity_error
);
3315 staticpro (&Qoverflow_error
);
3316 staticpro (&Qunderflow_error
);
3320 staticpro (&Qquote
);
3321 staticpro (&Qlambda
);
3323 staticpro (&Qunbound
);
3324 staticpro (&Qerror_conditions
);
3325 staticpro (&Qerror_message
);
3326 staticpro (&Qtop_level
);
3328 staticpro (&Qerror
);
3330 staticpro (&Qwrong_type_argument
);
3331 staticpro (&Qargs_out_of_range
);
3332 staticpro (&Qvoid_function
);
3333 staticpro (&Qcyclic_function_indirection
);
3334 staticpro (&Qcyclic_variable_indirection
);
3335 staticpro (&Qvoid_variable
);
3336 staticpro (&Qsetting_constant
);
3337 staticpro (&Qinvalid_read_syntax
);
3338 staticpro (&Qwrong_number_of_arguments
);
3339 staticpro (&Qinvalid_function
);
3340 staticpro (&Qno_catch
);
3341 staticpro (&Qend_of_file
);
3342 staticpro (&Qarith_error
);
3343 staticpro (&Qbeginning_of_buffer
);
3344 staticpro (&Qend_of_buffer
);
3345 staticpro (&Qbuffer_read_only
);
3346 staticpro (&Qtext_read_only
);
3347 staticpro (&Qmark_inactive
);
3349 staticpro (&Qlistp
);
3350 staticpro (&Qconsp
);
3351 staticpro (&Qsymbolp
);
3352 staticpro (&Qkeywordp
);
3353 staticpro (&Qintegerp
);
3354 staticpro (&Qnatnump
);
3355 staticpro (&Qwholenump
);
3356 staticpro (&Qstringp
);
3357 staticpro (&Qarrayp
);
3358 staticpro (&Qsequencep
);
3359 staticpro (&Qbufferp
);
3360 staticpro (&Qvectorp
);
3361 staticpro (&Qchar_or_string_p
);
3362 staticpro (&Qmarkerp
);
3363 staticpro (&Qbuffer_or_string_p
);
3364 staticpro (&Qinteger_or_marker_p
);
3365 staticpro (&Qfloatp
);
3366 staticpro (&Qnumberp
);
3367 staticpro (&Qnumber_or_marker_p
);
3368 staticpro (&Qchar_table_p
);
3369 staticpro (&Qvector_or_char_table_p
);
3370 staticpro (&Qsubrp
);
3372 staticpro (&Qunevalled
);
3374 staticpro (&Qboundp
);
3375 staticpro (&Qfboundp
);
3377 staticpro (&Qad_advice_info
);
3378 staticpro (&Qad_activate_internal
);
3380 /* Types that type-of returns. */
3381 Qinteger
= intern_c_string ("integer");
3382 Qsymbol
= intern_c_string ("symbol");
3383 Qstring
= intern_c_string ("string");
3384 Qcons
= intern_c_string ("cons");
3385 Qmarker
= intern_c_string ("marker");
3386 Qoverlay
= intern_c_string ("overlay");
3387 Qfloat
= intern_c_string ("float");
3388 Qwindow_configuration
= intern_c_string ("window-configuration");
3389 Qprocess
= intern_c_string ("process");
3390 Qwindow
= intern_c_string ("window");
3391 /* Qsubr = intern_c_string ("subr"); */
3392 Qcompiled_function
= intern_c_string ("compiled-function");
3393 Qbuffer
= intern_c_string ("buffer");
3394 Qframe
= intern_c_string ("frame");
3395 Qvector
= intern_c_string ("vector");
3396 Qchar_table
= intern_c_string ("char-table");
3397 Qbool_vector
= intern_c_string ("bool-vector");
3398 Qhash_table
= intern_c_string ("hash-table");
3400 Qthread_local_mark
= Fmake_symbol (make_pure_string ("thread-local-mark",
3403 DEFSYM (Qfont_spec
, "font-spec");
3404 DEFSYM (Qfont_entity
, "font-entity");
3405 DEFSYM (Qfont_object
, "font-object");
3407 DEFSYM (Qinteractive_form
, "interactive-form");
3409 staticpro (&Qinteger
);
3410 staticpro (&Qsymbol
);
3411 staticpro (&Qstring
);
3413 staticpro (&Qmarker
);
3414 staticpro (&Qoverlay
);
3415 staticpro (&Qfloat
);
3416 staticpro (&Qwindow_configuration
);
3417 staticpro (&Qprocess
);
3418 staticpro (&Qwindow
);
3419 /* staticpro (&Qsubr); */
3420 staticpro (&Qcompiled_function
);
3421 staticpro (&Qbuffer
);
3422 staticpro (&Qframe
);
3423 staticpro (&Qvector
);
3424 staticpro (&Qchar_table
);
3425 staticpro (&Qbool_vector
);
3426 staticpro (&Qhash_table
);
3427 staticpro (&Qthread_local_mark
);
3429 defsubr (&Sindirect_variable
);
3430 defsubr (&Sinteractive_form
);
3433 defsubr (&Stype_of
);
3438 defsubr (&Sintegerp
);
3439 defsubr (&Sinteger_or_marker_p
);
3440 defsubr (&Snumberp
);
3441 defsubr (&Snumber_or_marker_p
);
3443 defsubr (&Snatnump
);
3444 defsubr (&Ssymbolp
);
3445 defsubr (&Skeywordp
);
3446 defsubr (&Sstringp
);
3447 defsubr (&Smultibyte_string_p
);
3448 defsubr (&Svectorp
);
3449 defsubr (&Schar_table_p
);
3450 defsubr (&Svector_or_char_table_p
);
3451 defsubr (&Sbool_vector_p
);
3453 defsubr (&Ssequencep
);
3454 defsubr (&Sbufferp
);
3455 defsubr (&Smarkerp
);
3457 defsubr (&Sbyte_code_function_p
);
3458 defsubr (&Schar_or_string_p
);
3461 defsubr (&Scar_safe
);
3462 defsubr (&Scdr_safe
);
3465 defsubr (&Ssymbol_function
);
3466 defsubr (&Sindirect_function
);
3467 defsubr (&Ssymbol_plist
);
3468 defsubr (&Ssymbol_name
);
3469 defsubr (&Smakunbound
);
3470 defsubr (&Sfmakunbound
);
3472 defsubr (&Sfboundp
);
3474 defsubr (&Sdefalias
);
3475 defsubr (&Ssetplist
);
3476 defsubr (&Ssymbol_value
);
3478 defsubr (&Sdefault_boundp
);
3479 defsubr (&Sdefault_value
);
3480 defsubr (&Sset_default
);
3481 defsubr (&Ssetq_default
);
3482 defsubr (&Smake_variable_buffer_local
);
3483 defsubr (&Smake_local_variable
);
3484 defsubr (&Skill_local_variable
);
3485 defsubr (&Smake_variable_frame_local
);
3486 defsubr (&Slocal_variable_p
);
3487 defsubr (&Slocal_variable_if_set_p
);
3488 defsubr (&Svariable_binding_locus
);
3489 #if 0 /* XXX Remove this. --lorentey */
3490 defsubr (&Sterminal_local_value
);
3491 defsubr (&Sset_terminal_local_value
);
3495 defsubr (&Snumber_to_string
);
3496 defsubr (&Sstring_to_number
);
3497 defsubr (&Seqlsign
);
3520 defsubr (&Sbyteorder
);
3521 defsubr (&Ssubr_arity
);
3522 defsubr (&Ssubr_name
);
3524 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3526 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3527 doc
: /* The largest value that is representable in a Lisp integer. */);
3528 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3529 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3531 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3532 doc
: /* The smallest value that is representable in a Lisp integer. */);
3533 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3534 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3541 sigsetmask (SIGEMPTYMASK
);
3543 SIGNAL_THREAD_CHECK (signo
);
3544 xsignal0 (Qarith_error
);
3550 /* Don't do this if just dumping out.
3551 We don't want to call `signal' in this case
3552 so that we don't have trouble with dumping
3553 signal-delivering routines in an inconsistent state. */
3557 #endif /* CANNOT_DUMP */
3558 signal (SIGFPE
, arith_error
);
3561 signal (SIGEMT
, arith_error
);
3565 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3566 (do not change this comment) */