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 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
49 /* Work around a problem that happens because math.h on hpux 7
50 defines two static variables--which, in Emacs, are not really static,
51 because `static' is defined as nothing. The problem is that they are
52 here, in floatfns.c, and in lread.c.
53 These macros prevent the name conflict. */
54 #if defined (HPUX) && !defined (HPUX8)
55 #define _MAXLDBL data_c_maxldbl
56 #define _NMAXLDBL data_c_nmaxldbl
62 extern double atof ();
65 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
66 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
67 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
68 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
69 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
70 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
71 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
72 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
73 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
74 Lisp_Object Qtext_read_only
;
76 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
77 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
78 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
79 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
80 Lisp_Object Qboundp
, Qfboundp
;
81 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
84 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
86 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
87 Lisp_Object Qoverflow_error
, Qunderflow_error
;
90 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
93 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
94 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
96 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
97 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
98 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
100 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
102 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
106 circular_list_error (list
)
109 xsignal (Qcircular_list
, list
);
114 wrong_type_argument (predicate
, value
)
115 register Lisp_Object predicate
, value
;
117 /* If VALUE is not even a valid Lisp object, abort here
118 where we can get a backtrace showing where it came from. */
119 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
122 xsignal2 (Qwrong_type_argument
, predicate
, value
);
128 error ("Attempt to modify read-only object");
132 args_out_of_range (a1
, a2
)
135 xsignal2 (Qargs_out_of_range
, a1
, a2
);
139 args_out_of_range_3 (a1
, a2
, a3
)
140 Lisp_Object a1
, a2
, a3
;
142 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
145 /* On some machines, XINT needs a temporary location.
146 Here it is, in case it is needed. */
148 int sign_extend_temp
;
150 /* On a few machines, XINT can only be done by calling this. */
153 sign_extend_lisp_int (num
)
156 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
157 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
159 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
162 /* Data type predicates */
164 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
165 doc
: /* Return t if the two args are the same Lisp object. */)
167 Lisp_Object obj1
, obj2
;
174 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
175 doc
: /* Return t if OBJECT is nil. */)
184 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
185 doc
: /* Return a symbol representing the type of OBJECT.
186 The symbol returned names the object's basic type;
187 for example, (type-of 1) returns `integer'. */)
191 switch (XGCTYPE (object
))
206 switch (XMISCTYPE (object
))
208 case Lisp_Misc_Marker
:
210 case Lisp_Misc_Overlay
:
212 case Lisp_Misc_Float
:
217 case Lisp_Vectorlike
:
218 if (GC_WINDOW_CONFIGURATIONP (object
))
219 return Qwindow_configuration
;
220 if (GC_PROCESSP (object
))
222 if (GC_WINDOWP (object
))
224 if (GC_SUBRP (object
))
226 if (GC_COMPILEDP (object
))
227 return Qcompiled_function
;
228 if (GC_BUFFERP (object
))
230 if (GC_CHAR_TABLE_P (object
))
232 if (GC_BOOL_VECTOR_P (object
))
234 if (GC_FRAMEP (object
))
236 if (GC_HASH_TABLE_P (object
))
248 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
249 doc
: /* Return t if OBJECT is a cons cell. */)
258 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
259 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
268 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
269 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
270 Otherwise, return nil. */)
274 if (CONSP (object
) || NILP (object
))
279 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
290 doc
: /* Return t if OBJECT is a symbol. */)
294 if (SYMBOLP (object
))
299 /* Define this in C to avoid unnecessarily consing up the symbol
301 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
302 doc
: /* Return t if OBJECT is a keyword.
303 This means that it is a symbol with a print name beginning with `:'
304 interned in the initial obarray. */)
309 && SREF (SYMBOL_NAME (object
), 0) == ':'
310 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
315 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is a vector. */)
320 if (VECTORP (object
))
325 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
326 doc
: /* Return t if OBJECT is a string. */)
330 if (STRINGP (object
))
335 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
337 doc
: /* Return t if OBJECT is a multibyte string. */)
341 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
346 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
347 doc
: /* Return t if OBJECT is a char-table. */)
351 if (CHAR_TABLE_P (object
))
356 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
357 Svector_or_char_table_p
, 1, 1, 0,
358 doc
: /* Return t if OBJECT is a char-table or vector. */)
362 if (VECTORP (object
) || CHAR_TABLE_P (object
))
367 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a bool-vector. */)
372 if (BOOL_VECTOR_P (object
))
377 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is an array (string or vector). */)
387 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
388 doc
: /* Return t if OBJECT is a sequence (list or array). */)
390 register Lisp_Object object
;
392 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
397 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is an editor buffer. */)
402 if (BUFFERP (object
))
407 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
412 if (MARKERP (object
))
417 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a built-in function. */)
427 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
429 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
433 if (COMPILEDP (object
))
438 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
439 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
441 register Lisp_Object object
;
443 if (INTEGERP (object
) || STRINGP (object
))
448 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is an integer. */)
453 if (INTEGERP (object
))
458 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
461 register Lisp_Object object
;
463 if (MARKERP (object
) || INTEGERP (object
))
468 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is a nonnegative integer. */)
473 if (NATNUMP (object
))
478 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
479 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
483 if (NUMBERP (object
))
489 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
490 Snumber_or_marker_p
, 1, 1, 0,
491 doc
: /* Return t if OBJECT is a number or a marker. */)
495 if (NUMBERP (object
) || MARKERP (object
))
500 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a floating point number. */)
511 /* Extract and set components of lists */
513 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
514 doc
: /* Return the car of LIST. If arg is nil, return nil.
515 Error if arg is not nil and not a cons cell. See also `car-safe'.
517 See Info node `(elisp)Cons Cells' for a discussion of related basic
518 Lisp concepts such as car, cdr, cons cell and list. */)
520 register Lisp_Object list
;
525 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
526 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
530 return CAR_SAFE (object
);
533 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
534 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
535 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
537 See Info node `(elisp)Cons Cells' for a discussion of related basic
538 Lisp concepts such as cdr, car, cons cell and list. */)
540 register Lisp_Object list
;
545 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
546 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
550 return CDR_SAFE (object
);
553 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
554 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
556 register Lisp_Object cell
, newcar
;
560 XSETCAR (cell
, newcar
);
564 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
565 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
567 register Lisp_Object cell
, newcdr
;
571 XSETCDR (cell
, newcdr
);
575 /* Extract and set components of symbols */
577 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
578 doc
: /* Return t if SYMBOL's value is not void. */)
580 register Lisp_Object symbol
;
582 Lisp_Object valcontents
;
583 CHECK_SYMBOL (symbol
);
585 valcontents
= SYMBOL_VALUE (symbol
);
587 if (BUFFER_LOCAL_VALUEP (valcontents
)
588 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
589 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
591 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
594 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
595 doc
: /* Return t if SYMBOL's function definition is not void. */)
597 register Lisp_Object symbol
;
599 CHECK_SYMBOL (symbol
);
600 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
603 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
604 doc
: /* Make SYMBOL's value be void.
607 register Lisp_Object symbol
;
609 CHECK_SYMBOL (symbol
);
610 if (SYMBOL_CONSTANT_P (symbol
))
611 xsignal1 (Qsetting_constant
, symbol
);
612 Fset (symbol
, Qunbound
);
616 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
617 doc
: /* Make SYMBOL's function definition be void.
620 register Lisp_Object symbol
;
622 CHECK_SYMBOL (symbol
);
623 if (NILP (symbol
) || EQ (symbol
, Qt
))
624 xsignal1 (Qsetting_constant
, symbol
);
625 XSYMBOL (symbol
)->function
= Qunbound
;
629 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
630 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
632 register Lisp_Object symbol
;
634 CHECK_SYMBOL (symbol
);
635 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
636 return XSYMBOL (symbol
)->function
;
637 xsignal1 (Qvoid_function
, symbol
);
640 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
641 doc
: /* Return SYMBOL's property list. */)
643 register Lisp_Object symbol
;
645 CHECK_SYMBOL (symbol
);
646 return XSYMBOL (symbol
)->plist
;
649 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
650 doc
: /* Return SYMBOL's name, a string. */)
652 register Lisp_Object symbol
;
654 register Lisp_Object name
;
656 CHECK_SYMBOL (symbol
);
657 name
= SYMBOL_NAME (symbol
);
661 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
662 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
664 register Lisp_Object symbol
, definition
;
666 CHECK_SYMBOL (symbol
);
667 if (NILP (symbol
) || EQ (symbol
, Qt
))
668 xsignal1 (Qsetting_constant
, symbol
);
669 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
670 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
672 XSYMBOL (symbol
)->function
= definition
;
673 /* Handle automatic advice activation */
674 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
676 call2 (Qad_activate_internal
, symbol
, Qnil
);
677 definition
= XSYMBOL (symbol
)->function
;
682 extern Lisp_Object Qfunction_documentation
;
684 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
685 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
686 Associates the function with the current load file, if any.
687 The optional third argument DOCSTRING specifies the documentation string
688 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
689 determined by DEFINITION. */)
690 (symbol
, definition
, docstring
)
691 register Lisp_Object symbol
, definition
, docstring
;
693 CHECK_SYMBOL (symbol
);
694 if (CONSP (XSYMBOL (symbol
)->function
)
695 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
696 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
697 definition
= Ffset (symbol
, definition
);
698 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
699 if (!NILP (docstring
))
700 Fput (symbol
, Qfunction_documentation
, docstring
);
704 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
705 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
707 register Lisp_Object symbol
, newplist
;
709 CHECK_SYMBOL (symbol
);
710 XSYMBOL (symbol
)->plist
= newplist
;
714 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
715 doc
: /* Return minimum and maximum number of args allowed for SUBR.
716 SUBR must be a built-in function.
717 The returned value is a pair (MIN . MAX). MIN is the minimum number
718 of args. MAX is the maximum number or the symbol `many', for a
719 function with `&rest' args, or `unevalled' for a special form. */)
723 short minargs
, maxargs
;
725 minargs
= XSUBR (subr
)->min_args
;
726 maxargs
= XSUBR (subr
)->max_args
;
728 return Fcons (make_number (minargs
), Qmany
);
729 else if (maxargs
== UNEVALLED
)
730 return Fcons (make_number (minargs
), Qunevalled
);
732 return Fcons (make_number (minargs
), make_number (maxargs
));
735 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
736 doc
: /* Return name of subroutine SUBR.
737 SUBR must be a built-in function. */)
743 name
= XSUBR (subr
)->symbol_name
;
744 return make_string (name
, strlen (name
));
747 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
748 doc
: /* Return the interactive form of CMD or nil if none.
749 If CMD is not a command, the return value is nil.
750 Value, if non-nil, is a list \(interactive SPEC). */)
754 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
756 if (NILP (fun
) || EQ (fun
, Qunbound
))
759 /* Use an `interactive-form' property if present, analogous to the
760 function-documentation property. */
762 while (SYMBOLP (fun
))
764 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
768 fun
= Fsymbol_function (fun
);
773 char *spec
= XSUBR (fun
)->intspec
;
775 return list2 (Qinteractive
,
776 (*spec
!= '(') ? build_string (spec
) :
777 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
779 else if (COMPILEDP (fun
))
781 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
782 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
784 else if (CONSP (fun
))
786 Lisp_Object funcar
= XCAR (fun
);
787 if (EQ (funcar
, Qlambda
))
788 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
789 else if (EQ (funcar
, Qautoload
))
793 do_autoload (fun
, cmd
);
795 return Finteractive_form (cmd
);
802 /***********************************************************************
803 Getting and Setting Values of Symbols
804 ***********************************************************************/
806 /* Return the symbol holding SYMBOL's value. Signal
807 `cyclic-variable-indirection' if SYMBOL's chain of variable
808 indirections contains a loop. */
811 indirect_variable (symbol
)
814 Lisp_Object tortoise
, hare
;
816 hare
= tortoise
= symbol
;
818 while (XSYMBOL (hare
)->indirect_variable
)
820 hare
= XSYMBOL (hare
)->value
;
821 if (!XSYMBOL (hare
)->indirect_variable
)
824 hare
= XSYMBOL (hare
)->value
;
825 tortoise
= XSYMBOL (tortoise
)->value
;
827 if (EQ (hare
, tortoise
))
828 xsignal1 (Qcyclic_variable_indirection
, symbol
);
835 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
836 doc
: /* Return the variable at the end of OBJECT's variable chain.
837 If OBJECT is a symbol, follow all variable indirections and return the final
838 variable. If OBJECT is not a symbol, just return it.
839 Signal a cyclic-variable-indirection error if there is a loop in the
840 variable chain of symbols. */)
844 if (SYMBOLP (object
))
845 object
= indirect_variable (object
);
850 /* Given the raw contents of a symbol value cell,
851 return the Lisp value of the symbol.
852 This does not handle buffer-local variables; use
853 swap_in_symval_forwarding for that. */
856 do_symval_forwarding (valcontents
)
857 register Lisp_Object valcontents
;
859 register Lisp_Object val
;
861 if (MISCP (valcontents
))
862 switch (XMISCTYPE (valcontents
))
864 case Lisp_Misc_Intfwd
:
865 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
868 case Lisp_Misc_Boolfwd
:
869 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
871 case Lisp_Misc_Objfwd
:
872 return *XOBJFWD (valcontents
)->objvar
;
874 case Lisp_Misc_Buffer_Objfwd
:
875 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
876 return PER_BUFFER_VALUE (current_buffer
, offset
);
878 case Lisp_Misc_Kboard_Objfwd
:
879 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
880 /* We used to simply use current_kboard here, but from Lisp
881 code, it's value is often unexpected. It seems nicer to
882 allow constructions like this to work as intuitively expected:
884 (with-selected-frame frame
885 (define-key local-function-map "\eOP" [f1]))
887 On the other hand, this affects the semantics of
888 last-command and real-last-command, and people may rely on
889 that. I took a quick look at the Lisp codebase, and I
890 don't think anything will break. --lorentey */
891 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
896 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
897 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
898 buffer-independent contents of the value cell: forwarded just one
899 step past the buffer-localness.
901 BUF non-zero means set the value in buffer BUF instead of the
902 current buffer. This only plays a role for per-buffer variables. */
905 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
907 register Lisp_Object valcontents
, newval
;
910 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
913 switch (XMISCTYPE (valcontents
))
915 case Lisp_Misc_Intfwd
:
916 CHECK_NUMBER (newval
);
917 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
918 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
919 error ("Value out of range for variable `%s'",
920 SDATA (SYMBOL_NAME (symbol
)));
923 case Lisp_Misc_Boolfwd
:
924 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
927 case Lisp_Misc_Objfwd
:
928 *XOBJFWD (valcontents
)->objvar
= newval
;
930 /* If this variable is a default for something stored
931 in the buffer itself, such as default-fill-column,
932 find the buffers that don't have local values for it
934 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
935 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
937 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
938 - (char *) &buffer_defaults
);
939 int idx
= PER_BUFFER_IDX (offset
);
946 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
951 buf
= Fcdr (XCAR (tail
));
952 if (!BUFFERP (buf
)) continue;
955 if (! PER_BUFFER_VALUE_P (b
, idx
))
956 PER_BUFFER_VALUE (b
, offset
) = newval
;
961 case Lisp_Misc_Buffer_Objfwd
:
963 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
966 type
= PER_BUFFER_TYPE (offset
);
967 if (! NILP (type
) && ! NILP (newval
)
968 && XTYPE (newval
) != XINT (type
))
969 buffer_slot_type_mismatch (offset
);
972 buf
= current_buffer
;
973 PER_BUFFER_VALUE (buf
, offset
) = newval
;
977 case Lisp_Misc_Kboard_Objfwd
:
979 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
980 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
981 *(Lisp_Object
*) p
= newval
;
992 valcontents
= SYMBOL_VALUE (symbol
);
993 if (BUFFER_LOCAL_VALUEP (valcontents
)
994 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
995 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
997 SET_SYMBOL_VALUE (symbol
, newval
);
1001 /* Set up SYMBOL to refer to its global binding.
1002 This makes it safe to alter the status of other bindings. */
1005 swap_in_global_binding (symbol
)
1008 Lisp_Object valcontents
, cdr
;
1010 valcontents
= SYMBOL_VALUE (symbol
);
1011 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1012 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1014 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1016 /* Unload the previously loaded binding. */
1017 Fsetcdr (XCAR (cdr
),
1018 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1020 /* Select the global binding in the symbol. */
1022 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1024 /* Indicate that the global binding is set up now. */
1025 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1026 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1027 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1028 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1031 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1032 VALCONTENTS is the contents of its value cell,
1033 which points to a struct Lisp_Buffer_Local_Value.
1035 Return the value forwarded one step past the buffer-local stage.
1036 This could be another forwarding pointer. */
1039 swap_in_symval_forwarding (symbol
, valcontents
)
1040 Lisp_Object symbol
, valcontents
;
1042 register Lisp_Object tem1
;
1044 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1047 || current_buffer
!= XBUFFER (tem1
)
1048 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1049 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1051 if (XSYMBOL (symbol
)->indirect_variable
)
1052 symbol
= indirect_variable (symbol
);
1054 /* Unload the previously loaded binding. */
1055 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1057 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1058 /* Choose the new binding. */
1059 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1060 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1061 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1064 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1065 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1067 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1069 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1072 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1074 /* Load the new binding. */
1075 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1076 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1077 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1078 store_symval_forwarding (symbol
,
1079 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1082 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1085 /* Find the value of a symbol, returning Qunbound if it's not bound.
1086 This is helpful for code which just wants to get a variable's value
1087 if it has one, without signaling an error.
1088 Note that it must not be possible to quit
1089 within this function. Great care is required for this. */
1092 find_symbol_value (symbol
)
1095 register Lisp_Object valcontents
;
1096 register Lisp_Object val
;
1098 CHECK_SYMBOL (symbol
);
1099 valcontents
= SYMBOL_VALUE (symbol
);
1101 if (BUFFER_LOCAL_VALUEP (valcontents
)
1102 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1103 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1105 if (MISCP (valcontents
))
1107 switch (XMISCTYPE (valcontents
))
1109 case Lisp_Misc_Intfwd
:
1110 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1113 case Lisp_Misc_Boolfwd
:
1114 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1116 case Lisp_Misc_Objfwd
:
1117 return *XOBJFWD (valcontents
)->objvar
;
1119 case Lisp_Misc_Buffer_Objfwd
:
1120 return PER_BUFFER_VALUE (current_buffer
,
1121 XBUFFER_OBJFWD (valcontents
)->offset
);
1123 case Lisp_Misc_Kboard_Objfwd
:
1124 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1125 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1132 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1133 doc
: /* Return SYMBOL's value. Error if that is void. */)
1139 val
= find_symbol_value (symbol
);
1140 if (!EQ (val
, Qunbound
))
1143 xsignal1 (Qvoid_variable
, symbol
);
1146 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1147 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1149 register Lisp_Object symbol
, newval
;
1151 return set_internal (symbol
, newval
, current_buffer
, 0);
1154 /* Return 1 if SYMBOL currently has a let-binding
1155 which was made in the buffer that is now current. */
1158 let_shadows_buffer_binding_p (symbol
)
1161 volatile struct specbinding
*p
;
1163 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1165 && CONSP (p
->symbol
))
1167 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1168 if ((EQ (symbol
, let_bound_symbol
)
1169 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1170 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1171 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1175 return p
>= specpdl
;
1178 /* Store the value NEWVAL into SYMBOL.
1179 If buffer-locality is an issue, BUF specifies which buffer to use.
1180 (0 stands for the current buffer.)
1182 If BINDFLAG is zero, then if this symbol is supposed to become
1183 local in every buffer where it is set, then we make it local.
1184 If BINDFLAG is nonzero, we don't do that. */
1187 set_internal (symbol
, newval
, buf
, bindflag
)
1188 register Lisp_Object symbol
, newval
;
1192 int voide
= EQ (newval
, Qunbound
);
1194 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1197 buf
= current_buffer
;
1199 /* If restoring in a dead buffer, do nothing. */
1200 if (NILP (buf
->name
))
1203 CHECK_SYMBOL (symbol
);
1204 if (SYMBOL_CONSTANT_P (symbol
)
1205 && (NILP (Fkeywordp (symbol
))
1206 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1207 xsignal1 (Qsetting_constant
, symbol
);
1209 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1211 if (BUFFER_OBJFWDP (valcontents
))
1213 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1214 int idx
= PER_BUFFER_IDX (offset
);
1217 && !let_shadows_buffer_binding_p (symbol
))
1218 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1220 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1221 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1223 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1224 if (XSYMBOL (symbol
)->indirect_variable
)
1225 symbol
= indirect_variable (symbol
);
1227 /* What binding is loaded right now? */
1228 current_alist_element
1229 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1231 /* If the current buffer is not the buffer whose binding is
1232 loaded, or if there may be frame-local bindings and the frame
1233 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1234 the default binding is loaded, the loaded binding may be the
1236 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1237 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1238 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1239 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1240 || (BUFFER_LOCAL_VALUEP (valcontents
)
1241 && EQ (XCAR (current_alist_element
),
1242 current_alist_element
)))
1244 /* The currently loaded binding is not necessarily valid.
1245 We need to unload it, and choose a new binding. */
1247 /* Write out `realvalue' to the old loaded binding. */
1248 Fsetcdr (current_alist_element
,
1249 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1251 /* Find the new binding. */
1252 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1253 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1254 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1258 /* This buffer still sees the default value. */
1260 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1261 or if this is `let' rather than `set',
1262 make CURRENT-ALIST-ELEMENT point to itself,
1263 indicating that we're seeing the default value.
1264 Likewise if the variable has been let-bound
1265 in the current buffer. */
1266 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1267 || let_shadows_buffer_binding_p (symbol
))
1269 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1271 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1272 tem1
= Fassq (symbol
,
1273 XFRAME (selected_frame
)->param_alist
);
1276 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1278 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1280 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1281 and we're not within a let that was made for this buffer,
1282 create a new buffer-local binding for the variable.
1283 That means, give this buffer a new assoc for a local value
1284 and load that binding. */
1287 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1288 buf
->local_var_alist
1289 = Fcons (tem1
, buf
->local_var_alist
);
1293 /* Record which binding is now loaded. */
1294 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1297 /* Set `buffer' and `frame' slots for the binding now loaded. */
1298 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1299 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1301 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1304 /* If storing void (making the symbol void), forward only through
1305 buffer-local indicator, not through Lisp_Objfwd, etc. */
1307 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1309 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1311 /* If we just set a variable whose current binding is frame-local,
1312 store the new value in the frame parameter too. */
1314 if (BUFFER_LOCAL_VALUEP (valcontents
)
1315 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1317 /* What binding is loaded right now? */
1318 current_alist_element
1319 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1321 /* If the current buffer is not the buffer whose binding is
1322 loaded, or if there may be frame-local bindings and the frame
1323 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1324 the default binding is loaded, the loaded binding may be the
1326 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1327 XSETCDR (current_alist_element
, newval
);
1333 /* Access or set a buffer-local symbol's default value. */
1335 /* Return the default value of SYMBOL, but don't check for voidness.
1336 Return Qunbound if it is void. */
1339 default_value (symbol
)
1342 register Lisp_Object valcontents
;
1344 CHECK_SYMBOL (symbol
);
1345 valcontents
= SYMBOL_VALUE (symbol
);
1347 /* For a built-in buffer-local variable, get the default value
1348 rather than letting do_symval_forwarding get the current value. */
1349 if (BUFFER_OBJFWDP (valcontents
))
1351 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1352 if (PER_BUFFER_IDX (offset
) != 0)
1353 return PER_BUFFER_DEFAULT (offset
);
1356 /* Handle user-created local variables. */
1357 if (BUFFER_LOCAL_VALUEP (valcontents
)
1358 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1360 /* If var is set up for a buffer that lacks a local value for it,
1361 the current value is nominally the default value.
1362 But the `realvalue' slot may be more up to date, since
1363 ordinary setq stores just that slot. So use that. */
1364 Lisp_Object current_alist_element
, alist_element_car
;
1365 current_alist_element
1366 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1367 alist_element_car
= XCAR (current_alist_element
);
1368 if (EQ (alist_element_car
, current_alist_element
))
1369 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1371 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1373 /* For other variables, get the current value. */
1374 return do_symval_forwarding (valcontents
);
1377 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1378 doc
: /* Return t if SYMBOL has a non-void default value.
1379 This is the value that is seen in buffers that do not have their own values
1380 for this variable. */)
1384 register Lisp_Object value
;
1386 value
= default_value (symbol
);
1387 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1390 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1391 doc
: /* Return SYMBOL's default value.
1392 This is the value that is seen in buffers that do not have their own values
1393 for this variable. The default value is meaningful for variables with
1394 local bindings in certain buffers. */)
1398 register Lisp_Object value
;
1400 value
= default_value (symbol
);
1401 if (!EQ (value
, Qunbound
))
1404 xsignal1 (Qvoid_variable
, symbol
);
1407 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1408 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1409 The default value is seen in buffers that do not have their own values
1410 for this variable. */)
1412 Lisp_Object symbol
, value
;
1414 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1416 CHECK_SYMBOL (symbol
);
1417 valcontents
= SYMBOL_VALUE (symbol
);
1419 /* Handle variables like case-fold-search that have special slots
1420 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1422 if (BUFFER_OBJFWDP (valcontents
))
1424 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1425 int idx
= PER_BUFFER_IDX (offset
);
1427 PER_BUFFER_DEFAULT (offset
) = value
;
1429 /* If this variable is not always local in all buffers,
1430 set it in the buffers that don't nominally have a local value. */
1435 for (b
= all_buffers
; b
; b
= b
->next
)
1436 if (!PER_BUFFER_VALUE_P (b
, idx
))
1437 PER_BUFFER_VALUE (b
, offset
) = value
;
1442 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1443 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1444 return Fset (symbol
, value
);
1446 /* Store new value into the DEFAULT-VALUE slot. */
1447 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1449 /* If the default binding is now loaded, set the REALVALUE slot too. */
1450 current_alist_element
1451 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1452 alist_element_buffer
= Fcar (current_alist_element
);
1453 if (EQ (alist_element_buffer
, current_alist_element
))
1454 store_symval_forwarding (symbol
,
1455 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1461 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1462 doc
: /* Set the default value of variable VAR to VALUE.
1463 VAR, the variable name, is literal (not evaluated);
1464 VALUE is an expression: it is evaluated and its value returned.
1465 The default value of a variable is seen in buffers
1466 that do not have their own values for the variable.
1468 More generally, you can use multiple variables and values, as in
1469 (setq-default VAR VALUE VAR VALUE...)
1470 This sets each VAR's default value to the corresponding VALUE.
1471 The VALUE for the Nth VAR can refer to the new default values
1473 usage: (setq-default [VAR VALUE]...) */)
1477 register Lisp_Object args_left
;
1478 register Lisp_Object val
, symbol
;
1479 struct gcpro gcpro1
;
1489 val
= Feval (Fcar (Fcdr (args_left
)));
1490 symbol
= XCAR (args_left
);
1491 Fset_default (symbol
, val
);
1492 args_left
= Fcdr (XCDR (args_left
));
1494 while (!NILP (args_left
));
1500 /* Lisp functions for creating and removing buffer-local variables. */
1502 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1503 1, 1, "vMake Variable Buffer Local: ",
1504 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1505 At any time, the value for the current buffer is in effect,
1506 unless the variable has never been set in this buffer,
1507 in which case the default value is in effect.
1508 Note that binding the variable with `let', or setting it while
1509 a `let'-style binding made in this buffer is in effect,
1510 does not make the variable buffer-local. Return VARIABLE.
1512 In most cases it is better to use `make-local-variable',
1513 which makes a variable local in just one buffer.
1515 The function `default-value' gets the default value and `set-default' sets it. */)
1517 register Lisp_Object variable
;
1519 register Lisp_Object tem
, valcontents
, newval
;
1521 CHECK_SYMBOL (variable
);
1522 variable
= indirect_variable (variable
);
1524 valcontents
= SYMBOL_VALUE (variable
);
1525 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1526 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1528 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1530 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1532 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1535 if (EQ (valcontents
, Qunbound
))
1536 SET_SYMBOL_VALUE (variable
, Qnil
);
1537 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1539 newval
= allocate_misc ();
1540 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1541 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1542 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1543 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1544 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1545 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1546 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1547 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1548 SET_SYMBOL_VALUE (variable
, newval
);
1552 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1553 1, 1, "vMake Local Variable: ",
1554 doc
: /* Make VARIABLE have a separate value in the current buffer.
1555 Other buffers will continue to share a common default value.
1556 \(The buffer-local value of VARIABLE starts out as the same value
1557 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1560 If the variable is already arranged to become local when set,
1561 this function causes a local value to exist for this buffer,
1562 just as setting the variable would do.
1564 This function returns VARIABLE, and therefore
1565 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1568 See also `make-variable-buffer-local'.
1570 Do not use `make-local-variable' to make a hook variable buffer-local.
1571 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1573 register Lisp_Object variable
;
1575 register Lisp_Object tem
, valcontents
;
1577 CHECK_SYMBOL (variable
);
1578 variable
= indirect_variable (variable
);
1580 valcontents
= SYMBOL_VALUE (variable
);
1581 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1582 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1584 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1586 tem
= Fboundp (variable
);
1588 /* Make sure the symbol has a local value in this particular buffer,
1589 by setting it to the same value it already has. */
1590 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1593 /* Make sure symbol is set up to hold per-buffer values. */
1594 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1597 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1599 newval
= allocate_misc ();
1600 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1601 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1602 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1603 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1604 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1605 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1606 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1607 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1608 SET_SYMBOL_VALUE (variable
, newval
);
1610 /* Make sure this buffer has its own value of symbol. */
1611 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1614 /* Swap out any local binding for some other buffer, and make
1615 sure the current value is permanently recorded, if it's the
1617 find_symbol_value (variable
);
1619 current_buffer
->local_var_alist
1620 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1621 current_buffer
->local_var_alist
);
1623 /* Make sure symbol does not think it is set up for this buffer;
1624 force it to look once again for this buffer's value. */
1626 Lisp_Object
*pvalbuf
;
1628 valcontents
= SYMBOL_VALUE (variable
);
1630 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1631 if (current_buffer
== XBUFFER (*pvalbuf
))
1633 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1637 /* If the symbol forwards into a C variable, then load the binding
1638 for this buffer now. If C code modifies the variable before we
1639 load the binding in, then that new value will clobber the default
1640 binding the next time we unload it. */
1641 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1642 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1643 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1648 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1649 1, 1, "vKill Local Variable: ",
1650 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1651 From now on the default value will apply in this buffer. Return VARIABLE. */)
1653 register Lisp_Object variable
;
1655 register Lisp_Object tem
, valcontents
;
1657 CHECK_SYMBOL (variable
);
1658 variable
= indirect_variable (variable
);
1660 valcontents
= SYMBOL_VALUE (variable
);
1662 if (BUFFER_OBJFWDP (valcontents
))
1664 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1665 int idx
= PER_BUFFER_IDX (offset
);
1669 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1670 PER_BUFFER_VALUE (current_buffer
, offset
)
1671 = PER_BUFFER_DEFAULT (offset
);
1676 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1677 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1680 /* Get rid of this buffer's alist element, if any. */
1682 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1684 current_buffer
->local_var_alist
1685 = Fdelq (tem
, current_buffer
->local_var_alist
);
1687 /* If the symbol is set up with the current buffer's binding
1688 loaded, recompute its value. We have to do it now, or else
1689 forwarded objects won't work right. */
1691 Lisp_Object
*pvalbuf
, buf
;
1692 valcontents
= SYMBOL_VALUE (variable
);
1693 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1694 XSETBUFFER (buf
, current_buffer
);
1695 if (EQ (buf
, *pvalbuf
))
1698 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1699 find_symbol_value (variable
);
1706 /* Lisp functions for creating and removing buffer-local variables. */
1708 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1709 1, 1, "vMake Variable Frame Local: ",
1710 doc
: /* Enable VARIABLE to have frame-local bindings.
1711 This does not create any frame-local bindings for VARIABLE,
1712 it just makes them possible.
1714 A frame-local binding is actually a frame parameter value.
1715 If a frame F has a value for the frame parameter named VARIABLE,
1716 that also acts as a frame-local binding for VARIABLE in F--
1717 provided this function has been called to enable VARIABLE
1718 to have frame-local bindings at all.
1720 The only way to create a frame-local binding for VARIABLE in a frame
1721 is to set the VARIABLE frame parameter of that frame. See
1722 `modify-frame-parameters' for how to set frame parameters.
1724 Buffer-local bindings take precedence over frame-local bindings. */)
1726 register Lisp_Object variable
;
1728 register Lisp_Object tem
, valcontents
, newval
;
1730 CHECK_SYMBOL (variable
);
1731 variable
= indirect_variable (variable
);
1733 valcontents
= SYMBOL_VALUE (variable
);
1734 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1735 || BUFFER_OBJFWDP (valcontents
))
1736 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1738 if (BUFFER_LOCAL_VALUEP (valcontents
)
1739 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1741 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1745 if (EQ (valcontents
, Qunbound
))
1746 SET_SYMBOL_VALUE (variable
, Qnil
);
1747 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1749 newval
= allocate_misc ();
1750 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1751 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1752 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1753 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1754 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1755 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1756 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1757 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1758 SET_SYMBOL_VALUE (variable
, newval
);
1762 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1764 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1765 BUFFER defaults to the current buffer. */)
1767 register Lisp_Object variable
, buffer
;
1769 Lisp_Object valcontents
;
1770 register struct buffer
*buf
;
1773 buf
= current_buffer
;
1776 CHECK_BUFFER (buffer
);
1777 buf
= XBUFFER (buffer
);
1780 CHECK_SYMBOL (variable
);
1781 variable
= indirect_variable (variable
);
1783 valcontents
= SYMBOL_VALUE (variable
);
1784 if (BUFFER_LOCAL_VALUEP (valcontents
)
1785 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1787 Lisp_Object tail
, elt
;
1789 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1792 if (EQ (variable
, XCAR (elt
)))
1796 if (BUFFER_OBJFWDP (valcontents
))
1798 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1799 int idx
= PER_BUFFER_IDX (offset
);
1800 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1806 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1808 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1809 More precisely, this means that setting the variable \(with `set' or`setq'),
1810 while it does not have a `let'-style binding that was made in BUFFER,
1811 will produce a buffer local binding. See Info node
1812 `(elisp)Creating Buffer-Local'.
1813 BUFFER defaults to the current buffer. */)
1815 register Lisp_Object variable
, buffer
;
1817 Lisp_Object valcontents
;
1818 register struct buffer
*buf
;
1821 buf
= current_buffer
;
1824 CHECK_BUFFER (buffer
);
1825 buf
= XBUFFER (buffer
);
1828 CHECK_SYMBOL (variable
);
1829 variable
= indirect_variable (variable
);
1831 valcontents
= SYMBOL_VALUE (variable
);
1833 /* This means that make-variable-buffer-local was done. */
1834 if (BUFFER_LOCAL_VALUEP (valcontents
))
1836 /* All these slots become local if they are set. */
1837 if (BUFFER_OBJFWDP (valcontents
))
1839 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1841 Lisp_Object tail
, elt
;
1842 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1845 if (EQ (variable
, XCAR (elt
)))
1852 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1854 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1855 If the current binding is buffer-local, the value is the current buffer.
1856 If the current binding is frame-local, the value is the selected frame.
1857 If the current binding is global (the default), the value is nil. */)
1859 register Lisp_Object variable
;
1861 Lisp_Object valcontents
;
1863 CHECK_SYMBOL (variable
);
1864 variable
= indirect_variable (variable
);
1866 /* Make sure the current binding is actually swapped in. */
1867 find_symbol_value (variable
);
1869 valcontents
= XSYMBOL (variable
)->value
;
1871 if (BUFFER_LOCAL_VALUEP (valcontents
)
1872 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1873 || BUFFER_OBJFWDP (valcontents
))
1875 /* For a local variable, record both the symbol and which
1876 buffer's or frame's value we are saving. */
1877 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1878 return Fcurrent_buffer ();
1879 else if (!BUFFER_OBJFWDP (valcontents
)
1880 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1881 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1887 /* This code is disabled now that we use the selected frame to return
1888 keyboard-local-values. */
1890 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1892 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1893 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1894 If SYMBOL is not a terminal-local variable, then return its normal
1895 value, like `symbol-value'.
1897 TERMINAL may be a terminal id, a frame, or nil (meaning the
1898 selected frame's terminal device). */)
1901 Lisp_Object terminal
;
1904 struct terminal
*t
= get_terminal (terminal
, 1);
1905 push_kboard (t
->kboard
);
1906 result
= Fsymbol_value (symbol
);
1911 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1912 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1913 If VARIABLE is not a terminal-local variable, then set its normal
1914 binding, like `set'.
1916 TERMINAL may be a terminal id, a frame, or nil (meaning the
1917 selected frame's terminal device). */)
1918 (symbol
, terminal
, value
)
1920 Lisp_Object terminal
;
1924 struct terminal
*t
= get_terminal (terminal
, 1);
1925 push_kboard (d
->kboard
);
1926 result
= Fset (symbol
, value
);
1932 /* Find the function at the end of a chain of symbol function indirections. */
1934 /* If OBJECT is a symbol, find the end of its function chain and
1935 return the value found there. If OBJECT is not a symbol, just
1936 return it. If there is a cycle in the function chain, signal a
1937 cyclic-function-indirection error.
1939 This is like Findirect_function, except that it doesn't signal an
1940 error if the chain ends up unbound. */
1942 indirect_function (object
)
1943 register Lisp_Object object
;
1945 Lisp_Object tortoise
, hare
;
1947 hare
= tortoise
= object
;
1951 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1953 hare
= XSYMBOL (hare
)->function
;
1954 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1956 hare
= XSYMBOL (hare
)->function
;
1958 tortoise
= XSYMBOL (tortoise
)->function
;
1960 if (EQ (hare
, tortoise
))
1961 xsignal1 (Qcyclic_function_indirection
, object
);
1967 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1968 doc
: /* Return the function at the end of OBJECT's function chain.
1969 If OBJECT is not a symbol, just return it. Otherwise, follow all
1970 function indirections to find the final function binding and return it.
1971 If the final symbol in the chain is unbound, signal a void-function error.
1972 Optional arg NOERROR non-nil means to return nil instead of signalling.
1973 Signal a cyclic-function-indirection error if there is a loop in the
1974 function chain of symbols. */)
1976 register Lisp_Object object
;
1977 Lisp_Object noerror
;
1981 /* Optimize for no indirection. */
1983 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1984 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1985 result
= indirect_function (result
);
1986 if (!EQ (result
, Qunbound
))
1990 xsignal1 (Qvoid_function
, object
);
1995 /* Extract and set vector and string elements */
1997 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1998 doc
: /* Return the element of ARRAY at index IDX.
1999 ARRAY may be a vector, a string, a char-table, a bool-vector,
2000 or a byte-code object. IDX starts at 0. */)
2002 register Lisp_Object array
;
2005 register int idxval
;
2008 idxval
= XINT (idx
);
2009 if (STRINGP (array
))
2013 if (idxval
< 0 || idxval
>= SCHARS (array
))
2014 args_out_of_range (array
, idx
);
2015 if (! STRING_MULTIBYTE (array
))
2016 return make_number ((unsigned char) SREF (array
, idxval
));
2017 idxval_byte
= string_char_to_byte (array
, idxval
);
2019 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2020 SBYTES (array
) - idxval_byte
);
2021 return make_number (c
);
2023 else if (BOOL_VECTOR_P (array
))
2027 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2028 args_out_of_range (array
, idx
);
2030 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2031 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2033 else if (CHAR_TABLE_P (array
))
2040 args_out_of_range (array
, idx
);
2041 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2043 if (! SINGLE_BYTE_CHAR_P (idxval
))
2044 args_out_of_range (array
, idx
);
2045 /* For ASCII and 8-bit European characters, the element is
2046 stored in the top table. */
2047 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2051 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2052 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2053 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2054 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2057 val
= XCHAR_TABLE (array
)->defalt
;
2058 while (NILP (val
)) /* Follow parents until we find some value. */
2060 array
= XCHAR_TABLE (array
)->parent
;
2063 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2065 val
= XCHAR_TABLE (array
)->defalt
;
2072 Lisp_Object sub_table
;
2073 Lisp_Object current_default
;
2075 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2076 if (code
[1] < 32) code
[1] = -1;
2077 else if (code
[2] < 32) code
[2] = -1;
2079 /* Here, the possible range of CODE[0] (== charset ID) is
2080 128..MAX_CHARSET. Since the top level char table contains
2081 data for multibyte characters after 256th element, we must
2082 increment CODE[0] by 128 to get a correct index. */
2084 code
[3] = -1; /* anchor */
2086 try_parent_char_table
:
2087 current_default
= XCHAR_TABLE (array
)->defalt
;
2089 for (i
= 0; code
[i
] >= 0; i
++)
2091 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2092 if (SUB_CHAR_TABLE_P (val
))
2095 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2096 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2101 val
= current_default
;
2104 array
= XCHAR_TABLE (array
)->parent
;
2106 goto try_parent_char_table
;
2111 /* Reaching here means IDXVAL is a generic character in
2112 which each character or a group has independent value.
2113 Essentially it's nonsense to get a value for such a
2114 generic character, but for backward compatibility, we try
2115 the default value and parent. */
2116 val
= current_default
;
2119 array
= XCHAR_TABLE (array
)->parent
;
2121 goto try_parent_char_table
;
2129 if (VECTORP (array
))
2130 size
= XVECTOR (array
)->size
;
2131 else if (COMPILEDP (array
))
2132 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2134 wrong_type_argument (Qarrayp
, array
);
2136 if (idxval
< 0 || idxval
>= size
)
2137 args_out_of_range (array
, idx
);
2138 return XVECTOR (array
)->contents
[idxval
];
2142 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2143 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2144 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2145 bool-vector. IDX starts at 0. */)
2146 (array
, idx
, newelt
)
2147 register Lisp_Object array
;
2148 Lisp_Object idx
, newelt
;
2150 register int idxval
;
2153 idxval
= XINT (idx
);
2154 CHECK_ARRAY (array
, Qarrayp
);
2155 CHECK_IMPURE (array
);
2157 if (VECTORP (array
))
2159 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2160 args_out_of_range (array
, idx
);
2161 XVECTOR (array
)->contents
[idxval
] = newelt
;
2163 else if (BOOL_VECTOR_P (array
))
2167 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2168 args_out_of_range (array
, idx
);
2170 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2172 if (! NILP (newelt
))
2173 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2175 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2176 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2178 else if (CHAR_TABLE_P (array
))
2181 args_out_of_range (array
, idx
);
2182 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2184 if (! SINGLE_BYTE_CHAR_P (idxval
))
2185 args_out_of_range (array
, idx
);
2186 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2193 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2194 if (code
[1] < 32) code
[1] = -1;
2195 else if (code
[2] < 32) code
[2] = -1;
2197 /* See the comment of the corresponding part in Faref. */
2199 code
[3] = -1; /* anchor */
2200 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2202 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2203 if (SUB_CHAR_TABLE_P (val
))
2209 /* VAL is a leaf. Create a sub char table with the
2210 initial value VAL and look into it. */
2212 temp
= make_sub_char_table (val
);
2213 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2217 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2220 else if (STRING_MULTIBYTE (array
))
2222 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2223 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2225 if (idxval
< 0 || idxval
>= SCHARS (array
))
2226 args_out_of_range (array
, idx
);
2227 CHECK_NUMBER (newelt
);
2229 nbytes
= SBYTES (array
);
2231 idxval_byte
= string_char_to_byte (array
, idxval
);
2232 p1
= SDATA (array
) + idxval_byte
;
2233 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2234 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2235 if (prev_bytes
!= new_bytes
)
2237 /* We must relocate the string data. */
2238 int nchars
= SCHARS (array
);
2242 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2243 bcopy (SDATA (array
), str
, nbytes
);
2244 allocate_string_data (XSTRING (array
), nchars
,
2245 nbytes
+ new_bytes
- prev_bytes
);
2246 bcopy (str
, SDATA (array
), idxval_byte
);
2247 p1
= SDATA (array
) + idxval_byte
;
2248 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2249 nbytes
- (idxval_byte
+ prev_bytes
));
2251 clear_string_char_byte_cache ();
2258 if (idxval
< 0 || idxval
>= SCHARS (array
))
2259 args_out_of_range (array
, idx
);
2260 CHECK_NUMBER (newelt
);
2262 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2263 SSET (array
, idxval
, XINT (newelt
));
2266 /* We must relocate the string data while converting it to
2268 int idxval_byte
, prev_bytes
, new_bytes
;
2269 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2270 unsigned char *origstr
= SDATA (array
), *str
;
2274 nchars
= SCHARS (array
);
2275 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2276 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2278 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2279 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2280 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2282 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2283 allocate_string_data (XSTRING (array
), nchars
,
2284 nbytes
+ new_bytes
- prev_bytes
);
2285 bcopy (str
, SDATA (array
), idxval_byte
);
2286 p1
= SDATA (array
) + idxval_byte
;
2289 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2290 nbytes
- (idxval_byte
+ prev_bytes
));
2292 clear_string_char_byte_cache ();
2299 /* Arithmetic functions */
2301 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2304 arithcompare (num1
, num2
, comparison
)
2305 Lisp_Object num1
, num2
;
2306 enum comparison comparison
;
2308 double f1
= 0, f2
= 0;
2311 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2312 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2314 if (FLOATP (num1
) || FLOATP (num2
))
2317 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2318 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2324 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2329 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2334 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2339 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2344 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2349 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2358 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2359 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2361 register Lisp_Object num1
, num2
;
2363 return arithcompare (num1
, num2
, equal
);
2366 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2367 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2369 register Lisp_Object num1
, num2
;
2371 return arithcompare (num1
, num2
, less
);
2374 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2375 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2377 register Lisp_Object num1
, num2
;
2379 return arithcompare (num1
, num2
, grtr
);
2382 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2383 doc
: /* Return t if first arg is less than or equal to second arg.
2384 Both must be numbers or markers. */)
2386 register Lisp_Object num1
, num2
;
2388 return arithcompare (num1
, num2
, less_or_equal
);
2391 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2392 doc
: /* Return t if first arg is greater than or equal to second arg.
2393 Both must be numbers or markers. */)
2395 register Lisp_Object num1
, num2
;
2397 return arithcompare (num1
, num2
, grtr_or_equal
);
2400 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2401 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2403 register Lisp_Object num1
, num2
;
2405 return arithcompare (num1
, num2
, notequal
);
2408 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2409 doc
: /* Return t if NUMBER is zero. */)
2411 register Lisp_Object number
;
2413 CHECK_NUMBER_OR_FLOAT (number
);
2415 if (FLOATP (number
))
2417 if (XFLOAT_DATA (number
) == 0.0)
2427 /* Convert between long values and pairs of Lisp integers.
2428 Note that long_to_cons returns a single Lisp integer
2429 when the value fits in one. */
2435 unsigned long top
= i
>> 16;
2436 unsigned int bot
= i
& 0xFFFF;
2438 return make_number (bot
);
2439 if (top
== (unsigned long)-1 >> 16)
2440 return Fcons (make_number (-1), make_number (bot
));
2441 return Fcons (make_number (top
), make_number (bot
));
2448 Lisp_Object top
, bot
;
2455 return ((XINT (top
) << 16) | XINT (bot
));
2458 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2459 doc
: /* Return the decimal representation of NUMBER as a string.
2460 Uses a minus sign if negative.
2461 NUMBER may be an integer or a floating point number. */)
2465 char buffer
[VALBITS
];
2467 CHECK_NUMBER_OR_FLOAT (number
);
2469 if (FLOATP (number
))
2471 char pigbuf
[350]; /* see comments in float_to_string */
2473 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2474 return build_string (pigbuf
);
2477 if (sizeof (int) == sizeof (EMACS_INT
))
2478 sprintf (buffer
, "%d", XINT (number
));
2479 else if (sizeof (long) == sizeof (EMACS_INT
))
2480 sprintf (buffer
, "%ld", (long) XINT (number
));
2483 return build_string (buffer
);
2487 digit_to_number (character
, base
)
2488 int character
, base
;
2492 if (character
>= '0' && character
<= '9')
2493 digit
= character
- '0';
2494 else if (character
>= 'a' && character
<= 'z')
2495 digit
= character
- 'a' + 10;
2496 else if (character
>= 'A' && character
<= 'Z')
2497 digit
= character
- 'A' + 10;
2507 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2508 doc
: /* Parse STRING as a decimal number and return the number.
2509 This parses both integers and floating point numbers.
2510 It ignores leading spaces and tabs.
2512 If BASE, interpret STRING as a number in that base. If BASE isn't
2513 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2514 If the base used is not 10, floating point is not recognized. */)
2516 register Lisp_Object string
, base
;
2518 register unsigned char *p
;
2523 CHECK_STRING (string
);
2529 CHECK_NUMBER (base
);
2531 if (b
< 2 || b
> 16)
2532 xsignal1 (Qargs_out_of_range
, base
);
2535 /* Skip any whitespace at the front of the number. Some versions of
2536 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2538 while (*p
== ' ' || *p
== '\t')
2549 if (isfloat_string (p
) && b
== 10)
2550 val
= make_float (sign
* atof (p
));
2557 int digit
= digit_to_number (*p
++, b
);
2563 val
= make_fixnum_or_float (sign
* v
);
2583 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2584 int, Lisp_Object
*));
2585 extern Lisp_Object
fmod_float ();
2588 arith_driver (code
, nargs
, args
)
2591 register Lisp_Object
*args
;
2593 register Lisp_Object val
;
2594 register int argnum
;
2595 register EMACS_INT accum
= 0;
2596 register EMACS_INT next
;
2598 switch (SWITCH_ENUM_CAST (code
))
2616 for (argnum
= 0; argnum
< nargs
; argnum
++)
2618 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2620 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2623 return float_arith_driver ((double) accum
, argnum
, code
,
2626 next
= XINT (args
[argnum
]);
2627 switch (SWITCH_ENUM_CAST (code
))
2633 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2644 xsignal0 (Qarith_error
);
2658 if (!argnum
|| next
> accum
)
2662 if (!argnum
|| next
< accum
)
2668 XSETINT (val
, accum
);
2673 #define isnan(x) ((x) != (x))
2676 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2678 register int argnum
;
2681 register Lisp_Object
*args
;
2683 register Lisp_Object val
;
2686 for (; argnum
< nargs
; argnum
++)
2688 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2689 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2693 next
= XFLOAT_DATA (val
);
2697 args
[argnum
] = val
; /* runs into a compiler bug. */
2698 next
= XINT (args
[argnum
]);
2700 switch (SWITCH_ENUM_CAST (code
))
2706 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2716 if (! IEEE_FLOATING_POINT
&& next
== 0)
2717 xsignal0 (Qarith_error
);
2724 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2726 if (!argnum
|| isnan (next
) || next
> accum
)
2730 if (!argnum
|| isnan (next
) || next
< accum
)
2736 return make_float (accum
);
2740 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2741 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2742 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2747 return arith_driver (Aadd
, nargs
, args
);
2750 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2751 doc
: /* Negate number or subtract numbers or markers and return the result.
2752 With one arg, negates it. With more than one arg,
2753 subtracts all but the first from the first.
2754 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2759 return arith_driver (Asub
, nargs
, args
);
2762 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2763 doc
: /* Return product of any number of arguments, which are numbers or markers.
2764 usage: (* &rest NUMBERS-OR-MARKERS) */)
2769 return arith_driver (Amult
, nargs
, args
);
2772 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2773 doc
: /* Return first argument divided by all the remaining arguments.
2774 The arguments must be numbers or markers.
2775 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2781 for (argnum
= 2; argnum
< nargs
; argnum
++)
2782 if (FLOATP (args
[argnum
]))
2783 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2784 return arith_driver (Adiv
, nargs
, args
);
2787 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2788 doc
: /* Return remainder of X divided by Y.
2789 Both must be integers or markers. */)
2791 register Lisp_Object x
, y
;
2795 CHECK_NUMBER_COERCE_MARKER (x
);
2796 CHECK_NUMBER_COERCE_MARKER (y
);
2798 if (XFASTINT (y
) == 0)
2799 xsignal0 (Qarith_error
);
2801 XSETINT (val
, XINT (x
) % XINT (y
));
2815 /* If the magnitude of the result exceeds that of the divisor, or
2816 the sign of the result does not agree with that of the dividend,
2817 iterate with the reduced value. This does not yield a
2818 particularly accurate result, but at least it will be in the
2819 range promised by fmod. */
2821 r
-= f2
* floor (r
/ f2
);
2822 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2826 #endif /* ! HAVE_FMOD */
2828 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2829 doc
: /* Return X modulo Y.
2830 The result falls between zero (inclusive) and Y (exclusive).
2831 Both X and Y must be numbers or markers. */)
2833 register Lisp_Object x
, y
;
2838 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2839 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2841 if (FLOATP (x
) || FLOATP (y
))
2842 return fmod_float (x
, y
);
2848 xsignal0 (Qarith_error
);
2852 /* If the "remainder" comes out with the wrong sign, fix it. */
2853 if (i2
< 0 ? i1
> 0 : i1
< 0)
2860 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2861 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2862 The value is always a number; markers are converted to numbers.
2863 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2868 return arith_driver (Amax
, nargs
, args
);
2871 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2872 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2873 The value is always a number; markers are converted to numbers.
2874 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2879 return arith_driver (Amin
, nargs
, args
);
2882 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2883 doc
: /* Return bitwise-and of all the arguments.
2884 Arguments may be integers, or markers converted to integers.
2885 usage: (logand &rest INTS-OR-MARKERS) */)
2890 return arith_driver (Alogand
, nargs
, args
);
2893 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2894 doc
: /* Return bitwise-or of all the arguments.
2895 Arguments may be integers, or markers converted to integers.
2896 usage: (logior &rest INTS-OR-MARKERS) */)
2901 return arith_driver (Alogior
, nargs
, args
);
2904 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2905 doc
: /* Return bitwise-exclusive-or of all the arguments.
2906 Arguments may be integers, or markers converted to integers.
2907 usage: (logxor &rest INTS-OR-MARKERS) */)
2912 return arith_driver (Alogxor
, nargs
, args
);
2915 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2916 doc
: /* Return VALUE with its bits shifted left by COUNT.
2917 If COUNT is negative, shifting is actually to the right.
2918 In this case, the sign bit is duplicated. */)
2920 register Lisp_Object value
, count
;
2922 register Lisp_Object val
;
2924 CHECK_NUMBER (value
);
2925 CHECK_NUMBER (count
);
2927 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2929 else if (XINT (count
) > 0)
2930 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2931 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2932 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2934 XSETINT (val
, XINT (value
) >> -XINT (count
));
2938 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2939 doc
: /* Return VALUE with its bits shifted left by COUNT.
2940 If COUNT is negative, shifting is actually to the right.
2941 In this case, zeros are shifted in on the left. */)
2943 register Lisp_Object value
, count
;
2945 register Lisp_Object val
;
2947 CHECK_NUMBER (value
);
2948 CHECK_NUMBER (count
);
2950 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2952 else if (XINT (count
) > 0)
2953 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2954 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2957 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2961 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2962 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2963 Markers are converted to integers. */)
2965 register Lisp_Object number
;
2967 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2969 if (FLOATP (number
))
2970 return (make_float (1.0 + XFLOAT_DATA (number
)));
2972 XSETINT (number
, XINT (number
) + 1);
2976 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2977 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2978 Markers are converted to integers. */)
2980 register Lisp_Object number
;
2982 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2984 if (FLOATP (number
))
2985 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2987 XSETINT (number
, XINT (number
) - 1);
2991 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2992 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2994 register Lisp_Object number
;
2996 CHECK_NUMBER (number
);
2997 XSETINT (number
, ~XINT (number
));
3001 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3002 doc
: /* Return the byteorder for the machine.
3003 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3004 lowercase l) for small endian machines. */)
3007 unsigned i
= 0x04030201;
3008 int order
= *(char *)&i
== 1 ? 108 : 66;
3010 return make_number (order
);
3018 Lisp_Object error_tail
, arith_tail
;
3020 Qquote
= intern ("quote");
3021 Qlambda
= intern ("lambda");
3022 Qsubr
= intern ("subr");
3023 Qerror_conditions
= intern ("error-conditions");
3024 Qerror_message
= intern ("error-message");
3025 Qtop_level
= intern ("top-level");
3027 Qerror
= intern ("error");
3028 Qquit
= intern ("quit");
3029 Qwrong_type_argument
= intern ("wrong-type-argument");
3030 Qargs_out_of_range
= intern ("args-out-of-range");
3031 Qvoid_function
= intern ("void-function");
3032 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3033 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3034 Qvoid_variable
= intern ("void-variable");
3035 Qsetting_constant
= intern ("setting-constant");
3036 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3038 Qinvalid_function
= intern ("invalid-function");
3039 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3040 Qno_catch
= intern ("no-catch");
3041 Qend_of_file
= intern ("end-of-file");
3042 Qarith_error
= intern ("arith-error");
3043 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3044 Qend_of_buffer
= intern ("end-of-buffer");
3045 Qbuffer_read_only
= intern ("buffer-read-only");
3046 Qtext_read_only
= intern ("text-read-only");
3047 Qmark_inactive
= intern ("mark-inactive");
3049 Qlistp
= intern ("listp");
3050 Qconsp
= intern ("consp");
3051 Qsymbolp
= intern ("symbolp");
3052 Qkeywordp
= intern ("keywordp");
3053 Qintegerp
= intern ("integerp");
3054 Qnatnump
= intern ("natnump");
3055 Qwholenump
= intern ("wholenump");
3056 Qstringp
= intern ("stringp");
3057 Qarrayp
= intern ("arrayp");
3058 Qsequencep
= intern ("sequencep");
3059 Qbufferp
= intern ("bufferp");
3060 Qvectorp
= intern ("vectorp");
3061 Qchar_or_string_p
= intern ("char-or-string-p");
3062 Qmarkerp
= intern ("markerp");
3063 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3064 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3065 Qboundp
= intern ("boundp");
3066 Qfboundp
= intern ("fboundp");
3068 Qfloatp
= intern ("floatp");
3069 Qnumberp
= intern ("numberp");
3070 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3072 Qchar_table_p
= intern ("char-table-p");
3073 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3075 Qsubrp
= intern ("subrp");
3076 Qunevalled
= intern ("unevalled");
3077 Qmany
= intern ("many");
3079 Qcdr
= intern ("cdr");
3081 /* Handle automatic advice activation */
3082 Qad_advice_info
= intern ("ad-advice-info");
3083 Qad_activate_internal
= intern ("ad-activate-internal");
3085 error_tail
= Fcons (Qerror
, Qnil
);
3087 /* ERROR is used as a signaler for random errors for which nothing else is right */
3089 Fput (Qerror
, Qerror_conditions
,
3091 Fput (Qerror
, Qerror_message
,
3092 build_string ("error"));
3094 Fput (Qquit
, Qerror_conditions
,
3095 Fcons (Qquit
, Qnil
));
3096 Fput (Qquit
, Qerror_message
,
3097 build_string ("Quit"));
3099 Fput (Qwrong_type_argument
, Qerror_conditions
,
3100 Fcons (Qwrong_type_argument
, error_tail
));
3101 Fput (Qwrong_type_argument
, Qerror_message
,
3102 build_string ("Wrong type argument"));
3104 Fput (Qargs_out_of_range
, Qerror_conditions
,
3105 Fcons (Qargs_out_of_range
, error_tail
));
3106 Fput (Qargs_out_of_range
, Qerror_message
,
3107 build_string ("Args out of range"));
3109 Fput (Qvoid_function
, Qerror_conditions
,
3110 Fcons (Qvoid_function
, error_tail
));
3111 Fput (Qvoid_function
, Qerror_message
,
3112 build_string ("Symbol's function definition is void"));
3114 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3115 Fcons (Qcyclic_function_indirection
, error_tail
));
3116 Fput (Qcyclic_function_indirection
, Qerror_message
,
3117 build_string ("Symbol's chain of function indirections contains a loop"));
3119 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3120 Fcons (Qcyclic_variable_indirection
, error_tail
));
3121 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3122 build_string ("Symbol's chain of variable indirections contains a loop"));
3124 Qcircular_list
= intern ("circular-list");
3125 staticpro (&Qcircular_list
);
3126 Fput (Qcircular_list
, Qerror_conditions
,
3127 Fcons (Qcircular_list
, error_tail
));
3128 Fput (Qcircular_list
, Qerror_message
,
3129 build_string ("List contains a loop"));
3131 Fput (Qvoid_variable
, Qerror_conditions
,
3132 Fcons (Qvoid_variable
, error_tail
));
3133 Fput (Qvoid_variable
, Qerror_message
,
3134 build_string ("Symbol's value as variable is void"));
3136 Fput (Qsetting_constant
, Qerror_conditions
,
3137 Fcons (Qsetting_constant
, error_tail
));
3138 Fput (Qsetting_constant
, Qerror_message
,
3139 build_string ("Attempt to set a constant symbol"));
3141 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3142 Fcons (Qinvalid_read_syntax
, error_tail
));
3143 Fput (Qinvalid_read_syntax
, Qerror_message
,
3144 build_string ("Invalid read syntax"));
3146 Fput (Qinvalid_function
, Qerror_conditions
,
3147 Fcons (Qinvalid_function
, error_tail
));
3148 Fput (Qinvalid_function
, Qerror_message
,
3149 build_string ("Invalid function"));
3151 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3152 Fcons (Qwrong_number_of_arguments
, error_tail
));
3153 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3154 build_string ("Wrong number of arguments"));
3156 Fput (Qno_catch
, Qerror_conditions
,
3157 Fcons (Qno_catch
, error_tail
));
3158 Fput (Qno_catch
, Qerror_message
,
3159 build_string ("No catch for tag"));
3161 Fput (Qend_of_file
, Qerror_conditions
,
3162 Fcons (Qend_of_file
, error_tail
));
3163 Fput (Qend_of_file
, Qerror_message
,
3164 build_string ("End of file during parsing"));
3166 arith_tail
= Fcons (Qarith_error
, error_tail
);
3167 Fput (Qarith_error
, Qerror_conditions
,
3169 Fput (Qarith_error
, Qerror_message
,
3170 build_string ("Arithmetic error"));
3172 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3173 Fcons (Qbeginning_of_buffer
, error_tail
));
3174 Fput (Qbeginning_of_buffer
, Qerror_message
,
3175 build_string ("Beginning of buffer"));
3177 Fput (Qend_of_buffer
, Qerror_conditions
,
3178 Fcons (Qend_of_buffer
, error_tail
));
3179 Fput (Qend_of_buffer
, Qerror_message
,
3180 build_string ("End of buffer"));
3182 Fput (Qbuffer_read_only
, Qerror_conditions
,
3183 Fcons (Qbuffer_read_only
, error_tail
));
3184 Fput (Qbuffer_read_only
, Qerror_message
,
3185 build_string ("Buffer is read-only"));
3187 Fput (Qtext_read_only
, Qerror_conditions
,
3188 Fcons (Qtext_read_only
, error_tail
));
3189 Fput (Qtext_read_only
, Qerror_message
,
3190 build_string ("Text is read-only"));
3192 Qrange_error
= intern ("range-error");
3193 Qdomain_error
= intern ("domain-error");
3194 Qsingularity_error
= intern ("singularity-error");
3195 Qoverflow_error
= intern ("overflow-error");
3196 Qunderflow_error
= intern ("underflow-error");
3198 Fput (Qdomain_error
, Qerror_conditions
,
3199 Fcons (Qdomain_error
, arith_tail
));
3200 Fput (Qdomain_error
, Qerror_message
,
3201 build_string ("Arithmetic domain error"));
3203 Fput (Qrange_error
, Qerror_conditions
,
3204 Fcons (Qrange_error
, arith_tail
));
3205 Fput (Qrange_error
, Qerror_message
,
3206 build_string ("Arithmetic range error"));
3208 Fput (Qsingularity_error
, Qerror_conditions
,
3209 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3210 Fput (Qsingularity_error
, Qerror_message
,
3211 build_string ("Arithmetic singularity error"));
3213 Fput (Qoverflow_error
, Qerror_conditions
,
3214 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3215 Fput (Qoverflow_error
, Qerror_message
,
3216 build_string ("Arithmetic overflow error"));
3218 Fput (Qunderflow_error
, Qerror_conditions
,
3219 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3220 Fput (Qunderflow_error
, Qerror_message
,
3221 build_string ("Arithmetic underflow error"));
3223 staticpro (&Qrange_error
);
3224 staticpro (&Qdomain_error
);
3225 staticpro (&Qsingularity_error
);
3226 staticpro (&Qoverflow_error
);
3227 staticpro (&Qunderflow_error
);
3231 staticpro (&Qquote
);
3232 staticpro (&Qlambda
);
3234 staticpro (&Qunbound
);
3235 staticpro (&Qerror_conditions
);
3236 staticpro (&Qerror_message
);
3237 staticpro (&Qtop_level
);
3239 staticpro (&Qerror
);
3241 staticpro (&Qwrong_type_argument
);
3242 staticpro (&Qargs_out_of_range
);
3243 staticpro (&Qvoid_function
);
3244 staticpro (&Qcyclic_function_indirection
);
3245 staticpro (&Qcyclic_variable_indirection
);
3246 staticpro (&Qvoid_variable
);
3247 staticpro (&Qsetting_constant
);
3248 staticpro (&Qinvalid_read_syntax
);
3249 staticpro (&Qwrong_number_of_arguments
);
3250 staticpro (&Qinvalid_function
);
3251 staticpro (&Qno_catch
);
3252 staticpro (&Qend_of_file
);
3253 staticpro (&Qarith_error
);
3254 staticpro (&Qbeginning_of_buffer
);
3255 staticpro (&Qend_of_buffer
);
3256 staticpro (&Qbuffer_read_only
);
3257 staticpro (&Qtext_read_only
);
3258 staticpro (&Qmark_inactive
);
3260 staticpro (&Qlistp
);
3261 staticpro (&Qconsp
);
3262 staticpro (&Qsymbolp
);
3263 staticpro (&Qkeywordp
);
3264 staticpro (&Qintegerp
);
3265 staticpro (&Qnatnump
);
3266 staticpro (&Qwholenump
);
3267 staticpro (&Qstringp
);
3268 staticpro (&Qarrayp
);
3269 staticpro (&Qsequencep
);
3270 staticpro (&Qbufferp
);
3271 staticpro (&Qvectorp
);
3272 staticpro (&Qchar_or_string_p
);
3273 staticpro (&Qmarkerp
);
3274 staticpro (&Qbuffer_or_string_p
);
3275 staticpro (&Qinteger_or_marker_p
);
3276 staticpro (&Qfloatp
);
3277 staticpro (&Qnumberp
);
3278 staticpro (&Qnumber_or_marker_p
);
3279 staticpro (&Qchar_table_p
);
3280 staticpro (&Qvector_or_char_table_p
);
3281 staticpro (&Qsubrp
);
3283 staticpro (&Qunevalled
);
3285 staticpro (&Qboundp
);
3286 staticpro (&Qfboundp
);
3288 staticpro (&Qad_advice_info
);
3289 staticpro (&Qad_activate_internal
);
3291 /* Types that type-of returns. */
3292 Qinteger
= intern ("integer");
3293 Qsymbol
= intern ("symbol");
3294 Qstring
= intern ("string");
3295 Qcons
= intern ("cons");
3296 Qmarker
= intern ("marker");
3297 Qoverlay
= intern ("overlay");
3298 Qfloat
= intern ("float");
3299 Qwindow_configuration
= intern ("window-configuration");
3300 Qprocess
= intern ("process");
3301 Qwindow
= intern ("window");
3302 /* Qsubr = intern ("subr"); */
3303 Qcompiled_function
= intern ("compiled-function");
3304 Qbuffer
= intern ("buffer");
3305 Qframe
= intern ("frame");
3306 Qvector
= intern ("vector");
3307 Qchar_table
= intern ("char-table");
3308 Qbool_vector
= intern ("bool-vector");
3309 Qhash_table
= intern ("hash-table");
3311 staticpro (&Qinteger
);
3312 staticpro (&Qsymbol
);
3313 staticpro (&Qstring
);
3315 staticpro (&Qmarker
);
3316 staticpro (&Qoverlay
);
3317 staticpro (&Qfloat
);
3318 staticpro (&Qwindow_configuration
);
3319 staticpro (&Qprocess
);
3320 staticpro (&Qwindow
);
3321 /* staticpro (&Qsubr); */
3322 staticpro (&Qcompiled_function
);
3323 staticpro (&Qbuffer
);
3324 staticpro (&Qframe
);
3325 staticpro (&Qvector
);
3326 staticpro (&Qchar_table
);
3327 staticpro (&Qbool_vector
);
3328 staticpro (&Qhash_table
);
3330 defsubr (&Sindirect_variable
);
3331 defsubr (&Sinteractive_form
);
3334 defsubr (&Stype_of
);
3339 defsubr (&Sintegerp
);
3340 defsubr (&Sinteger_or_marker_p
);
3341 defsubr (&Snumberp
);
3342 defsubr (&Snumber_or_marker_p
);
3344 defsubr (&Snatnump
);
3345 defsubr (&Ssymbolp
);
3346 defsubr (&Skeywordp
);
3347 defsubr (&Sstringp
);
3348 defsubr (&Smultibyte_string_p
);
3349 defsubr (&Svectorp
);
3350 defsubr (&Schar_table_p
);
3351 defsubr (&Svector_or_char_table_p
);
3352 defsubr (&Sbool_vector_p
);
3354 defsubr (&Ssequencep
);
3355 defsubr (&Sbufferp
);
3356 defsubr (&Smarkerp
);
3358 defsubr (&Sbyte_code_function_p
);
3359 defsubr (&Schar_or_string_p
);
3362 defsubr (&Scar_safe
);
3363 defsubr (&Scdr_safe
);
3366 defsubr (&Ssymbol_function
);
3367 defsubr (&Sindirect_function
);
3368 defsubr (&Ssymbol_plist
);
3369 defsubr (&Ssymbol_name
);
3370 defsubr (&Smakunbound
);
3371 defsubr (&Sfmakunbound
);
3373 defsubr (&Sfboundp
);
3375 defsubr (&Sdefalias
);
3376 defsubr (&Ssetplist
);
3377 defsubr (&Ssymbol_value
);
3379 defsubr (&Sdefault_boundp
);
3380 defsubr (&Sdefault_value
);
3381 defsubr (&Sset_default
);
3382 defsubr (&Ssetq_default
);
3383 defsubr (&Smake_variable_buffer_local
);
3384 defsubr (&Smake_local_variable
);
3385 defsubr (&Skill_local_variable
);
3386 defsubr (&Smake_variable_frame_local
);
3387 defsubr (&Slocal_variable_p
);
3388 defsubr (&Slocal_variable_if_set_p
);
3389 defsubr (&Svariable_binding_locus
);
3390 #if 0 /* XXX Remove this. --lorentey */
3391 defsubr (&Sterminal_local_value
);
3392 defsubr (&Sset_terminal_local_value
);
3396 defsubr (&Snumber_to_string
);
3397 defsubr (&Sstring_to_number
);
3398 defsubr (&Seqlsign
);
3421 defsubr (&Sbyteorder
);
3422 defsubr (&Ssubr_arity
);
3423 defsubr (&Ssubr_name
);
3425 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3427 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3428 doc
: /* The largest value that is representable in a Lisp integer. */);
3429 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3431 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3432 doc
: /* The smallest value that is representable in a Lisp integer. */);
3433 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3440 #if defined(USG) && !defined(POSIX_SIGNALS)
3441 /* USG systems forget handlers when they are used;
3442 must reestablish each time */
3443 signal (signo
, arith_error
);
3446 /* VMS systems are like USG. */
3447 signal (signo
, arith_error
);
3451 #else /* not BSD4_1 */
3452 sigsetmask (SIGEMPTYMASK
);
3453 #endif /* not BSD4_1 */
3455 SIGNAL_THREAD_CHECK (signo
);
3456 xsignal0 (Qarith_error
);
3462 /* Don't do this if just dumping out.
3463 We don't want to call `signal' in this case
3464 so that we don't have trouble with dumping
3465 signal-delivering routines in an inconsistent state. */
3469 #endif /* CANNOT_DUMP */
3470 signal (SIGFPE
, arith_error
);
3473 signal (SIGEMT
, arith_error
);
3477 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3478 (do not change this comment) */