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 ***********************************************************************/
811 /* Retrieve the buffer local data for the caller thread. SYMBOL is used only
812 when the specified buffer local value does not have a binding for the thread
813 and a new one must be created. */
816 blocal_get_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object symbol
)
818 Lisp_Object ret
= assq_no_quit (get_current_thread (), l
->thread_data
);
821 Lisp_Object tem
, val
, len
;
823 if (NILP (symbol
) || !initialized
)
826 XSETFASTINT (len
, 4);
827 ret
= Fmake_vector (len
, Qnil
);
829 BLOCAL_CLEAR_FLAGS_VEC (ret
);
830 tem
= Fcons (Qnil
, Qnil
);
831 val
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
832 if (NILP (val
) || (l
->check_frame
&& ! EQ (selected_frame
, Qnil
)))
834 val
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
836 BLOCAL_SET_FOUND_FOR_FRAME_VEC (ret
);
839 val
= XTHREADLOCAL (l
->realvalue
)->global
;
847 XSETCDR (tem
, XTHREADLOCAL (l
->realvalue
)->global
);
848 BLOCAL_SET_FOUND_FOR_BUFFER_VEC (ret
);
851 BLOCAL_BUFFER_VEC (ret
) = Fcurrent_buffer ();
852 BLOCAL_FRAME_VEC (ret
) = Qnil
;
853 BLOCAL_CDR_VEC (ret
) = tem
;
855 ret
= Fcons (get_current_thread (), ret
);
856 l
->thread_data
= Fcons (ret
, l
->thread_data
);
857 XTHREADLOCAL (l
->realvalue
)->thread_alist
=
858 Fcons (Fcons (get_current_thread (), val
),
859 XTHREADLOCAL (l
->realvalue
)->thread_alist
);
862 return &XCDR_AS_LVALUE (ret
);
865 /* Remove any thread-local data. */
867 blocal_unbind_thread (Lisp_Object thread
)
871 struct Lisp_Vector
*obarray
= XVECTOR (Vobarray
);
872 for (i
= 0; i
< obarray
->size
; i
++)
874 struct Lisp_Symbol
*sym
;
876 if (!SYMBOLP (obarray
->contents
[i
]))
879 sym
= XSYMBOL (obarray
->contents
[i
]);
881 #define UNBIND_LOCAL_VALUE(X) do { \
882 Lisp_Object tem = assq_no_quit (thread, (X)); \
884 (X) = Fdelq (tem, (X)); \
887 if (BUFFER_LOCAL_VALUEP (SYMBOL_VALUE (obarray
->contents
[i
])))
889 struct Lisp_Buffer_Local_Value
*loc
890 = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (obarray
->contents
[i
]));
892 UNBIND_LOCAL_VALUE (loc
->realvalue
);
893 UNBIND_LOCAL_VALUE (loc
->thread_data
);
896 if (THREADLOCALP (SYMBOL_VALUE (obarray
->contents
[i
])))
898 struct Lisp_ThreadLocal
*val
899 = XTHREADLOCAL (SYMBOL_VALUE (obarray
->contents
[i
]));
900 UNBIND_LOCAL_VALUE (val
->thread_alist
);
903 #undef UNBIND_LOCAL_VALUE
907 blocal_set_thread_data (struct Lisp_Buffer_Local_Value
*l
, Lisp_Object obj
)
909 if (! NILP (l
->thread_data
))
912 l
->thread_data
= Fcons (Fcons (get_current_thread (), obj
), Qnil
);
916 find_variable_location (Lisp_Object
*root
)
918 if (THREADLOCALP (*root
))
920 struct Lisp_ThreadLocal
*thr
= XTHREADLOCAL (*root
);
921 Lisp_Object cons
= assq_no_quit (get_current_thread (),
923 if (!EQ (cons
, Qnil
))
924 return &XCDR_AS_LVALUE (cons
);
933 ensure_thread_local (Lisp_Object
*root
)
937 if (THREADLOCALP (*root
))
938 cons
= assq_no_quit (get_current_thread (),
939 XTHREADLOCAL (*root
)->thread_alist
);
943 newval
= allocate_misc ();
944 XMISCTYPE (newval
) = Lisp_Misc_ThreadLocal
;
945 XTHREADLOCAL (newval
)->global
= *root
;
946 XTHREADLOCAL (newval
)->thread_alist
= Qnil
;
953 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
954 cons
= Fcons (get_current_thread (), Qthread_local_mark
);
955 local
->thread_alist
= Fcons (cons
, local
->thread_alist
);
962 remove_thread_local (Lisp_Object
*root
)
964 if (THREADLOCALP (*root
))
966 Lisp_Object iter
, thr
= get_current_thread (), prior
= Qnil
;
967 struct Lisp_ThreadLocal
*local
= XTHREADLOCAL (*root
);
968 for (iter
= local
->thread_alist
; !NILP (iter
); iter
= XCDR (iter
))
970 if (EQ (XCAR (XCAR (iter
)), thr
))
973 local
->thread_alist
= XCDR (iter
);
975 XSETCDR (prior
, XCDR (iter
));
983 /* Return the symbol holding SYMBOL's value. Signal
984 `cyclic-variable-indirection' if SYMBOL's chain of variable
985 indirections contains a loop. */
988 indirect_variable (symbol
)
989 struct Lisp_Symbol
*symbol
;
991 struct Lisp_Symbol
*tortoise
, *hare
;
993 hare
= tortoise
= symbol
;
995 while (hare
->indirect_variable
)
997 hare
= XSYMBOL (hare
->value
);
998 if (!hare
->indirect_variable
)
1001 hare
= XSYMBOL (hare
->value
);
1002 tortoise
= XSYMBOL (tortoise
->value
);
1004 if (hare
== tortoise
)
1007 XSETSYMBOL (tem
, symbol
);
1008 xsignal1 (Qcyclic_variable_indirection
, tem
);
1016 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
1017 doc
: /* Return the variable at the end of OBJECT's variable chain.
1018 If OBJECT is a symbol, follow all variable indirections and return the final
1019 variable. If OBJECT is not a symbol, just return it.
1020 Signal a cyclic-variable-indirection error if there is a loop in the
1021 variable chain of symbols. */)
1025 if (SYMBOLP (object
))
1026 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
1031 /* Given the raw contents of a symbol value cell,
1032 return the Lisp value of the symbol.
1033 This does not handle buffer-local variables; use
1034 swap_in_symval_forwarding for that. */
1037 do_symval_forwarding (valcontents
)
1038 Lisp_Object valcontents
;
1040 register Lisp_Object val
;
1041 if (MISCP (valcontents
))
1042 switch (XMISCTYPE (valcontents
))
1044 case Lisp_Misc_Intfwd
:
1045 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1048 case Lisp_Misc_Boolfwd
:
1049 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1051 case Lisp_Misc_Objfwd
:
1052 return *XOBJFWD (valcontents
)->objvar
;
1054 case Lisp_Misc_Buffer_Objfwd
:
1055 return PER_BUFFER_VALUE (current_buffer
,
1056 XBUFFER_OBJFWD (valcontents
)->offset
);
1058 case Lisp_Misc_Kboard_Objfwd
:
1059 /* We used to simply use current_kboard here, but from Lisp
1060 code, it's value is often unexpected. It seems nicer to
1061 allow constructions like this to work as intuitively expected:
1063 (with-selected-frame frame
1064 (define-key local-function-map "\eOP" [f1]))
1066 On the other hand, this affects the semantics of
1067 last-command and real-last-command, and people may rely on
1068 that. I took a quick look at the Lisp codebase, and I
1069 don't think anything will break. --lorentey */
1070 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1071 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1073 case Lisp_Misc_ThreadLocal
:
1074 return *find_variable_location (&valcontents
);
1079 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
1080 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
1081 buffer-independent contents of the value cell: forwarded just one
1082 step past the buffer-localness.
1084 BUF non-zero means set the value in buffer BUF instead of the
1085 current buffer. This only plays a role for per-buffer variables. */
1088 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
1090 register Lisp_Object valcontents
, newval
;
1093 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
1096 switch (XMISCTYPE (valcontents
))
1098 case Lisp_Misc_Intfwd
:
1099 CHECK_NUMBER (newval
);
1100 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
1101 /* This can never happen since intvar points to an EMACS_INT
1102 which is at least large enough to hold a Lisp_Object.
1103 if (*XINTFWD (valcontents)->intvar != XINT (newval))
1104 error ("Value out of range for variable `%s'",
1105 SDATA (SYMBOL_NAME (symbol))); */
1108 case Lisp_Misc_Boolfwd
:
1109 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
1112 case Lisp_Misc_Objfwd
:
1113 *find_variable_location (XOBJFWD (valcontents
)->objvar
) = newval
;
1115 /* If this variable is a default for something stored
1116 in the buffer itself, such as default-fill-column,
1117 find the buffers that don't have local values for it
1119 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
1120 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
1122 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
1123 - (char *) &buffer_defaults
);
1124 int idx
= PER_BUFFER_IDX (offset
);
1131 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
1136 buf
= Fcdr (XCAR (tail
));
1137 if (!BUFFERP (buf
)) continue;
1140 if (! PER_BUFFER_VALUE_P (b
, idx
))
1141 SET_PER_BUFFER_VALUE_RAW (b
, offset
, newval
);
1146 case Lisp_Misc_Buffer_Objfwd
:
1148 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1149 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1151 if (!(NILP (type
) || NILP (newval
)
1152 || (XINT (type
) == LISP_INT_TAG
1154 : XTYPE (newval
) == XINT (type
))))
1155 buffer_slot_type_mismatch (newval
, XINT (type
));
1158 buf
= current_buffer
;
1159 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1163 case Lisp_Misc_Kboard_Objfwd
:
1165 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1166 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1167 *(Lisp_Object
*) p
= newval
;
1178 valcontents
= SYMBOL_VALUE (symbol
);
1179 if (BUFFER_LOCAL_VALUEP (valcontents
))
1181 Lisp_Object v
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1182 if (! let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1185 for (it
= XBUFFER_LOCAL_VALUE (valcontents
)->thread_data
;
1186 !NILP (it
); it
= XCDR (it
))
1188 Lisp_Object head
= XCDR (XCAR (it
));
1189 if (EQ (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)),
1190 BLOCAL_BUFFER_VEC (head
))
1191 && (! XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1192 || EQ (selected_frame
, BLOCAL_FRAME_VEC (head
))))
1195 = XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1196 Fsetcdr (assq_no_quit (XCAR (XCAR (it
)),
1197 XTHREADLOCAL (rv
)->thread_alist
),
1199 Fsetcdr (XCAR (BLOCAL_CDR_VEC (head
)), newval
);
1203 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)) = newval
;
1205 else if (THREADLOCALP (valcontents
))
1207 Lisp_Object val
= indirect_variable (XSYMBOL (symbol
))->value
;
1208 val
= ensure_thread_local (&val
);
1209 XSETCDR (val
, newval
);
1212 SET_SYMBOL_VALUE (symbol
, newval
);
1216 /* Set up SYMBOL to refer to its global binding.
1217 This makes it safe to alter the status of other bindings. */
1220 swap_in_global_binding (symbol
)
1223 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1224 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1225 Lisp_Object cdr
= BLOCAL_CDR (blv
);
1227 /* Unload the previously loaded binding. */
1228 Fsetcdr (XCAR (cdr
),
1229 do_symval_forwarding (BLOCAL_REALVALUE (blv
)));
1231 /* Select the global binding in the symbol. */
1233 store_symval_forwarding (symbol
, BLOCAL_REALVALUE (blv
), XCDR (cdr
), NULL
);
1235 /* Indicate that the global binding is set up now. */
1236 BLOCAL_FRAME (blv
) = Qnil
;
1237 BLOCAL_BUFFER (blv
) = Qnil
;
1238 BLOCAL_CLEAR_FLAGS (blv
);
1241 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1242 VALCONTENTS is the contents of its value cell,
1243 which points to a struct Lisp_Buffer_Local_Value.
1245 Return the value forwarded one step past the buffer-local stage.
1246 This could be another forwarding pointer. */
1249 swap_in_symval_forwarding (symbol
, valcontents
)
1250 Lisp_Object symbol
, valcontents
;
1252 register Lisp_Object tem1
;
1254 struct Lisp_Buffer_Local_Value
*local
= XBUFFER_LOCAL_VALUE (valcontents
);
1255 blocal_get_thread_data (local
, symbol
);
1256 tem1
= BLOCAL_BUFFER (local
);
1259 || current_buffer
!= XBUFFER (tem1
)
1260 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1261 && ! EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))))
1263 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1264 if (sym
->indirect_variable
)
1266 sym
= indirect_variable (sym
);
1267 XSETSYMBOL (symbol
, sym
);
1270 /* Unload the previously loaded binding. */
1271 tem1
= XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1273 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1275 /* Choose the new binding. */
1276 tem1
= assq_no_quit (symbol
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1277 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1280 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1281 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1283 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1285 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1288 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1290 /* Load the new binding. */
1291 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1292 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), current_buffer
);
1293 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1294 store_symval_forwarding (symbol
,
1295 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1299 return BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1303 /* Find the value of a symbol, returning Qunbound if it's not bound.
1304 This is helpful for code which just wants to get a variable's value
1305 if it has one, without signaling an error.
1306 Note that it must not be possible to quit
1307 within this function. Great care is required for this. */
1310 find_symbol_value (symbol
)
1313 register Lisp_Object valcontents
;
1314 register Lisp_Object val
;
1316 CHECK_SYMBOL (symbol
);
1317 valcontents
= SYMBOL_VALUE (symbol
);
1319 if (BUFFER_LOCAL_VALUEP (valcontents
))
1320 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1322 return do_symval_forwarding (valcontents
);
1325 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1326 doc
: /* Return SYMBOL's value. Error if that is void. */)
1332 val
= find_symbol_value (symbol
);
1333 if (!EQ (val
, Qunbound
))
1336 xsignal1 (Qvoid_variable
, symbol
);
1339 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1340 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1342 register Lisp_Object symbol
, newval
;
1344 return set_internal (symbol
, newval
, current_buffer
, 0);
1347 /* Return 1 if SYMBOL currently has a let-binding
1348 which was made in the buffer that is now current. */
1351 let_shadows_buffer_binding_p (symbol
)
1352 struct Lisp_Symbol
*symbol
;
1354 volatile struct specbinding
*p
;
1356 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1358 && CONSP (p
->symbol
))
1360 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1361 if ((symbol
== let_bound_symbol
1362 || (let_bound_symbol
->indirect_variable
1363 && symbol
== indirect_variable (let_bound_symbol
)))
1364 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1368 return p
>= specpdl
;
1371 /* Store the value NEWVAL into SYMBOL.
1372 If buffer-locality is an issue, BUF specifies which buffer to use.
1373 (0 stands for the current buffer.)
1375 If BINDFLAG is zero, then if this symbol is supposed to become
1376 local in every buffer where it is set, then we make it local.
1377 If BINDFLAG is nonzero, we don't do that. */
1380 set_internal (symbol
, newval
, buf
, bindflag
)
1381 register Lisp_Object symbol
, newval
;
1385 int voide
= EQ (newval
, Qunbound
);
1387 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1390 buf
= current_buffer
;
1392 /* If restoring in a dead buffer, do nothing. */
1393 if (NILP (BUF_NAME (buf
)))
1396 CHECK_SYMBOL (symbol
);
1397 if (SYMBOL_CONSTANT_P (symbol
)
1398 && (NILP (Fkeywordp (symbol
))
1399 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1400 xsignal1 (Qsetting_constant
, symbol
);
1402 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1404 if (BUFFER_OBJFWDP (valcontents
))
1406 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1407 int idx
= PER_BUFFER_IDX (offset
);
1410 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1411 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1413 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1415 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1416 if (XSYMBOL (symbol
)->indirect_variable
)
1417 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1419 blocal_get_thread_data (XBUFFER_LOCAL_VALUE (valcontents
), symbol
);
1421 /* What binding is loaded right now? */
1422 current_alist_element
1423 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1425 /* If the current buffer is not the buffer whose binding is
1426 loaded, or if there may be frame-local bindings and the frame
1427 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1428 the default binding is loaded, the loaded binding may be the
1430 if (!BUFFERP (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1431 || buf
!= XBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)))
1432 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1433 && !EQ (selected_frame
, BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
))))
1434 /* Also unload a global binding (if the var is local_if_set). */
1435 || (EQ (XCAR (current_alist_element
),
1436 current_alist_element
)))
1438 /* The currently loaded binding is not necessarily valid.
1439 We need to unload it, and choose a new binding. */
1441 /* Write out `realvalue' to the old loaded binding. */
1442 Fsetcdr (current_alist_element
,
1443 do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
))));
1445 /* Find the new binding. */
1446 tem1
= Fassq (symbol
, BUF_LOCAL_VAR_ALIST (buf
));
1447 BLOCAL_SET_FOUND_FOR_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1451 /* This buffer still sees the default value. */
1453 /* If the variable is not local_if_set,
1454 or if this is `let' rather than `set',
1455 make CURRENT-ALIST-ELEMENT point to itself,
1456 indicating that we're seeing the default value.
1457 Likewise if the variable has been let-bound
1458 in the current buffer. */
1459 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1460 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1462 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1464 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1465 tem1
= Fassq (symbol
,
1466 XFRAME (selected_frame
)->param_alist
);
1469 BLOCAL_SET_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
1471 tem1
= BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
));
1473 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1474 and we're not within a let that was made for this buffer,
1475 create a new buffer-local binding for the variable.
1476 That means, give this buffer a new assoc for a local value
1477 and load that binding. */
1480 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1481 BUF_LOCAL_VAR_ALIST (buf
)
1482 = Fcons (tem1
, BUF_LOCAL_VAR_ALIST (buf
));
1486 /* Record which binding is now loaded. */
1487 XSETCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), tem1
);
1489 /* Set `buffer' and `frame' slots for the binding now loaded. */
1490 XSETBUFFER (BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
)), buf
);
1491 BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)) = selected_frame
;
1493 innercontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
));
1495 /* Store the new value in the cons-cell. */
1496 XSETCDR (XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
))), newval
);
1499 /* If storing void (making the symbol void), forward only through
1500 buffer-local indicator, not through Lisp_Objfwd, etc. */
1502 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1504 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1509 /* Access or set a buffer-local symbol's default value. */
1511 /* Return the default value of SYMBOL, but don't check for voidness.
1512 Return Qunbound if it is void. */
1515 default_value (symbol
)
1518 register Lisp_Object valcontents
;
1520 CHECK_SYMBOL (symbol
);
1521 valcontents
= SYMBOL_VALUE (symbol
);
1523 /* For a built-in buffer-local variable, get the default value
1524 rather than letting do_symval_forwarding get the current value. */
1525 if (BUFFER_OBJFWDP (valcontents
))
1527 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1528 if (PER_BUFFER_IDX (offset
) != 0)
1529 return PER_BUFFER_DEFAULT (offset
);
1532 /* Handle user-created local variables. */
1533 if (BUFFER_LOCAL_VALUEP (valcontents
))
1535 /* If var is set up for a buffer that lacks a local value for it,
1536 the current value is nominally the default value.
1537 But the `realvalue' slot may be more up to date, since
1538 ordinary setq stores just that slot. So use that. */
1539 Lisp_Object current_alist_element
, alist_element_car
;
1541 blocal_get_thread_data (XBUFFER_LOCAL_VALUE (valcontents
), symbol
);
1543 current_alist_element
1544 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1545 alist_element_car
= XCAR (current_alist_element
);
1546 if (EQ (alist_element_car
, current_alist_element
))
1547 return do_symval_forwarding (BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)));
1549 return XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1551 /* For other variables, get the current value. */
1552 return do_symval_forwarding (valcontents
);
1555 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1556 doc
: /* Return t if SYMBOL has a non-void default value.
1557 This is the value that is seen in buffers that do not have their own values
1558 for this variable. */)
1562 register Lisp_Object value
;
1564 value
= default_value (symbol
);
1565 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1568 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1569 doc
: /* Return SYMBOL's default value.
1570 This is the value that is seen in buffers that do not have their own values
1571 for this variable. The default value is meaningful for variables with
1572 local bindings in certain buffers. */)
1576 register Lisp_Object value
;
1578 value
= default_value (symbol
);
1579 if (!EQ (value
, Qunbound
))
1582 xsignal1 (Qvoid_variable
, symbol
);
1585 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1586 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1587 The default value is seen in buffers that do not have their own values
1588 for this variable. */)
1590 Lisp_Object symbol
, value
;
1592 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1594 CHECK_SYMBOL (symbol
);
1595 valcontents
= SYMBOL_VALUE (symbol
);
1597 /* Handle variables like case-fold-search that have special slots
1598 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1600 if (BUFFER_OBJFWDP (valcontents
))
1602 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1603 int idx
= PER_BUFFER_IDX (offset
);
1605 PER_BUFFER_DEFAULT (offset
) = value
;
1607 /* If this variable is not always local in all buffers,
1608 set it in the buffers that don't nominally have a local value. */
1613 for (b
= all_buffers
; b
; b
= b
->next
)
1614 if (!PER_BUFFER_VALUE_P (b
, idx
))
1615 PER_BUFFER_VALUE (b
, offset
) = value
;
1620 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1621 return Fset (symbol
, value
);
1623 /* Store new value into the DEFAULT-VALUE slot. */
1624 XSETCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)), value
);
1626 /* If the default binding is now loaded, set the REALVALUE slot too. */
1627 current_alist_element
1628 = XCAR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (valcontents
)));
1629 alist_element_buffer
= Fcar (current_alist_element
);
1630 if (EQ (alist_element_buffer
, current_alist_element
))
1631 store_symval_forwarding (symbol
,
1632 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (valcontents
)),
1638 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1639 doc
: /* Set the default value of variable VAR to VALUE.
1640 VAR, the variable name, is literal (not evaluated);
1641 VALUE is an expression: it is evaluated and its value returned.
1642 The default value of a variable is seen in buffers
1643 that do not have their own values for the variable.
1645 More generally, you can use multiple variables and values, as in
1646 (setq-default VAR VALUE VAR VALUE...)
1647 This sets each VAR's default value to the corresponding VALUE.
1648 The VALUE for the Nth VAR can refer to the new default values
1650 usage: (setq-default [VAR VALUE]...) */)
1654 register Lisp_Object args_left
;
1655 register Lisp_Object val
, symbol
;
1656 struct gcpro gcpro1
;
1666 val
= Feval (Fcar (Fcdr (args_left
)));
1667 symbol
= XCAR (args_left
);
1668 Fset_default (symbol
, val
);
1669 args_left
= Fcdr (XCDR (args_left
));
1671 while (!NILP (args_left
));
1677 /* Lisp functions for creating and removing buffer-local variables. */
1679 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1680 1, 1, "vMake Variable Buffer Local: ",
1681 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1682 At any time, the value for the current buffer is in effect,
1683 unless the variable has never been set in this buffer,
1684 in which case the default value is in effect.
1685 Note that binding the variable with `let', or setting it while
1686 a `let'-style binding made in this buffer is in effect,
1687 does not make the variable buffer-local. Return VARIABLE.
1689 In most cases it is better to use `make-local-variable',
1690 which makes a variable local in just one buffer.
1692 The function `default-value' gets the default value and `set-default' sets it. */)
1694 register Lisp_Object variable
;
1696 register Lisp_Object tem
, valcontents
, newval
;
1697 struct Lisp_Symbol
*sym
;
1699 CHECK_SYMBOL (variable
);
1700 sym
= indirect_variable (XSYMBOL (variable
));
1702 valcontents
= sym
->value
;
1703 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1704 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1706 if (BUFFER_OBJFWDP (valcontents
))
1708 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1710 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1711 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1712 newval
= valcontents
;
1716 Lisp_Object len
, val_vec
;
1717 XSETFASTINT (len
, 4);
1718 val_vec
= Fmake_vector (len
, Qnil
);
1719 if (EQ (valcontents
, Qunbound
))
1721 tem
= Fcons (Qnil
, valcontents
);
1723 newval
= allocate_misc ();
1724 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1725 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1726 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1727 BLOCAL_BUFFER_VEC (val_vec
) = Fcurrent_buffer ();
1728 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1729 BLOCAL_CDR_VEC (val_vec
) = tem
;
1730 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1731 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1732 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1733 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1734 = Lisp_Misc_ThreadLocal
;
1735 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1737 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1738 = Fcons (Fcons (get_current_thread (), valcontents
), Qnil
);
1739 sym
->value
= newval
;
1741 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1745 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1746 1, 1, "vMake Local Variable: ",
1747 doc
: /* Make VARIABLE have a separate value in the current buffer.
1748 Other buffers will continue to share a common default value.
1749 \(The buffer-local value of VARIABLE starts out as the same value
1750 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1753 If the variable is already arranged to become local when set,
1754 this function causes a local value to exist for this buffer,
1755 just as setting the variable would do.
1757 This function returns VARIABLE, and therefore
1758 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1761 See also `make-variable-buffer-local'.
1763 Do not use `make-local-variable' to make a hook variable buffer-local.
1764 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1766 register Lisp_Object variable
;
1768 register Lisp_Object tem
, valcontents
;
1769 struct Lisp_Symbol
*sym
;
1771 CHECK_SYMBOL (variable
);
1772 sym
= indirect_variable (XSYMBOL (variable
));
1774 valcontents
= sym
->value
;
1775 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1776 || (BUFFER_LOCAL_VALUEP (valcontents
)
1777 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1778 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1780 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1781 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1782 || BUFFER_OBJFWDP (valcontents
))
1784 tem
= Fboundp (variable
);
1786 /* Make sure the symbol has a local value in this particular buffer,
1787 by setting it to the same value it already has. */
1788 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1791 /* Make sure symbol is set up to hold per-buffer values. */
1792 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1794 Lisp_Object newval
, len
, val_vec
;
1795 XSETFASTINT (len
, 4);
1796 val_vec
= Fmake_vector (len
, Qnil
);
1797 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1799 newval
= allocate_misc ();
1800 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1801 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1802 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1803 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1804 BLOCAL_CDR_VEC (val_vec
) = tem
;
1805 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1806 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1807 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1808 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1809 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1810 = Lisp_Misc_ThreadLocal
;
1811 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1813 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1814 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1815 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1816 sym
->value
= newval
;
1818 /* Make sure this buffer has its own value of symbol. */
1819 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1820 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1823 /* Swap out any local binding for some other buffer, and make
1824 sure the current value is permanently recorded, if it's the
1826 find_symbol_value (variable
);
1828 BUF_LOCAL_VAR_ALIST (current_buffer
)
1829 = Fcons (Fcons (variable
, XCDR (BLOCAL_CDR (XBUFFER_LOCAL_VALUE (sym
->value
)))),
1830 BUF_LOCAL_VAR_ALIST (current_buffer
));
1832 /* Make sure symbol does not think it is set up for this buffer;
1833 force it to look once again for this buffer's value. */
1835 Lisp_Object
*pvalbuf
;
1837 valcontents
= sym
->value
;
1839 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1840 if (current_buffer
== XBUFFER (*pvalbuf
))
1842 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1846 /* If the symbol forwards into a C variable, then load the binding
1847 for this buffer now. If C code modifies the variable before we
1848 load the binding in, then that new value will clobber the default
1849 binding the next time we unload it. */
1850 valcontents
= BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (sym
->value
));
1851 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1852 swap_in_symval_forwarding (variable
, sym
->value
);
1857 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1858 1, 1, "vKill Local Variable: ",
1859 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1860 From now on the default value will apply in this buffer. Return VARIABLE. */)
1862 register Lisp_Object variable
;
1864 register Lisp_Object tem
, valcontents
;
1865 struct Lisp_Symbol
*sym
;
1867 CHECK_SYMBOL (variable
);
1868 sym
= indirect_variable (XSYMBOL (variable
));
1870 valcontents
= sym
->value
;
1872 if (BUFFER_OBJFWDP (valcontents
))
1874 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1875 int idx
= PER_BUFFER_IDX (offset
);
1879 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1880 PER_BUFFER_VALUE (current_buffer
, offset
)
1881 = PER_BUFFER_DEFAULT (offset
);
1886 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1889 /* Get rid of this buffer's alist element, if any. */
1890 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1891 tem
= Fassq (variable
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1893 BUF_LOCAL_VAR_ALIST (current_buffer
)
1894 = Fdelq (tem
, BUF_LOCAL_VAR_ALIST (current_buffer
));
1896 /* If the symbol is set up with the current buffer's binding
1897 loaded, recompute its value. We have to do it now, or else
1898 forwarded objects won't work right. */
1900 Lisp_Object
*pvalbuf
, buf
;
1901 valcontents
= sym
->value
;
1902 pvalbuf
= &BLOCAL_BUFFER (XBUFFER_LOCAL_VALUE (valcontents
));
1903 XSETBUFFER (buf
, current_buffer
);
1904 if (EQ (buf
, *pvalbuf
))
1907 BLOCAL_CLEAR_FLAGS (XBUFFER_LOCAL_VALUE (valcontents
));
1908 find_symbol_value (variable
);
1915 /* Lisp functions for creating and removing buffer-local variables. */
1917 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1918 when/if this is removed. */
1920 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1921 1, 1, "vMake Variable Frame Local: ",
1922 doc
: /* Enable VARIABLE to have frame-local bindings.
1923 This does not create any frame-local bindings for VARIABLE,
1924 it just makes them possible.
1926 A frame-local binding is actually a frame parameter value.
1927 If a frame F has a value for the frame parameter named VARIABLE,
1928 that also acts as a frame-local binding for VARIABLE in F--
1929 provided this function has been called to enable VARIABLE
1930 to have frame-local bindings at all.
1932 The only way to create a frame-local binding for VARIABLE in a frame
1933 is to set the VARIABLE frame parameter of that frame. See
1934 `modify-frame-parameters' for how to set frame parameters.
1936 Note that since Emacs 23.1, variables cannot be both buffer-local and
1937 frame-local any more (buffer-local bindings used to take precedence over
1938 frame-local bindings). */)
1940 register Lisp_Object variable
;
1942 register Lisp_Object tem
, valcontents
, newval
, val_vec
, len
;
1943 struct Lisp_Symbol
*sym
;
1945 CHECK_SYMBOL (variable
);
1946 sym
= indirect_variable (XSYMBOL (variable
));
1948 valcontents
= sym
->value
;
1949 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1950 || BUFFER_OBJFWDP (valcontents
))
1951 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1953 if (BUFFER_LOCAL_VALUEP (valcontents
))
1955 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1956 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1960 if (EQ (valcontents
, Qunbound
))
1962 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1964 newval
= allocate_misc ();
1965 XSETFASTINT (len
, 4);
1966 val_vec
= Fmake_vector (len
, Qnil
);
1967 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1968 XBUFFER_LOCAL_VALUE (newval
)->thread_data
= Qnil
;
1969 BLOCAL_CLEAR_FLAGS_VEC (val_vec
);
1970 BLOCAL_BUFFER_VEC (val_vec
) = Qnil
;
1971 BLOCAL_FRAME_VEC (val_vec
) = Qnil
;
1972 BLOCAL_CDR_VEC (val_vec
) = tem
;
1973 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1974 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1975 BLOCAL_SET_THREAD_DATA (XBUFFER_LOCAL_VALUE (newval
), val_vec
);
1976 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= allocate_misc ();
1977 XMISCTYPE (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)
1978 = Lisp_Misc_ThreadLocal
;
1979 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->global
1981 XTHREADLOCAL (XBUFFER_LOCAL_VALUE (newval
)->realvalue
)->thread_alist
1982 = Fcons (Fcons (get_current_thread (), Qnil
), Qnil
);
1983 BLOCAL_REALVALUE (XBUFFER_LOCAL_VALUE (newval
)) = sym
->value
;
1984 sym
->value
= newval
;
1988 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1990 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1991 BUFFER defaults to the current buffer. */)
1993 register Lisp_Object variable
, buffer
;
1995 Lisp_Object valcontents
;
1996 register struct buffer
*buf
;
1997 struct Lisp_Symbol
*sym
;
2000 buf
= current_buffer
;
2003 CHECK_BUFFER (buffer
);
2004 buf
= XBUFFER (buffer
);
2007 CHECK_SYMBOL (variable
);
2008 sym
= indirect_variable (XSYMBOL (variable
));
2009 XSETSYMBOL (variable
, sym
);
2011 valcontents
= sym
->value
;
2012 if (BUFFER_LOCAL_VALUEP (valcontents
))
2014 Lisp_Object tail
, elt
;
2016 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2019 if (EQ (variable
, XCAR (elt
)))
2023 if (BUFFER_OBJFWDP (valcontents
))
2025 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
2026 int idx
= PER_BUFFER_IDX (offset
);
2027 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
2033 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
2035 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
2036 More precisely, this means that setting the variable \(with `set' or`setq'),
2037 while it does not have a `let'-style binding that was made in BUFFER,
2038 will produce a buffer local binding. See Info node
2039 `(elisp)Creating Buffer-Local'.
2040 BUFFER defaults to the current buffer. */)
2042 register Lisp_Object variable
, buffer
;
2044 Lisp_Object valcontents
;
2045 register struct buffer
*buf
;
2046 struct Lisp_Symbol
*sym
;
2049 buf
= current_buffer
;
2052 CHECK_BUFFER (buffer
);
2053 buf
= XBUFFER (buffer
);
2056 CHECK_SYMBOL (variable
);
2057 sym
= indirect_variable (XSYMBOL (variable
));
2058 XSETSYMBOL (variable
, sym
);
2060 valcontents
= sym
->value
;
2062 if (BUFFER_OBJFWDP (valcontents
))
2063 /* All these slots become local if they are set. */
2065 else if (BUFFER_LOCAL_VALUEP (valcontents
))
2067 Lisp_Object tail
, elt
;
2068 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
2070 for (tail
= BUF_LOCAL_VAR_ALIST (buf
); CONSP (tail
); tail
= XCDR (tail
))
2073 if (EQ (variable
, XCAR (elt
)))
2080 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2082 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2083 If the current binding is buffer-local, the value is the current buffer.
2084 If the current binding is frame-local, the value is the selected frame.
2085 If the current binding is global (the default), the value is nil. */)
2087 register Lisp_Object variable
;
2089 Lisp_Object valcontents
;
2090 struct Lisp_Symbol
*sym
;
2092 CHECK_SYMBOL (variable
);
2093 sym
= indirect_variable (XSYMBOL (variable
));
2095 /* Make sure the current binding is actually swapped in. */
2096 find_symbol_value (variable
);
2098 valcontents
= sym
->value
;
2100 if (BUFFER_LOCAL_VALUEP (valcontents
)
2101 || BUFFER_OBJFWDP (valcontents
))
2103 /* For a local variable, record both the symbol and which
2104 buffer's or frame's value we are saving. */
2105 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2106 return Fcurrent_buffer ();
2107 else if (BUFFER_LOCAL_VALUEP (valcontents
)
2108 && BLOCAL_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))
2109 return BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
2115 /* This code is disabled now that we use the selected frame to return
2116 keyboard-local-values. */
2118 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2120 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2121 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2122 If SYMBOL is not a terminal-local variable, then return its normal
2123 value, like `symbol-value'.
2125 TERMINAL may be a terminal object, a frame, or nil (meaning the
2126 selected frame's terminal device). */)
2129 Lisp_Object terminal
;
2132 struct terminal
*t
= get_terminal (terminal
, 1);
2133 push_kboard (t
->kboard
);
2134 result
= Fsymbol_value (symbol
);
2139 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2140 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2141 If VARIABLE is not a terminal-local variable, then set its normal
2142 binding, like `set'.
2144 TERMINAL may be a terminal object, a frame, or nil (meaning the
2145 selected frame's terminal device). */)
2146 (symbol
, terminal
, value
)
2148 Lisp_Object terminal
;
2152 struct terminal
*t
= get_terminal (terminal
, 1);
2153 push_kboard (d
->kboard
);
2154 result
= Fset (symbol
, value
);
2160 /* Find the function at the end of a chain of symbol function indirections. */
2162 /* If OBJECT is a symbol, find the end of its function chain and
2163 return the value found there. If OBJECT is not a symbol, just
2164 return it. If there is a cycle in the function chain, signal a
2165 cyclic-function-indirection error.
2167 This is like Findirect_function, except that it doesn't signal an
2168 error if the chain ends up unbound. */
2170 indirect_function (object
)
2171 register Lisp_Object object
;
2173 Lisp_Object tortoise
, hare
;
2175 hare
= tortoise
= object
;
2179 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2181 hare
= XSYMBOL (hare
)->function
;
2182 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2184 hare
= XSYMBOL (hare
)->function
;
2186 tortoise
= XSYMBOL (tortoise
)->function
;
2188 if (EQ (hare
, tortoise
))
2189 xsignal1 (Qcyclic_function_indirection
, object
);
2195 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2196 doc
: /* Return the function at the end of OBJECT's function chain.
2197 If OBJECT is not a symbol, just return it. Otherwise, follow all
2198 function indirections to find the final function binding and return it.
2199 If the final symbol in the chain is unbound, signal a void-function error.
2200 Optional arg NOERROR non-nil means to return nil instead of signalling.
2201 Signal a cyclic-function-indirection error if there is a loop in the
2202 function chain of symbols. */)
2204 register Lisp_Object object
;
2205 Lisp_Object noerror
;
2209 /* Optimize for no indirection. */
2211 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2212 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2213 result
= indirect_function (result
);
2214 if (!EQ (result
, Qunbound
))
2218 xsignal1 (Qvoid_function
, object
);
2223 /* Extract and set vector and string elements */
2225 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2226 doc
: /* Return the element of ARRAY at index IDX.
2227 ARRAY may be a vector, a string, a char-table, a bool-vector,
2228 or a byte-code object. IDX starts at 0. */)
2230 register Lisp_Object array
;
2233 register int idxval
;
2236 idxval
= XINT (idx
);
2237 if (STRINGP (array
))
2241 if (idxval
< 0 || idxval
>= SCHARS (array
))
2242 args_out_of_range (array
, idx
);
2243 if (! STRING_MULTIBYTE (array
))
2244 return make_number ((unsigned char) SREF (array
, idxval
));
2245 idxval_byte
= string_char_to_byte (array
, idxval
);
2247 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2248 return make_number (c
);
2250 else if (BOOL_VECTOR_P (array
))
2254 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2255 args_out_of_range (array
, idx
);
2257 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2258 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2260 else if (CHAR_TABLE_P (array
))
2262 CHECK_CHARACTER (idx
);
2263 return CHAR_TABLE_REF (array
, idxval
);
2268 if (VECTORP (array
))
2269 size
= XVECTOR (array
)->size
;
2270 else if (COMPILEDP (array
))
2271 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2273 wrong_type_argument (Qarrayp
, array
);
2275 if (idxval
< 0 || idxval
>= size
)
2276 args_out_of_range (array
, idx
);
2277 return XVECTOR (array
)->contents
[idxval
];
2281 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2282 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2283 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2284 bool-vector. IDX starts at 0. */)
2285 (array
, idx
, newelt
)
2286 register Lisp_Object array
;
2287 Lisp_Object idx
, newelt
;
2289 register int idxval
;
2292 idxval
= XINT (idx
);
2293 CHECK_ARRAY (array
, Qarrayp
);
2294 CHECK_IMPURE (array
);
2296 if (VECTORP (array
))
2298 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2299 args_out_of_range (array
, idx
);
2300 XVECTOR (array
)->contents
[idxval
] = newelt
;
2302 else if (BOOL_VECTOR_P (array
))
2306 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2307 args_out_of_range (array
, idx
);
2309 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2311 if (! NILP (newelt
))
2312 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2314 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2315 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2317 else if (CHAR_TABLE_P (array
))
2319 CHECK_CHARACTER (idx
);
2320 CHAR_TABLE_SET (array
, idxval
, newelt
);
2322 else if (STRING_MULTIBYTE (array
))
2324 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2325 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2327 if (idxval
< 0 || idxval
>= SCHARS (array
))
2328 args_out_of_range (array
, idx
);
2329 CHECK_CHARACTER (newelt
);
2331 nbytes
= SBYTES (array
);
2333 idxval_byte
= string_char_to_byte (array
, idxval
);
2334 p1
= SDATA (array
) + idxval_byte
;
2335 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2336 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2337 if (prev_bytes
!= new_bytes
)
2339 /* We must relocate the string data. */
2340 int nchars
= SCHARS (array
);
2344 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2345 bcopy (SDATA (array
), str
, nbytes
);
2346 allocate_string_data (XSTRING (array
), nchars
,
2347 nbytes
+ new_bytes
- prev_bytes
);
2348 bcopy (str
, SDATA (array
), idxval_byte
);
2349 p1
= SDATA (array
) + idxval_byte
;
2350 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2351 nbytes
- (idxval_byte
+ prev_bytes
));
2353 clear_string_char_byte_cache ();
2360 if (idxval
< 0 || idxval
>= SCHARS (array
))
2361 args_out_of_range (array
, idx
);
2362 CHECK_NUMBER (newelt
);
2364 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2368 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2369 if (SREF (array
, i
) >= 0x80)
2370 args_out_of_range (array
, newelt
);
2371 /* ARRAY is an ASCII string. Convert it to a multibyte
2372 string, and try `aset' again. */
2373 STRING_SET_MULTIBYTE (array
);
2374 return Faset (array
, idx
, newelt
);
2376 SSET (array
, idxval
, XINT (newelt
));
2382 /* Arithmetic functions */
2384 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2387 arithcompare (num1
, num2
, comparison
)
2388 Lisp_Object num1
, num2
;
2389 enum comparison comparison
;
2391 double f1
= 0, f2
= 0;
2394 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2395 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2397 if (FLOATP (num1
) || FLOATP (num2
))
2400 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2401 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2407 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2412 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2417 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2422 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2427 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2432 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2441 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2442 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2444 register Lisp_Object num1
, num2
;
2446 return arithcompare (num1
, num2
, equal
);
2449 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2450 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2452 register Lisp_Object num1
, num2
;
2454 return arithcompare (num1
, num2
, less
);
2457 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2458 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2460 register Lisp_Object num1
, num2
;
2462 return arithcompare (num1
, num2
, grtr
);
2465 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2466 doc
: /* Return t if first arg is less than or equal to second arg.
2467 Both must be numbers or markers. */)
2469 register Lisp_Object num1
, num2
;
2471 return arithcompare (num1
, num2
, less_or_equal
);
2474 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2475 doc
: /* Return t if first arg is greater than or equal to second arg.
2476 Both must be numbers or markers. */)
2478 register Lisp_Object num1
, num2
;
2480 return arithcompare (num1
, num2
, grtr_or_equal
);
2483 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2484 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2486 register Lisp_Object num1
, num2
;
2488 return arithcompare (num1
, num2
, notequal
);
2491 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2492 doc
: /* Return t if NUMBER is zero. */)
2494 register Lisp_Object number
;
2496 CHECK_NUMBER_OR_FLOAT (number
);
2498 if (FLOATP (number
))
2500 if (XFLOAT_DATA (number
) == 0.0)
2510 /* Convert between long values and pairs of Lisp integers.
2511 Note that long_to_cons returns a single Lisp integer
2512 when the value fits in one. */
2518 unsigned long top
= i
>> 16;
2519 unsigned int bot
= i
& 0xFFFF;
2521 return make_number (bot
);
2522 if (top
== (unsigned long)-1 >> 16)
2523 return Fcons (make_number (-1), make_number (bot
));
2524 return Fcons (make_number (top
), make_number (bot
));
2531 Lisp_Object top
, bot
;
2538 return ((XINT (top
) << 16) | XINT (bot
));
2541 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2542 doc
: /* Return the decimal representation of NUMBER as a string.
2543 Uses a minus sign if negative.
2544 NUMBER may be an integer or a floating point number. */)
2548 char buffer
[VALBITS
];
2550 CHECK_NUMBER_OR_FLOAT (number
);
2552 if (FLOATP (number
))
2554 char pigbuf
[350]; /* see comments in float_to_string */
2556 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2557 return build_string (pigbuf
);
2560 if (sizeof (int) == sizeof (EMACS_INT
))
2561 sprintf (buffer
, "%d", (int) XINT (number
));
2562 else if (sizeof (long) == sizeof (EMACS_INT
))
2563 sprintf (buffer
, "%ld", (long) XINT (number
));
2566 return build_string (buffer
);
2570 digit_to_number (character
, base
)
2571 int character
, base
;
2575 if (character
>= '0' && character
<= '9')
2576 digit
= character
- '0';
2577 else if (character
>= 'a' && character
<= 'z')
2578 digit
= character
- 'a' + 10;
2579 else if (character
>= 'A' && character
<= 'Z')
2580 digit
= character
- 'A' + 10;
2590 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2591 doc
: /* Parse STRING as a decimal number and return the number.
2592 This parses both integers and floating point numbers.
2593 It ignores leading spaces and tabs, and all trailing chars.
2595 If BASE, interpret STRING as a number in that base. If BASE isn't
2596 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2597 If the base used is not 10, STRING is always parsed as integer. */)
2599 register Lisp_Object string
, base
;
2601 register unsigned char *p
;
2606 CHECK_STRING (string
);
2612 CHECK_NUMBER (base
);
2614 if (b
< 2 || b
> 16)
2615 xsignal1 (Qargs_out_of_range
, base
);
2618 /* Skip any whitespace at the front of the number. Some versions of
2619 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2621 while (*p
== ' ' || *p
== '\t')
2632 if (isfloat_string (p
, 1) && b
== 10)
2633 val
= make_float (sign
* atof (p
));
2640 int digit
= digit_to_number (*p
++, b
);
2646 val
= make_fixnum_or_float (sign
* v
);
2666 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2667 int, Lisp_Object
*));
2668 extern Lisp_Object
fmod_float ();
2671 arith_driver (code
, nargs
, args
)
2674 register Lisp_Object
*args
;
2676 register Lisp_Object val
;
2677 register int argnum
;
2678 register EMACS_INT accum
= 0;
2679 register EMACS_INT next
;
2681 switch (SWITCH_ENUM_CAST (code
))
2699 for (argnum
= 0; argnum
< nargs
; argnum
++)
2701 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2703 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2706 return float_arith_driver ((double) accum
, argnum
, code
,
2709 next
= XINT (args
[argnum
]);
2710 switch (SWITCH_ENUM_CAST (code
))
2716 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2727 xsignal0 (Qarith_error
);
2741 if (!argnum
|| next
> accum
)
2745 if (!argnum
|| next
< accum
)
2751 XSETINT (val
, accum
);
2756 #define isnan(x) ((x) != (x))
2759 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2761 register int argnum
;
2764 register Lisp_Object
*args
;
2766 register Lisp_Object val
;
2769 for (; argnum
< nargs
; argnum
++)
2771 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2772 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2776 next
= XFLOAT_DATA (val
);
2780 args
[argnum
] = val
; /* runs into a compiler bug. */
2781 next
= XINT (args
[argnum
]);
2783 switch (SWITCH_ENUM_CAST (code
))
2789 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2799 if (! IEEE_FLOATING_POINT
&& next
== 0)
2800 xsignal0 (Qarith_error
);
2807 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2809 if (!argnum
|| isnan (next
) || next
> accum
)
2813 if (!argnum
|| isnan (next
) || next
< accum
)
2819 return make_float (accum
);
2823 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2824 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2825 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2830 return arith_driver (Aadd
, nargs
, args
);
2833 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2834 doc
: /* Negate number or subtract numbers or markers and return the result.
2835 With one arg, negates it. With more than one arg,
2836 subtracts all but the first from the first.
2837 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2842 return arith_driver (Asub
, nargs
, args
);
2845 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2846 doc
: /* Return product of any number of arguments, which are numbers or markers.
2847 usage: (* &rest NUMBERS-OR-MARKERS) */)
2852 return arith_driver (Amult
, nargs
, args
);
2855 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2856 doc
: /* Return first argument divided by all the remaining arguments.
2857 The arguments must be numbers or markers.
2858 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2864 for (argnum
= 2; argnum
< nargs
; argnum
++)
2865 if (FLOATP (args
[argnum
]))
2866 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2867 return arith_driver (Adiv
, nargs
, args
);
2870 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2871 doc
: /* Return remainder of X divided by Y.
2872 Both must be integers or markers. */)
2874 register Lisp_Object x
, y
;
2878 CHECK_NUMBER_COERCE_MARKER (x
);
2879 CHECK_NUMBER_COERCE_MARKER (y
);
2881 if (XFASTINT (y
) == 0)
2882 xsignal0 (Qarith_error
);
2884 XSETINT (val
, XINT (x
) % XINT (y
));
2898 /* If the magnitude of the result exceeds that of the divisor, or
2899 the sign of the result does not agree with that of the dividend,
2900 iterate with the reduced value. This does not yield a
2901 particularly accurate result, but at least it will be in the
2902 range promised by fmod. */
2904 r
-= f2
* floor (r
/ f2
);
2905 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2909 #endif /* ! HAVE_FMOD */
2911 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2912 doc
: /* Return X modulo Y.
2913 The result falls between zero (inclusive) and Y (exclusive).
2914 Both X and Y must be numbers or markers. */)
2916 register Lisp_Object x
, y
;
2921 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2922 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2924 if (FLOATP (x
) || FLOATP (y
))
2925 return fmod_float (x
, y
);
2931 xsignal0 (Qarith_error
);
2935 /* If the "remainder" comes out with the wrong sign, fix it. */
2936 if (i2
< 0 ? i1
> 0 : i1
< 0)
2943 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2944 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2945 The value is always a number; markers are converted to numbers.
2946 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2951 return arith_driver (Amax
, nargs
, args
);
2954 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2955 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2956 The value is always a number; markers are converted to numbers.
2957 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2962 return arith_driver (Amin
, nargs
, args
);
2965 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2966 doc
: /* Return bitwise-and of all the arguments.
2967 Arguments may be integers, or markers converted to integers.
2968 usage: (logand &rest INTS-OR-MARKERS) */)
2973 return arith_driver (Alogand
, nargs
, args
);
2976 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2977 doc
: /* Return bitwise-or of all the arguments.
2978 Arguments may be integers, or markers converted to integers.
2979 usage: (logior &rest INTS-OR-MARKERS) */)
2984 return arith_driver (Alogior
, nargs
, args
);
2987 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2988 doc
: /* Return bitwise-exclusive-or of all the arguments.
2989 Arguments may be integers, or markers converted to integers.
2990 usage: (logxor &rest INTS-OR-MARKERS) */)
2995 return arith_driver (Alogxor
, nargs
, args
);
2998 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2999 doc
: /* Return VALUE with its bits shifted left by COUNT.
3000 If COUNT is negative, shifting is actually to the right.
3001 In this case, the sign bit is duplicated. */)
3003 register Lisp_Object value
, count
;
3005 register Lisp_Object val
;
3007 CHECK_NUMBER (value
);
3008 CHECK_NUMBER (count
);
3010 if (XINT (count
) >= BITS_PER_EMACS_INT
)
3012 else if (XINT (count
) > 0)
3013 XSETINT (val
, XINT (value
) << XFASTINT (count
));
3014 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
3015 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
3017 XSETINT (val
, XINT (value
) >> -XINT (count
));
3021 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
3022 doc
: /* Return VALUE with its bits shifted left by COUNT.
3023 If COUNT is negative, shifting is actually to the right.
3024 In this case, zeros are shifted in on the left. */)
3026 register Lisp_Object value
, count
;
3028 register Lisp_Object val
;
3030 CHECK_NUMBER (value
);
3031 CHECK_NUMBER (count
);
3033 if (XINT (count
) >= BITS_PER_EMACS_INT
)
3035 else if (XINT (count
) > 0)
3036 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
3037 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
3040 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
3044 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
3045 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
3046 Markers are converted to integers. */)
3048 register Lisp_Object number
;
3050 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3052 if (FLOATP (number
))
3053 return (make_float (1.0 + XFLOAT_DATA (number
)));
3055 XSETINT (number
, XINT (number
) + 1);
3059 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3060 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3061 Markers are converted to integers. */)
3063 register Lisp_Object number
;
3065 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3067 if (FLOATP (number
))
3068 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3070 XSETINT (number
, XINT (number
) - 1);
3074 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3075 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3077 register Lisp_Object number
;
3079 CHECK_NUMBER (number
);
3080 XSETINT (number
, ~XINT (number
));
3084 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3085 doc
: /* Return the byteorder for the machine.
3086 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3087 lowercase l) for small endian machines. */)
3090 unsigned i
= 0x04030201;
3091 int order
= *(char *)&i
== 1 ? 108 : 66;
3093 return make_number (order
);
3101 Lisp_Object error_tail
, arith_tail
;
3103 Qquote
= intern_c_string ("quote");
3104 Qlambda
= intern_c_string ("lambda");
3105 Qsubr
= intern_c_string ("subr");
3106 Qerror_conditions
= intern_c_string ("error-conditions");
3107 Qerror_message
= intern_c_string ("error-message");
3108 Qtop_level
= intern_c_string ("top-level");
3110 Qerror
= intern_c_string ("error");
3111 Qquit
= intern_c_string ("quit");
3112 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3113 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3114 Qvoid_function
= intern_c_string ("void-function");
3115 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3116 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3117 Qvoid_variable
= intern_c_string ("void-variable");
3118 Qsetting_constant
= intern_c_string ("setting-constant");
3119 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3121 Qinvalid_function
= intern_c_string ("invalid-function");
3122 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3123 Qno_catch
= intern_c_string ("no-catch");
3124 Qend_of_file
= intern_c_string ("end-of-file");
3125 Qarith_error
= intern_c_string ("arith-error");
3126 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3127 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3128 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3129 Qtext_read_only
= intern_c_string ("text-read-only");
3130 Qmark_inactive
= intern_c_string ("mark-inactive");
3132 Qlistp
= intern_c_string ("listp");
3133 Qconsp
= intern_c_string ("consp");
3134 Qsymbolp
= intern_c_string ("symbolp");
3135 Qkeywordp
= intern_c_string ("keywordp");
3136 Qintegerp
= intern_c_string ("integerp");
3137 Qnatnump
= intern_c_string ("natnump");
3138 Qwholenump
= intern_c_string ("wholenump");
3139 Qstringp
= intern_c_string ("stringp");
3140 Qarrayp
= intern_c_string ("arrayp");
3141 Qsequencep
= intern_c_string ("sequencep");
3142 Qbufferp
= intern_c_string ("bufferp");
3143 Qvectorp
= intern_c_string ("vectorp");
3144 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3145 Qmarkerp
= intern_c_string ("markerp");
3146 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3147 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3148 Qboundp
= intern_c_string ("boundp");
3149 Qfboundp
= intern_c_string ("fboundp");
3151 Qfloatp
= intern_c_string ("floatp");
3152 Qnumberp
= intern_c_string ("numberp");
3153 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3155 Qchar_table_p
= intern_c_string ("char-table-p");
3156 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3158 Qsubrp
= intern_c_string ("subrp");
3159 Qunevalled
= intern_c_string ("unevalled");
3160 Qmany
= intern_c_string ("many");
3162 Qcdr
= intern_c_string ("cdr");
3164 /* Handle automatic advice activation */
3165 Qad_advice_info
= intern_c_string ("ad-advice-info");
3166 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3168 error_tail
= pure_cons (Qerror
, Qnil
);
3170 /* ERROR is used as a signaler for random errors for which nothing else is right */
3172 Fput (Qerror
, Qerror_conditions
,
3174 Fput (Qerror
, Qerror_message
,
3175 make_pure_c_string ("error"));
3177 Fput (Qquit
, Qerror_conditions
,
3178 pure_cons (Qquit
, Qnil
));
3179 Fput (Qquit
, Qerror_message
,
3180 make_pure_c_string ("Quit"));
3182 Fput (Qwrong_type_argument
, Qerror_conditions
,
3183 pure_cons (Qwrong_type_argument
, error_tail
));
3184 Fput (Qwrong_type_argument
, Qerror_message
,
3185 make_pure_c_string ("Wrong type argument"));
3187 Fput (Qargs_out_of_range
, Qerror_conditions
,
3188 pure_cons (Qargs_out_of_range
, error_tail
));
3189 Fput (Qargs_out_of_range
, Qerror_message
,
3190 make_pure_c_string ("Args out of range"));
3192 Fput (Qvoid_function
, Qerror_conditions
,
3193 pure_cons (Qvoid_function
, error_tail
));
3194 Fput (Qvoid_function
, Qerror_message
,
3195 make_pure_c_string ("Symbol's function definition is void"));
3197 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3198 pure_cons (Qcyclic_function_indirection
, error_tail
));
3199 Fput (Qcyclic_function_indirection
, Qerror_message
,
3200 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3202 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3203 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3204 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3205 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3207 Qcircular_list
= intern_c_string ("circular-list");
3208 staticpro (&Qcircular_list
);
3209 Fput (Qcircular_list
, Qerror_conditions
,
3210 pure_cons (Qcircular_list
, error_tail
));
3211 Fput (Qcircular_list
, Qerror_message
,
3212 make_pure_c_string ("List contains a loop"));
3214 Fput (Qvoid_variable
, Qerror_conditions
,
3215 pure_cons (Qvoid_variable
, error_tail
));
3216 Fput (Qvoid_variable
, Qerror_message
,
3217 make_pure_c_string ("Symbol's value as variable is void"));
3219 Fput (Qsetting_constant
, Qerror_conditions
,
3220 pure_cons (Qsetting_constant
, error_tail
));
3221 Fput (Qsetting_constant
, Qerror_message
,
3222 make_pure_c_string ("Attempt to set a constant symbol"));
3224 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3225 pure_cons (Qinvalid_read_syntax
, error_tail
));
3226 Fput (Qinvalid_read_syntax
, Qerror_message
,
3227 make_pure_c_string ("Invalid read syntax"));
3229 Fput (Qinvalid_function
, Qerror_conditions
,
3230 pure_cons (Qinvalid_function
, error_tail
));
3231 Fput (Qinvalid_function
, Qerror_message
,
3232 make_pure_c_string ("Invalid function"));
3234 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3235 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3236 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3237 make_pure_c_string ("Wrong number of arguments"));
3239 Fput (Qno_catch
, Qerror_conditions
,
3240 pure_cons (Qno_catch
, error_tail
));
3241 Fput (Qno_catch
, Qerror_message
,
3242 make_pure_c_string ("No catch for tag"));
3244 Fput (Qend_of_file
, Qerror_conditions
,
3245 pure_cons (Qend_of_file
, error_tail
));
3246 Fput (Qend_of_file
, Qerror_message
,
3247 make_pure_c_string ("End of file during parsing"));
3249 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3250 Fput (Qarith_error
, Qerror_conditions
,
3252 Fput (Qarith_error
, Qerror_message
,
3253 make_pure_c_string ("Arithmetic error"));
3255 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3256 pure_cons (Qbeginning_of_buffer
, error_tail
));
3257 Fput (Qbeginning_of_buffer
, Qerror_message
,
3258 make_pure_c_string ("Beginning of buffer"));
3260 Fput (Qend_of_buffer
, Qerror_conditions
,
3261 pure_cons (Qend_of_buffer
, error_tail
));
3262 Fput (Qend_of_buffer
, Qerror_message
,
3263 make_pure_c_string ("End of buffer"));
3265 Fput (Qbuffer_read_only
, Qerror_conditions
,
3266 pure_cons (Qbuffer_read_only
, error_tail
));
3267 Fput (Qbuffer_read_only
, Qerror_message
,
3268 make_pure_c_string ("Buffer is read-only"));
3270 Fput (Qtext_read_only
, Qerror_conditions
,
3271 pure_cons (Qtext_read_only
, error_tail
));
3272 Fput (Qtext_read_only
, Qerror_message
,
3273 make_pure_c_string ("Text is read-only"));
3275 Qrange_error
= intern_c_string ("range-error");
3276 Qdomain_error
= intern_c_string ("domain-error");
3277 Qsingularity_error
= intern_c_string ("singularity-error");
3278 Qoverflow_error
= intern_c_string ("overflow-error");
3279 Qunderflow_error
= intern_c_string ("underflow-error");
3281 Fput (Qdomain_error
, Qerror_conditions
,
3282 pure_cons (Qdomain_error
, arith_tail
));
3283 Fput (Qdomain_error
, Qerror_message
,
3284 make_pure_c_string ("Arithmetic domain error"));
3286 Fput (Qrange_error
, Qerror_conditions
,
3287 pure_cons (Qrange_error
, arith_tail
));
3288 Fput (Qrange_error
, Qerror_message
,
3289 make_pure_c_string ("Arithmetic range error"));
3291 Fput (Qsingularity_error
, Qerror_conditions
,
3292 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3293 Fput (Qsingularity_error
, Qerror_message
,
3294 make_pure_c_string ("Arithmetic singularity error"));
3296 Fput (Qoverflow_error
, Qerror_conditions
,
3297 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3298 Fput (Qoverflow_error
, Qerror_message
,
3299 make_pure_c_string ("Arithmetic overflow error"));
3301 Fput (Qunderflow_error
, Qerror_conditions
,
3302 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3303 Fput (Qunderflow_error
, Qerror_message
,
3304 make_pure_c_string ("Arithmetic underflow error"));
3306 staticpro (&Qrange_error
);
3307 staticpro (&Qdomain_error
);
3308 staticpro (&Qsingularity_error
);
3309 staticpro (&Qoverflow_error
);
3310 staticpro (&Qunderflow_error
);
3314 staticpro (&Qquote
);
3315 staticpro (&Qlambda
);
3317 staticpro (&Qunbound
);
3318 staticpro (&Qerror_conditions
);
3319 staticpro (&Qerror_message
);
3320 staticpro (&Qtop_level
);
3322 staticpro (&Qerror
);
3324 staticpro (&Qwrong_type_argument
);
3325 staticpro (&Qargs_out_of_range
);
3326 staticpro (&Qvoid_function
);
3327 staticpro (&Qcyclic_function_indirection
);
3328 staticpro (&Qcyclic_variable_indirection
);
3329 staticpro (&Qvoid_variable
);
3330 staticpro (&Qsetting_constant
);
3331 staticpro (&Qinvalid_read_syntax
);
3332 staticpro (&Qwrong_number_of_arguments
);
3333 staticpro (&Qinvalid_function
);
3334 staticpro (&Qno_catch
);
3335 staticpro (&Qend_of_file
);
3336 staticpro (&Qarith_error
);
3337 staticpro (&Qbeginning_of_buffer
);
3338 staticpro (&Qend_of_buffer
);
3339 staticpro (&Qbuffer_read_only
);
3340 staticpro (&Qtext_read_only
);
3341 staticpro (&Qmark_inactive
);
3343 staticpro (&Qlistp
);
3344 staticpro (&Qconsp
);
3345 staticpro (&Qsymbolp
);
3346 staticpro (&Qkeywordp
);
3347 staticpro (&Qintegerp
);
3348 staticpro (&Qnatnump
);
3349 staticpro (&Qwholenump
);
3350 staticpro (&Qstringp
);
3351 staticpro (&Qarrayp
);
3352 staticpro (&Qsequencep
);
3353 staticpro (&Qbufferp
);
3354 staticpro (&Qvectorp
);
3355 staticpro (&Qchar_or_string_p
);
3356 staticpro (&Qmarkerp
);
3357 staticpro (&Qbuffer_or_string_p
);
3358 staticpro (&Qinteger_or_marker_p
);
3359 staticpro (&Qfloatp
);
3360 staticpro (&Qnumberp
);
3361 staticpro (&Qnumber_or_marker_p
);
3362 staticpro (&Qchar_table_p
);
3363 staticpro (&Qvector_or_char_table_p
);
3364 staticpro (&Qsubrp
);
3366 staticpro (&Qunevalled
);
3368 staticpro (&Qboundp
);
3369 staticpro (&Qfboundp
);
3371 staticpro (&Qad_advice_info
);
3372 staticpro (&Qad_activate_internal
);
3374 /* Types that type-of returns. */
3375 Qinteger
= intern_c_string ("integer");
3376 Qsymbol
= intern_c_string ("symbol");
3377 Qstring
= intern_c_string ("string");
3378 Qcons
= intern_c_string ("cons");
3379 Qmarker
= intern_c_string ("marker");
3380 Qoverlay
= intern_c_string ("overlay");
3381 Qfloat
= intern_c_string ("float");
3382 Qwindow_configuration
= intern_c_string ("window-configuration");
3383 Qprocess
= intern_c_string ("process");
3384 Qwindow
= intern_c_string ("window");
3385 /* Qsubr = intern_c_string ("subr"); */
3386 Qcompiled_function
= intern_c_string ("compiled-function");
3387 Qbuffer
= intern_c_string ("buffer");
3388 Qframe
= intern_c_string ("frame");
3389 Qvector
= intern_c_string ("vector");
3390 Qchar_table
= intern_c_string ("char-table");
3391 Qbool_vector
= intern_c_string ("bool-vector");
3392 Qhash_table
= intern_c_string ("hash-table");
3394 Qthread_local_mark
= Fmake_symbol (make_pure_string ("thread-local-mark",
3397 DEFSYM (Qfont_spec
, "font-spec");
3398 DEFSYM (Qfont_entity
, "font-entity");
3399 DEFSYM (Qfont_object
, "font-object");
3401 DEFSYM (Qinteractive_form
, "interactive-form");
3403 staticpro (&Qinteger
);
3404 staticpro (&Qsymbol
);
3405 staticpro (&Qstring
);
3407 staticpro (&Qmarker
);
3408 staticpro (&Qoverlay
);
3409 staticpro (&Qfloat
);
3410 staticpro (&Qwindow_configuration
);
3411 staticpro (&Qprocess
);
3412 staticpro (&Qwindow
);
3413 /* staticpro (&Qsubr); */
3414 staticpro (&Qcompiled_function
);
3415 staticpro (&Qbuffer
);
3416 staticpro (&Qframe
);
3417 staticpro (&Qvector
);
3418 staticpro (&Qchar_table
);
3419 staticpro (&Qbool_vector
);
3420 staticpro (&Qhash_table
);
3421 staticpro (&Qthread_local_mark
);
3423 defsubr (&Sindirect_variable
);
3424 defsubr (&Sinteractive_form
);
3427 defsubr (&Stype_of
);
3432 defsubr (&Sintegerp
);
3433 defsubr (&Sinteger_or_marker_p
);
3434 defsubr (&Snumberp
);
3435 defsubr (&Snumber_or_marker_p
);
3437 defsubr (&Snatnump
);
3438 defsubr (&Ssymbolp
);
3439 defsubr (&Skeywordp
);
3440 defsubr (&Sstringp
);
3441 defsubr (&Smultibyte_string_p
);
3442 defsubr (&Svectorp
);
3443 defsubr (&Schar_table_p
);
3444 defsubr (&Svector_or_char_table_p
);
3445 defsubr (&Sbool_vector_p
);
3447 defsubr (&Ssequencep
);
3448 defsubr (&Sbufferp
);
3449 defsubr (&Smarkerp
);
3451 defsubr (&Sbyte_code_function_p
);
3452 defsubr (&Schar_or_string_p
);
3455 defsubr (&Scar_safe
);
3456 defsubr (&Scdr_safe
);
3459 defsubr (&Ssymbol_function
);
3460 defsubr (&Sindirect_function
);
3461 defsubr (&Ssymbol_plist
);
3462 defsubr (&Ssymbol_name
);
3463 defsubr (&Smakunbound
);
3464 defsubr (&Sfmakunbound
);
3466 defsubr (&Sfboundp
);
3468 defsubr (&Sdefalias
);
3469 defsubr (&Ssetplist
);
3470 defsubr (&Ssymbol_value
);
3472 defsubr (&Sdefault_boundp
);
3473 defsubr (&Sdefault_value
);
3474 defsubr (&Sset_default
);
3475 defsubr (&Ssetq_default
);
3476 defsubr (&Smake_variable_buffer_local
);
3477 defsubr (&Smake_local_variable
);
3478 defsubr (&Skill_local_variable
);
3479 defsubr (&Smake_variable_frame_local
);
3480 defsubr (&Slocal_variable_p
);
3481 defsubr (&Slocal_variable_if_set_p
);
3482 defsubr (&Svariable_binding_locus
);
3483 #if 0 /* XXX Remove this. --lorentey */
3484 defsubr (&Sterminal_local_value
);
3485 defsubr (&Sset_terminal_local_value
);
3489 defsubr (&Snumber_to_string
);
3490 defsubr (&Sstring_to_number
);
3491 defsubr (&Seqlsign
);
3514 defsubr (&Sbyteorder
);
3515 defsubr (&Ssubr_arity
);
3516 defsubr (&Ssubr_name
);
3518 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3520 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3521 doc
: /* The largest value that is representable in a Lisp integer. */);
3522 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3523 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3525 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3526 doc
: /* The smallest value that is representable in a Lisp integer. */);
3527 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3528 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3535 sigsetmask (SIGEMPTYMASK
);
3537 SIGNAL_THREAD_CHECK (signo
);
3538 xsignal0 (Qarith_error
);
3544 /* Don't do this if just dumping out.
3545 We don't want to call `signal' in this case
3546 so that we don't have trouble with dumping
3547 signal-delivering routines in an inconsistent state. */
3551 #endif /* CANNOT_DUMP */
3552 signal (SIGFPE
, arith_error
);
3555 signal (SIGEMT
, arith_error
);
3559 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3560 (do not change this comment) */