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 register Lisp_Object function
;
668 CHECK_SYMBOL (symbol
);
669 if (NILP (symbol
) || EQ (symbol
, Qt
))
670 xsignal1 (Qsetting_constant
, symbol
);
672 function
= XSYMBOL (symbol
)->function
;
674 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
675 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
677 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
678 Fput (symbol
, Qautoload
, XCDR (function
));
680 XSYMBOL (symbol
)->function
= definition
;
681 /* Handle automatic advice activation */
682 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
684 call2 (Qad_activate_internal
, symbol
, Qnil
);
685 definition
= XSYMBOL (symbol
)->function
;
690 extern Lisp_Object Qfunction_documentation
;
692 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
693 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
694 Associates the function with the current load file, if any.
695 The optional third argument DOCSTRING specifies the documentation string
696 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
697 determined by DEFINITION. */)
698 (symbol
, definition
, docstring
)
699 register Lisp_Object symbol
, definition
, docstring
;
701 CHECK_SYMBOL (symbol
);
702 if (CONSP (XSYMBOL (symbol
)->function
)
703 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
704 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
705 definition
= Ffset (symbol
, definition
);
706 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
707 if (!NILP (docstring
))
708 Fput (symbol
, Qfunction_documentation
, docstring
);
712 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
713 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
715 register Lisp_Object symbol
, newplist
;
717 CHECK_SYMBOL (symbol
);
718 XSYMBOL (symbol
)->plist
= newplist
;
722 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
723 doc
: /* Return minimum and maximum number of args allowed for SUBR.
724 SUBR must be a built-in function.
725 The returned value is a pair (MIN . MAX). MIN is the minimum number
726 of args. MAX is the maximum number or the symbol `many', for a
727 function with `&rest' args, or `unevalled' for a special form. */)
731 short minargs
, maxargs
;
733 minargs
= XSUBR (subr
)->min_args
;
734 maxargs
= XSUBR (subr
)->max_args
;
736 return Fcons (make_number (minargs
), Qmany
);
737 else if (maxargs
== UNEVALLED
)
738 return Fcons (make_number (minargs
), Qunevalled
);
740 return Fcons (make_number (minargs
), make_number (maxargs
));
743 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
744 doc
: /* Return name of subroutine SUBR.
745 SUBR must be a built-in function. */)
751 name
= XSUBR (subr
)->symbol_name
;
752 return make_string (name
, strlen (name
));
755 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
756 doc
: /* Return the interactive form of CMD or nil if none.
757 If CMD is not a command, the return value is nil.
758 Value, if non-nil, is a list \(interactive SPEC). */)
762 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
764 if (NILP (fun
) || EQ (fun
, Qunbound
))
767 /* Use an `interactive-form' property if present, analogous to the
768 function-documentation property. */
770 while (SYMBOLP (fun
))
772 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
776 fun
= Fsymbol_function (fun
);
781 char *spec
= XSUBR (fun
)->intspec
;
783 return list2 (Qinteractive
,
784 (*spec
!= '(') ? build_string (spec
) :
785 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
787 else if (COMPILEDP (fun
))
789 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
790 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
792 else if (CONSP (fun
))
794 Lisp_Object funcar
= XCAR (fun
);
795 if (EQ (funcar
, Qlambda
))
796 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
797 else if (EQ (funcar
, Qautoload
))
801 do_autoload (fun
, cmd
);
803 return Finteractive_form (cmd
);
810 /***********************************************************************
811 Getting and Setting Values of Symbols
812 ***********************************************************************/
814 /* Return the symbol holding SYMBOL's value. Signal
815 `cyclic-variable-indirection' if SYMBOL's chain of variable
816 indirections contains a loop. */
819 indirect_variable (symbol
)
822 Lisp_Object tortoise
, hare
;
824 hare
= tortoise
= symbol
;
826 while (XSYMBOL (hare
)->indirect_variable
)
828 hare
= XSYMBOL (hare
)->value
;
829 if (!XSYMBOL (hare
)->indirect_variable
)
832 hare
= XSYMBOL (hare
)->value
;
833 tortoise
= XSYMBOL (tortoise
)->value
;
835 if (EQ (hare
, tortoise
))
836 xsignal1 (Qcyclic_variable_indirection
, symbol
);
843 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
844 doc
: /* Return the variable at the end of OBJECT's variable chain.
845 If OBJECT is a symbol, follow all variable indirections and return the final
846 variable. If OBJECT is not a symbol, just return it.
847 Signal a cyclic-variable-indirection error if there is a loop in the
848 variable chain of symbols. */)
852 if (SYMBOLP (object
))
853 object
= indirect_variable (object
);
858 /* Given the raw contents of a symbol value cell,
859 return the Lisp value of the symbol.
860 This does not handle buffer-local variables; use
861 swap_in_symval_forwarding for that. */
864 do_symval_forwarding (valcontents
)
865 register Lisp_Object valcontents
;
867 register Lisp_Object val
;
869 if (MISCP (valcontents
))
870 switch (XMISCTYPE (valcontents
))
872 case Lisp_Misc_Intfwd
:
873 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
876 case Lisp_Misc_Boolfwd
:
877 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
879 case Lisp_Misc_Objfwd
:
880 return *XOBJFWD (valcontents
)->objvar
;
882 case Lisp_Misc_Buffer_Objfwd
:
883 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
884 return PER_BUFFER_VALUE (current_buffer
, offset
);
886 case Lisp_Misc_Kboard_Objfwd
:
887 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
888 /* We used to simply use current_kboard here, but from Lisp
889 code, it's value is often unexpected. It seems nicer to
890 allow constructions like this to work as intuitively expected:
892 (with-selected-frame frame
893 (define-key local-function-map "\eOP" [f1]))
895 On the other hand, this affects the semantics of
896 last-command and real-last-command, and people may rely on
897 that. I took a quick look at the Lisp codebase, and I
898 don't think anything will break. --lorentey */
899 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
904 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
905 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
906 buffer-independent contents of the value cell: forwarded just one
907 step past the buffer-localness.
909 BUF non-zero means set the value in buffer BUF instead of the
910 current buffer. This only plays a role for per-buffer variables. */
913 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
915 register Lisp_Object valcontents
, newval
;
918 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
921 switch (XMISCTYPE (valcontents
))
923 case Lisp_Misc_Intfwd
:
924 CHECK_NUMBER (newval
);
925 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
926 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
927 error ("Value out of range for variable `%s'",
928 SDATA (SYMBOL_NAME (symbol
)));
931 case Lisp_Misc_Boolfwd
:
932 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
935 case Lisp_Misc_Objfwd
:
936 *XOBJFWD (valcontents
)->objvar
= newval
;
938 /* If this variable is a default for something stored
939 in the buffer itself, such as default-fill-column,
940 find the buffers that don't have local values for it
942 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
943 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
945 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
946 - (char *) &buffer_defaults
);
947 int idx
= PER_BUFFER_IDX (offset
);
954 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
959 buf
= Fcdr (XCAR (tail
));
960 if (!BUFFERP (buf
)) continue;
963 if (! PER_BUFFER_VALUE_P (b
, idx
))
964 PER_BUFFER_VALUE (b
, offset
) = newval
;
969 case Lisp_Misc_Buffer_Objfwd
:
971 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
974 type
= PER_BUFFER_TYPE (offset
);
975 if (! NILP (type
) && ! NILP (newval
)
976 && XTYPE (newval
) != XINT (type
))
977 buffer_slot_type_mismatch (offset
);
980 buf
= current_buffer
;
981 PER_BUFFER_VALUE (buf
, offset
) = newval
;
985 case Lisp_Misc_Kboard_Objfwd
:
987 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
988 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
989 *(Lisp_Object
*) p
= newval
;
1000 valcontents
= SYMBOL_VALUE (symbol
);
1001 if (BUFFER_LOCAL_VALUEP (valcontents
)
1002 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1003 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1005 SET_SYMBOL_VALUE (symbol
, newval
);
1009 /* Set up SYMBOL to refer to its global binding.
1010 This makes it safe to alter the status of other bindings. */
1013 swap_in_global_binding (symbol
)
1016 Lisp_Object valcontents
, cdr
;
1018 valcontents
= SYMBOL_VALUE (symbol
);
1019 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1020 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1022 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1024 /* Unload the previously loaded binding. */
1025 Fsetcdr (XCAR (cdr
),
1026 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1028 /* Select the global binding in the symbol. */
1030 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1032 /* Indicate that the global binding is set up now. */
1033 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1034 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1035 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1036 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1039 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1040 VALCONTENTS is the contents of its value cell,
1041 which points to a struct Lisp_Buffer_Local_Value.
1043 Return the value forwarded one step past the buffer-local stage.
1044 This could be another forwarding pointer. */
1047 swap_in_symval_forwarding (symbol
, valcontents
)
1048 Lisp_Object symbol
, valcontents
;
1050 register Lisp_Object tem1
;
1052 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1055 || current_buffer
!= XBUFFER (tem1
)
1056 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1057 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1059 if (XSYMBOL (symbol
)->indirect_variable
)
1060 symbol
= indirect_variable (symbol
);
1062 /* Unload the previously loaded binding. */
1063 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1065 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1066 /* Choose the new binding. */
1067 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1068 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1069 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1072 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1073 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1075 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1077 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1080 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1082 /* Load the new binding. */
1083 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1084 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1085 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1086 store_symval_forwarding (symbol
,
1087 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1090 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1093 /* Find the value of a symbol, returning Qunbound if it's not bound.
1094 This is helpful for code which just wants to get a variable's value
1095 if it has one, without signaling an error.
1096 Note that it must not be possible to quit
1097 within this function. Great care is required for this. */
1100 find_symbol_value (symbol
)
1103 register Lisp_Object valcontents
;
1104 register Lisp_Object val
;
1106 CHECK_SYMBOL (symbol
);
1107 valcontents
= SYMBOL_VALUE (symbol
);
1109 if (BUFFER_LOCAL_VALUEP (valcontents
)
1110 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1111 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1113 if (MISCP (valcontents
))
1115 switch (XMISCTYPE (valcontents
))
1117 case Lisp_Misc_Intfwd
:
1118 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1121 case Lisp_Misc_Boolfwd
:
1122 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1124 case Lisp_Misc_Objfwd
:
1125 return *XOBJFWD (valcontents
)->objvar
;
1127 case Lisp_Misc_Buffer_Objfwd
:
1128 return PER_BUFFER_VALUE (current_buffer
,
1129 XBUFFER_OBJFWD (valcontents
)->offset
);
1131 case Lisp_Misc_Kboard_Objfwd
:
1132 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1133 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1140 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1141 doc
: /* Return SYMBOL's value. Error if that is void. */)
1147 val
= find_symbol_value (symbol
);
1148 if (!EQ (val
, Qunbound
))
1151 xsignal1 (Qvoid_variable
, symbol
);
1154 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1155 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1157 register Lisp_Object symbol
, newval
;
1159 return set_internal (symbol
, newval
, current_buffer
, 0);
1162 /* Return 1 if SYMBOL currently has a let-binding
1163 which was made in the buffer that is now current. */
1166 let_shadows_buffer_binding_p (symbol
)
1169 volatile struct specbinding
*p
;
1171 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1173 && CONSP (p
->symbol
))
1175 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1176 if ((EQ (symbol
, let_bound_symbol
)
1177 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1178 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1179 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1183 return p
>= specpdl
;
1186 /* Store the value NEWVAL into SYMBOL.
1187 If buffer-locality is an issue, BUF specifies which buffer to use.
1188 (0 stands for the current buffer.)
1190 If BINDFLAG is zero, then if this symbol is supposed to become
1191 local in every buffer where it is set, then we make it local.
1192 If BINDFLAG is nonzero, we don't do that. */
1195 set_internal (symbol
, newval
, buf
, bindflag
)
1196 register Lisp_Object symbol
, newval
;
1200 int voide
= EQ (newval
, Qunbound
);
1202 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1205 buf
= current_buffer
;
1207 /* If restoring in a dead buffer, do nothing. */
1208 if (NILP (buf
->name
))
1211 CHECK_SYMBOL (symbol
);
1212 if (SYMBOL_CONSTANT_P (symbol
)
1213 && (NILP (Fkeywordp (symbol
))
1214 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1215 xsignal1 (Qsetting_constant
, symbol
);
1217 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1219 if (BUFFER_OBJFWDP (valcontents
))
1221 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1222 int idx
= PER_BUFFER_IDX (offset
);
1225 && !let_shadows_buffer_binding_p (symbol
))
1226 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1228 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1229 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1231 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1232 if (XSYMBOL (symbol
)->indirect_variable
)
1233 symbol
= indirect_variable (symbol
);
1235 /* What binding is loaded right now? */
1236 current_alist_element
1237 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1239 /* If the current buffer is not the buffer whose binding is
1240 loaded, or if there may be frame-local bindings and the frame
1241 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1242 the default binding is loaded, the loaded binding may be the
1244 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1245 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1246 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1247 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1248 || (BUFFER_LOCAL_VALUEP (valcontents
)
1249 && EQ (XCAR (current_alist_element
),
1250 current_alist_element
)))
1252 /* The currently loaded binding is not necessarily valid.
1253 We need to unload it, and choose a new binding. */
1255 /* Write out `realvalue' to the old loaded binding. */
1256 Fsetcdr (current_alist_element
,
1257 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1259 /* Find the new binding. */
1260 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1261 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1262 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1266 /* This buffer still sees the default value. */
1268 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1269 or if this is `let' rather than `set',
1270 make CURRENT-ALIST-ELEMENT point to itself,
1271 indicating that we're seeing the default value.
1272 Likewise if the variable has been let-bound
1273 in the current buffer. */
1274 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1275 || let_shadows_buffer_binding_p (symbol
))
1277 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1279 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1280 tem1
= Fassq (symbol
,
1281 XFRAME (selected_frame
)->param_alist
);
1284 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1286 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1288 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1289 and we're not within a let that was made for this buffer,
1290 create a new buffer-local binding for the variable.
1291 That means, give this buffer a new assoc for a local value
1292 and load that binding. */
1295 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1296 buf
->local_var_alist
1297 = Fcons (tem1
, buf
->local_var_alist
);
1301 /* Record which binding is now loaded. */
1302 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1305 /* Set `buffer' and `frame' slots for the binding now loaded. */
1306 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1307 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1309 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1312 /* If storing void (making the symbol void), forward only through
1313 buffer-local indicator, not through Lisp_Objfwd, etc. */
1315 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1317 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1319 /* If we just set a variable whose current binding is frame-local,
1320 store the new value in the frame parameter too. */
1322 if (BUFFER_LOCAL_VALUEP (valcontents
)
1323 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1325 /* What binding is loaded right now? */
1326 current_alist_element
1327 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1329 /* If the current buffer is not the buffer whose binding is
1330 loaded, or if there may be frame-local bindings and the frame
1331 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1332 the default binding is loaded, the loaded binding may be the
1334 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1335 XSETCDR (current_alist_element
, newval
);
1341 /* Access or set a buffer-local symbol's default value. */
1343 /* Return the default value of SYMBOL, but don't check for voidness.
1344 Return Qunbound if it is void. */
1347 default_value (symbol
)
1350 register Lisp_Object valcontents
;
1352 CHECK_SYMBOL (symbol
);
1353 valcontents
= SYMBOL_VALUE (symbol
);
1355 /* For a built-in buffer-local variable, get the default value
1356 rather than letting do_symval_forwarding get the current value. */
1357 if (BUFFER_OBJFWDP (valcontents
))
1359 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1360 if (PER_BUFFER_IDX (offset
) != 0)
1361 return PER_BUFFER_DEFAULT (offset
);
1364 /* Handle user-created local variables. */
1365 if (BUFFER_LOCAL_VALUEP (valcontents
)
1366 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1368 /* If var is set up for a buffer that lacks a local value for it,
1369 the current value is nominally the default value.
1370 But the `realvalue' slot may be more up to date, since
1371 ordinary setq stores just that slot. So use that. */
1372 Lisp_Object current_alist_element
, alist_element_car
;
1373 current_alist_element
1374 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1375 alist_element_car
= XCAR (current_alist_element
);
1376 if (EQ (alist_element_car
, current_alist_element
))
1377 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1379 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1381 /* For other variables, get the current value. */
1382 return do_symval_forwarding (valcontents
);
1385 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1386 doc
: /* Return t if SYMBOL has a non-void default value.
1387 This is the value that is seen in buffers that do not have their own values
1388 for this variable. */)
1392 register Lisp_Object value
;
1394 value
= default_value (symbol
);
1395 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1398 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1399 doc
: /* Return SYMBOL's default value.
1400 This is the value that is seen in buffers that do not have their own values
1401 for this variable. The default value is meaningful for variables with
1402 local bindings in certain buffers. */)
1406 register Lisp_Object value
;
1408 value
= default_value (symbol
);
1409 if (!EQ (value
, Qunbound
))
1412 xsignal1 (Qvoid_variable
, symbol
);
1415 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1416 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1417 The default value is seen in buffers that do not have their own values
1418 for this variable. */)
1420 Lisp_Object symbol
, value
;
1422 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1424 CHECK_SYMBOL (symbol
);
1425 valcontents
= SYMBOL_VALUE (symbol
);
1427 /* Handle variables like case-fold-search that have special slots
1428 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1430 if (BUFFER_OBJFWDP (valcontents
))
1432 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1433 int idx
= PER_BUFFER_IDX (offset
);
1435 PER_BUFFER_DEFAULT (offset
) = value
;
1437 /* If this variable is not always local in all buffers,
1438 set it in the buffers that don't nominally have a local value. */
1443 for (b
= all_buffers
; b
; b
= b
->next
)
1444 if (!PER_BUFFER_VALUE_P (b
, idx
))
1445 PER_BUFFER_VALUE (b
, offset
) = value
;
1450 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1451 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1452 return Fset (symbol
, value
);
1454 /* Store new value into the DEFAULT-VALUE slot. */
1455 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1457 /* If the default binding is now loaded, set the REALVALUE slot too. */
1458 current_alist_element
1459 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1460 alist_element_buffer
= Fcar (current_alist_element
);
1461 if (EQ (alist_element_buffer
, current_alist_element
))
1462 store_symval_forwarding (symbol
,
1463 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1469 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1470 doc
: /* Set the default value of variable VAR to VALUE.
1471 VAR, the variable name, is literal (not evaluated);
1472 VALUE is an expression: it is evaluated and its value returned.
1473 The default value of a variable is seen in buffers
1474 that do not have their own values for the variable.
1476 More generally, you can use multiple variables and values, as in
1477 (setq-default VAR VALUE VAR VALUE...)
1478 This sets each VAR's default value to the corresponding VALUE.
1479 The VALUE for the Nth VAR can refer to the new default values
1481 usage: (setq-default [VAR VALUE]...) */)
1485 register Lisp_Object args_left
;
1486 register Lisp_Object val
, symbol
;
1487 struct gcpro gcpro1
;
1497 val
= Feval (Fcar (Fcdr (args_left
)));
1498 symbol
= XCAR (args_left
);
1499 Fset_default (symbol
, val
);
1500 args_left
= Fcdr (XCDR (args_left
));
1502 while (!NILP (args_left
));
1508 /* Lisp functions for creating and removing buffer-local variables. */
1510 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1511 1, 1, "vMake Variable Buffer Local: ",
1512 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1513 At any time, the value for the current buffer is in effect,
1514 unless the variable has never been set in this buffer,
1515 in which case the default value is in effect.
1516 Note that binding the variable with `let', or setting it while
1517 a `let'-style binding made in this buffer is in effect,
1518 does not make the variable buffer-local. Return VARIABLE.
1520 In most cases it is better to use `make-local-variable',
1521 which makes a variable local in just one buffer.
1523 The function `default-value' gets the default value and `set-default' sets it. */)
1525 register Lisp_Object variable
;
1527 register Lisp_Object tem
, valcontents
, newval
;
1529 CHECK_SYMBOL (variable
);
1530 variable
= indirect_variable (variable
);
1532 valcontents
= SYMBOL_VALUE (variable
);
1533 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1534 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1536 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1538 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1540 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1543 if (EQ (valcontents
, Qunbound
))
1544 SET_SYMBOL_VALUE (variable
, Qnil
);
1545 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1547 newval
= allocate_misc ();
1548 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1549 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1550 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1551 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1552 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1553 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1554 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1555 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1556 SET_SYMBOL_VALUE (variable
, newval
);
1560 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1561 1, 1, "vMake Local Variable: ",
1562 doc
: /* Make VARIABLE have a separate value in the current buffer.
1563 Other buffers will continue to share a common default value.
1564 \(The buffer-local value of VARIABLE starts out as the same value
1565 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1568 If the variable is already arranged to become local when set,
1569 this function causes a local value to exist for this buffer,
1570 just as setting the variable would do.
1572 This function returns VARIABLE, and therefore
1573 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1576 See also `make-variable-buffer-local'.
1578 Do not use `make-local-variable' to make a hook variable buffer-local.
1579 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1581 register Lisp_Object variable
;
1583 register Lisp_Object tem
, valcontents
;
1585 CHECK_SYMBOL (variable
);
1586 variable
= indirect_variable (variable
);
1588 valcontents
= SYMBOL_VALUE (variable
);
1589 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1590 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1592 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1594 tem
= Fboundp (variable
);
1596 /* Make sure the symbol has a local value in this particular buffer,
1597 by setting it to the same value it already has. */
1598 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1601 /* Make sure symbol is set up to hold per-buffer values. */
1602 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1605 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1607 newval
= allocate_misc ();
1608 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1609 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1610 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1611 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1612 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1613 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1614 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1615 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1616 SET_SYMBOL_VALUE (variable
, newval
);
1618 /* Make sure this buffer has its own value of symbol. */
1619 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1622 /* Swap out any local binding for some other buffer, and make
1623 sure the current value is permanently recorded, if it's the
1625 find_symbol_value (variable
);
1627 current_buffer
->local_var_alist
1628 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1629 current_buffer
->local_var_alist
);
1631 /* Make sure symbol does not think it is set up for this buffer;
1632 force it to look once again for this buffer's value. */
1634 Lisp_Object
*pvalbuf
;
1636 valcontents
= SYMBOL_VALUE (variable
);
1638 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1639 if (current_buffer
== XBUFFER (*pvalbuf
))
1641 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1645 /* If the symbol forwards into a C variable, then load the binding
1646 for this buffer now. If C code modifies the variable before we
1647 load the binding in, then that new value will clobber the default
1648 binding the next time we unload it. */
1649 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1650 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1651 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1656 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1657 1, 1, "vKill Local Variable: ",
1658 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1659 From now on the default value will apply in this buffer. Return VARIABLE. */)
1661 register Lisp_Object variable
;
1663 register Lisp_Object tem
, valcontents
;
1665 CHECK_SYMBOL (variable
);
1666 variable
= indirect_variable (variable
);
1668 valcontents
= SYMBOL_VALUE (variable
);
1670 if (BUFFER_OBJFWDP (valcontents
))
1672 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1673 int idx
= PER_BUFFER_IDX (offset
);
1677 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1678 PER_BUFFER_VALUE (current_buffer
, offset
)
1679 = PER_BUFFER_DEFAULT (offset
);
1684 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1685 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1688 /* Get rid of this buffer's alist element, if any. */
1690 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1692 current_buffer
->local_var_alist
1693 = Fdelq (tem
, current_buffer
->local_var_alist
);
1695 /* If the symbol is set up with the current buffer's binding
1696 loaded, recompute its value. We have to do it now, or else
1697 forwarded objects won't work right. */
1699 Lisp_Object
*pvalbuf
, buf
;
1700 valcontents
= SYMBOL_VALUE (variable
);
1701 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1702 XSETBUFFER (buf
, current_buffer
);
1703 if (EQ (buf
, *pvalbuf
))
1706 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1707 find_symbol_value (variable
);
1714 /* Lisp functions for creating and removing buffer-local variables. */
1716 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1717 1, 1, "vMake Variable Frame Local: ",
1718 doc
: /* Enable VARIABLE to have frame-local bindings.
1719 This does not create any frame-local bindings for VARIABLE,
1720 it just makes them possible.
1722 A frame-local binding is actually a frame parameter value.
1723 If a frame F has a value for the frame parameter named VARIABLE,
1724 that also acts as a frame-local binding for VARIABLE in F--
1725 provided this function has been called to enable VARIABLE
1726 to have frame-local bindings at all.
1728 The only way to create a frame-local binding for VARIABLE in a frame
1729 is to set the VARIABLE frame parameter of that frame. See
1730 `modify-frame-parameters' for how to set frame parameters.
1732 Buffer-local bindings take precedence over frame-local bindings. */)
1734 register Lisp_Object variable
;
1736 register Lisp_Object tem
, valcontents
, newval
;
1738 CHECK_SYMBOL (variable
);
1739 variable
= indirect_variable (variable
);
1741 valcontents
= SYMBOL_VALUE (variable
);
1742 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1743 || BUFFER_OBJFWDP (valcontents
))
1744 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1746 if (BUFFER_LOCAL_VALUEP (valcontents
)
1747 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1749 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1753 if (EQ (valcontents
, Qunbound
))
1754 SET_SYMBOL_VALUE (variable
, Qnil
);
1755 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1757 newval
= allocate_misc ();
1758 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1759 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1760 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1761 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1762 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1763 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1764 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1765 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1766 SET_SYMBOL_VALUE (variable
, newval
);
1770 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1772 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1773 BUFFER defaults to the current buffer. */)
1775 register Lisp_Object variable
, buffer
;
1777 Lisp_Object valcontents
;
1778 register struct buffer
*buf
;
1781 buf
= current_buffer
;
1784 CHECK_BUFFER (buffer
);
1785 buf
= XBUFFER (buffer
);
1788 CHECK_SYMBOL (variable
);
1789 variable
= indirect_variable (variable
);
1791 valcontents
= SYMBOL_VALUE (variable
);
1792 if (BUFFER_LOCAL_VALUEP (valcontents
)
1793 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1795 Lisp_Object tail
, elt
;
1797 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1800 if (EQ (variable
, XCAR (elt
)))
1804 if (BUFFER_OBJFWDP (valcontents
))
1806 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1807 int idx
= PER_BUFFER_IDX (offset
);
1808 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1814 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1816 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1817 More precisely, this means that setting the variable \(with `set' or`setq'),
1818 while it does not have a `let'-style binding that was made in BUFFER,
1819 will produce a buffer local binding. See Info node
1820 `(elisp)Creating Buffer-Local'.
1821 BUFFER defaults to the current buffer. */)
1823 register Lisp_Object variable
, buffer
;
1825 Lisp_Object valcontents
;
1826 register struct buffer
*buf
;
1829 buf
= current_buffer
;
1832 CHECK_BUFFER (buffer
);
1833 buf
= XBUFFER (buffer
);
1836 CHECK_SYMBOL (variable
);
1837 variable
= indirect_variable (variable
);
1839 valcontents
= SYMBOL_VALUE (variable
);
1841 /* This means that make-variable-buffer-local was done. */
1842 if (BUFFER_LOCAL_VALUEP (valcontents
))
1844 /* All these slots become local if they are set. */
1845 if (BUFFER_OBJFWDP (valcontents
))
1847 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1849 Lisp_Object tail
, elt
;
1850 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1853 if (EQ (variable
, XCAR (elt
)))
1860 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1862 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1863 If the current binding is buffer-local, the value is the current buffer.
1864 If the current binding is frame-local, the value is the selected frame.
1865 If the current binding is global (the default), the value is nil. */)
1867 register Lisp_Object variable
;
1869 Lisp_Object valcontents
;
1871 CHECK_SYMBOL (variable
);
1872 variable
= indirect_variable (variable
);
1874 /* Make sure the current binding is actually swapped in. */
1875 find_symbol_value (variable
);
1877 valcontents
= XSYMBOL (variable
)->value
;
1879 if (BUFFER_LOCAL_VALUEP (valcontents
)
1880 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1881 || BUFFER_OBJFWDP (valcontents
))
1883 /* For a local variable, record both the symbol and which
1884 buffer's or frame's value we are saving. */
1885 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1886 return Fcurrent_buffer ();
1887 else if (!BUFFER_OBJFWDP (valcontents
)
1888 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1889 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1895 /* This code is disabled now that we use the selected frame to return
1896 keyboard-local-values. */
1898 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1900 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1901 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1902 If SYMBOL is not a terminal-local variable, then return its normal
1903 value, like `symbol-value'.
1905 TERMINAL may be a terminal id, a frame, or nil (meaning the
1906 selected frame's terminal device). */)
1909 Lisp_Object terminal
;
1912 struct terminal
*t
= get_terminal (terminal
, 1);
1913 push_kboard (t
->kboard
);
1914 result
= Fsymbol_value (symbol
);
1919 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1920 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1921 If VARIABLE is not a terminal-local variable, then set its normal
1922 binding, like `set'.
1924 TERMINAL may be a terminal id, a frame, or nil (meaning the
1925 selected frame's terminal device). */)
1926 (symbol
, terminal
, value
)
1928 Lisp_Object terminal
;
1932 struct terminal
*t
= get_terminal (terminal
, 1);
1933 push_kboard (d
->kboard
);
1934 result
= Fset (symbol
, value
);
1940 /* Find the function at the end of a chain of symbol function indirections. */
1942 /* If OBJECT is a symbol, find the end of its function chain and
1943 return the value found there. If OBJECT is not a symbol, just
1944 return it. If there is a cycle in the function chain, signal a
1945 cyclic-function-indirection error.
1947 This is like Findirect_function, except that it doesn't signal an
1948 error if the chain ends up unbound. */
1950 indirect_function (object
)
1951 register Lisp_Object object
;
1953 Lisp_Object tortoise
, hare
;
1955 hare
= tortoise
= object
;
1959 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1961 hare
= XSYMBOL (hare
)->function
;
1962 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1964 hare
= XSYMBOL (hare
)->function
;
1966 tortoise
= XSYMBOL (tortoise
)->function
;
1968 if (EQ (hare
, tortoise
))
1969 xsignal1 (Qcyclic_function_indirection
, object
);
1975 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1976 doc
: /* Return the function at the end of OBJECT's function chain.
1977 If OBJECT is not a symbol, just return it. Otherwise, follow all
1978 function indirections to find the final function binding and return it.
1979 If the final symbol in the chain is unbound, signal a void-function error.
1980 Optional arg NOERROR non-nil means to return nil instead of signalling.
1981 Signal a cyclic-function-indirection error if there is a loop in the
1982 function chain of symbols. */)
1984 register Lisp_Object object
;
1985 Lisp_Object noerror
;
1989 /* Optimize for no indirection. */
1991 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1992 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1993 result
= indirect_function (result
);
1994 if (!EQ (result
, Qunbound
))
1998 xsignal1 (Qvoid_function
, object
);
2003 /* Extract and set vector and string elements */
2005 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2006 doc
: /* Return the element of ARRAY at index IDX.
2007 ARRAY may be a vector, a string, a char-table, a bool-vector,
2008 or a byte-code object. IDX starts at 0. */)
2010 register Lisp_Object array
;
2013 register int idxval
;
2016 idxval
= XINT (idx
);
2017 if (STRINGP (array
))
2021 if (idxval
< 0 || idxval
>= SCHARS (array
))
2022 args_out_of_range (array
, idx
);
2023 if (! STRING_MULTIBYTE (array
))
2024 return make_number ((unsigned char) SREF (array
, idxval
));
2025 idxval_byte
= string_char_to_byte (array
, idxval
);
2027 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2028 SBYTES (array
) - idxval_byte
);
2029 return make_number (c
);
2031 else if (BOOL_VECTOR_P (array
))
2035 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2036 args_out_of_range (array
, idx
);
2038 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2039 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2041 else if (CHAR_TABLE_P (array
))
2048 args_out_of_range (array
, idx
);
2049 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2051 if (! SINGLE_BYTE_CHAR_P (idxval
))
2052 args_out_of_range (array
, idx
);
2053 /* For ASCII and 8-bit European characters, the element is
2054 stored in the top table. */
2055 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2059 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2060 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2061 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2062 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2065 val
= XCHAR_TABLE (array
)->defalt
;
2066 while (NILP (val
)) /* Follow parents until we find some value. */
2068 array
= XCHAR_TABLE (array
)->parent
;
2071 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2073 val
= XCHAR_TABLE (array
)->defalt
;
2080 Lisp_Object sub_table
;
2081 Lisp_Object current_default
;
2083 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2084 if (code
[1] < 32) code
[1] = -1;
2085 else if (code
[2] < 32) code
[2] = -1;
2087 /* Here, the possible range of CODE[0] (== charset ID) is
2088 128..MAX_CHARSET. Since the top level char table contains
2089 data for multibyte characters after 256th element, we must
2090 increment CODE[0] by 128 to get a correct index. */
2092 code
[3] = -1; /* anchor */
2094 try_parent_char_table
:
2095 current_default
= XCHAR_TABLE (array
)->defalt
;
2097 for (i
= 0; code
[i
] >= 0; i
++)
2099 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2100 if (SUB_CHAR_TABLE_P (val
))
2103 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2104 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2109 val
= current_default
;
2112 array
= XCHAR_TABLE (array
)->parent
;
2114 goto try_parent_char_table
;
2119 /* Reaching here means IDXVAL is a generic character in
2120 which each character or a group has independent value.
2121 Essentially it's nonsense to get a value for such a
2122 generic character, but for backward compatibility, we try
2123 the default value and parent. */
2124 val
= current_default
;
2127 array
= XCHAR_TABLE (array
)->parent
;
2129 goto try_parent_char_table
;
2137 if (VECTORP (array
))
2138 size
= XVECTOR (array
)->size
;
2139 else if (COMPILEDP (array
))
2140 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2142 wrong_type_argument (Qarrayp
, array
);
2144 if (idxval
< 0 || idxval
>= size
)
2145 args_out_of_range (array
, idx
);
2146 return XVECTOR (array
)->contents
[idxval
];
2150 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2151 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2152 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2153 bool-vector. IDX starts at 0. */)
2154 (array
, idx
, newelt
)
2155 register Lisp_Object array
;
2156 Lisp_Object idx
, newelt
;
2158 register int idxval
;
2161 idxval
= XINT (idx
);
2162 CHECK_ARRAY (array
, Qarrayp
);
2163 CHECK_IMPURE (array
);
2165 if (VECTORP (array
))
2167 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2168 args_out_of_range (array
, idx
);
2169 XVECTOR (array
)->contents
[idxval
] = newelt
;
2171 else if (BOOL_VECTOR_P (array
))
2175 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2176 args_out_of_range (array
, idx
);
2178 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2180 if (! NILP (newelt
))
2181 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2183 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2184 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2186 else if (CHAR_TABLE_P (array
))
2189 args_out_of_range (array
, idx
);
2190 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2192 if (! SINGLE_BYTE_CHAR_P (idxval
))
2193 args_out_of_range (array
, idx
);
2194 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2201 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2202 if (code
[1] < 32) code
[1] = -1;
2203 else if (code
[2] < 32) code
[2] = -1;
2205 /* See the comment of the corresponding part in Faref. */
2207 code
[3] = -1; /* anchor */
2208 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2210 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2211 if (SUB_CHAR_TABLE_P (val
))
2217 /* VAL is a leaf. Create a sub char table with the
2218 initial value VAL and look into it. */
2220 temp
= make_sub_char_table (val
);
2221 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2225 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2228 else if (STRING_MULTIBYTE (array
))
2230 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2231 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2233 if (idxval
< 0 || idxval
>= SCHARS (array
))
2234 args_out_of_range (array
, idx
);
2235 CHECK_NUMBER (newelt
);
2237 nbytes
= SBYTES (array
);
2239 idxval_byte
= string_char_to_byte (array
, idxval
);
2240 p1
= SDATA (array
) + idxval_byte
;
2241 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2242 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2243 if (prev_bytes
!= new_bytes
)
2245 /* We must relocate the string data. */
2246 int nchars
= SCHARS (array
);
2250 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2251 bcopy (SDATA (array
), str
, nbytes
);
2252 allocate_string_data (XSTRING (array
), nchars
,
2253 nbytes
+ new_bytes
- prev_bytes
);
2254 bcopy (str
, SDATA (array
), idxval_byte
);
2255 p1
= SDATA (array
) + idxval_byte
;
2256 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2257 nbytes
- (idxval_byte
+ prev_bytes
));
2259 clear_string_char_byte_cache ();
2266 if (idxval
< 0 || idxval
>= SCHARS (array
))
2267 args_out_of_range (array
, idx
);
2268 CHECK_NUMBER (newelt
);
2270 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2271 SSET (array
, idxval
, XINT (newelt
));
2274 /* We must relocate the string data while converting it to
2276 int idxval_byte
, prev_bytes
, new_bytes
;
2277 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2278 unsigned char *origstr
= SDATA (array
), *str
;
2282 nchars
= SCHARS (array
);
2283 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2284 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2286 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2287 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2288 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2290 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2291 allocate_string_data (XSTRING (array
), nchars
,
2292 nbytes
+ new_bytes
- prev_bytes
);
2293 bcopy (str
, SDATA (array
), idxval_byte
);
2294 p1
= SDATA (array
) + idxval_byte
;
2297 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2298 nbytes
- (idxval_byte
+ prev_bytes
));
2300 clear_string_char_byte_cache ();
2307 /* Arithmetic functions */
2309 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2312 arithcompare (num1
, num2
, comparison
)
2313 Lisp_Object num1
, num2
;
2314 enum comparison comparison
;
2316 double f1
= 0, f2
= 0;
2319 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2320 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2322 if (FLOATP (num1
) || FLOATP (num2
))
2325 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2326 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2332 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2337 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2342 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2347 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2352 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2357 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2366 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2367 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2369 register Lisp_Object num1
, num2
;
2371 return arithcompare (num1
, num2
, equal
);
2374 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2375 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2377 register Lisp_Object num1
, num2
;
2379 return arithcompare (num1
, num2
, less
);
2382 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2383 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2385 register Lisp_Object num1
, num2
;
2387 return arithcompare (num1
, num2
, grtr
);
2390 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2391 doc
: /* Return t if first arg is less than or equal to second arg.
2392 Both must be numbers or markers. */)
2394 register Lisp_Object num1
, num2
;
2396 return arithcompare (num1
, num2
, less_or_equal
);
2399 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2400 doc
: /* Return t if first arg is greater than or equal to second arg.
2401 Both must be numbers or markers. */)
2403 register Lisp_Object num1
, num2
;
2405 return arithcompare (num1
, num2
, grtr_or_equal
);
2408 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2409 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2411 register Lisp_Object num1
, num2
;
2413 return arithcompare (num1
, num2
, notequal
);
2416 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2417 doc
: /* Return t if NUMBER is zero. */)
2419 register Lisp_Object number
;
2421 CHECK_NUMBER_OR_FLOAT (number
);
2423 if (FLOATP (number
))
2425 if (XFLOAT_DATA (number
) == 0.0)
2435 /* Convert between long values and pairs of Lisp integers.
2436 Note that long_to_cons returns a single Lisp integer
2437 when the value fits in one. */
2443 unsigned long top
= i
>> 16;
2444 unsigned int bot
= i
& 0xFFFF;
2446 return make_number (bot
);
2447 if (top
== (unsigned long)-1 >> 16)
2448 return Fcons (make_number (-1), make_number (bot
));
2449 return Fcons (make_number (top
), make_number (bot
));
2456 Lisp_Object top
, bot
;
2463 return ((XINT (top
) << 16) | XINT (bot
));
2466 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2467 doc
: /* Return the decimal representation of NUMBER as a string.
2468 Uses a minus sign if negative.
2469 NUMBER may be an integer or a floating point number. */)
2473 char buffer
[VALBITS
];
2475 CHECK_NUMBER_OR_FLOAT (number
);
2477 if (FLOATP (number
))
2479 char pigbuf
[350]; /* see comments in float_to_string */
2481 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2482 return build_string (pigbuf
);
2485 if (sizeof (int) == sizeof (EMACS_INT
))
2486 sprintf (buffer
, "%d", XINT (number
));
2487 else if (sizeof (long) == sizeof (EMACS_INT
))
2488 sprintf (buffer
, "%ld", (long) XINT (number
));
2491 return build_string (buffer
);
2495 digit_to_number (character
, base
)
2496 int character
, base
;
2500 if (character
>= '0' && character
<= '9')
2501 digit
= character
- '0';
2502 else if (character
>= 'a' && character
<= 'z')
2503 digit
= character
- 'a' + 10;
2504 else if (character
>= 'A' && character
<= 'Z')
2505 digit
= character
- 'A' + 10;
2515 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2516 doc
: /* Parse STRING as a decimal number and return the number.
2517 This parses both integers and floating point numbers.
2518 It ignores leading spaces and tabs.
2520 If BASE, interpret STRING as a number in that base. If BASE isn't
2521 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2522 If the base used is not 10, floating point is not recognized. */)
2524 register Lisp_Object string
, base
;
2526 register unsigned char *p
;
2531 CHECK_STRING (string
);
2537 CHECK_NUMBER (base
);
2539 if (b
< 2 || b
> 16)
2540 xsignal1 (Qargs_out_of_range
, base
);
2543 /* Skip any whitespace at the front of the number. Some versions of
2544 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2546 while (*p
== ' ' || *p
== '\t')
2557 if (isfloat_string (p
) && b
== 10)
2558 val
= make_float (sign
* atof (p
));
2565 int digit
= digit_to_number (*p
++, b
);
2571 val
= make_fixnum_or_float (sign
* v
);
2591 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2592 int, Lisp_Object
*));
2593 extern Lisp_Object
fmod_float ();
2596 arith_driver (code
, nargs
, args
)
2599 register Lisp_Object
*args
;
2601 register Lisp_Object val
;
2602 register int argnum
;
2603 register EMACS_INT accum
= 0;
2604 register EMACS_INT next
;
2606 switch (SWITCH_ENUM_CAST (code
))
2624 for (argnum
= 0; argnum
< nargs
; argnum
++)
2626 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2628 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2631 return float_arith_driver ((double) accum
, argnum
, code
,
2634 next
= XINT (args
[argnum
]);
2635 switch (SWITCH_ENUM_CAST (code
))
2641 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2652 xsignal0 (Qarith_error
);
2666 if (!argnum
|| next
> accum
)
2670 if (!argnum
|| next
< accum
)
2676 XSETINT (val
, accum
);
2681 #define isnan(x) ((x) != (x))
2684 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2686 register int argnum
;
2689 register Lisp_Object
*args
;
2691 register Lisp_Object val
;
2694 for (; argnum
< nargs
; argnum
++)
2696 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2697 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2701 next
= XFLOAT_DATA (val
);
2705 args
[argnum
] = val
; /* runs into a compiler bug. */
2706 next
= XINT (args
[argnum
]);
2708 switch (SWITCH_ENUM_CAST (code
))
2714 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2724 if (! IEEE_FLOATING_POINT
&& next
== 0)
2725 xsignal0 (Qarith_error
);
2732 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2734 if (!argnum
|| isnan (next
) || next
> accum
)
2738 if (!argnum
|| isnan (next
) || next
< accum
)
2744 return make_float (accum
);
2748 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2749 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2750 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2755 return arith_driver (Aadd
, nargs
, args
);
2758 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2759 doc
: /* Negate number or subtract numbers or markers and return the result.
2760 With one arg, negates it. With more than one arg,
2761 subtracts all but the first from the first.
2762 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2767 return arith_driver (Asub
, nargs
, args
);
2770 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2771 doc
: /* Return product of any number of arguments, which are numbers or markers.
2772 usage: (* &rest NUMBERS-OR-MARKERS) */)
2777 return arith_driver (Amult
, nargs
, args
);
2780 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2781 doc
: /* Return first argument divided by all the remaining arguments.
2782 The arguments must be numbers or markers.
2783 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2789 for (argnum
= 2; argnum
< nargs
; argnum
++)
2790 if (FLOATP (args
[argnum
]))
2791 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2792 return arith_driver (Adiv
, nargs
, args
);
2795 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2796 doc
: /* Return remainder of X divided by Y.
2797 Both must be integers or markers. */)
2799 register Lisp_Object x
, y
;
2803 CHECK_NUMBER_COERCE_MARKER (x
);
2804 CHECK_NUMBER_COERCE_MARKER (y
);
2806 if (XFASTINT (y
) == 0)
2807 xsignal0 (Qarith_error
);
2809 XSETINT (val
, XINT (x
) % XINT (y
));
2823 /* If the magnitude of the result exceeds that of the divisor, or
2824 the sign of the result does not agree with that of the dividend,
2825 iterate with the reduced value. This does not yield a
2826 particularly accurate result, but at least it will be in the
2827 range promised by fmod. */
2829 r
-= f2
* floor (r
/ f2
);
2830 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2834 #endif /* ! HAVE_FMOD */
2836 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2837 doc
: /* Return X modulo Y.
2838 The result falls between zero (inclusive) and Y (exclusive).
2839 Both X and Y must be numbers or markers. */)
2841 register Lisp_Object x
, y
;
2846 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2847 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2849 if (FLOATP (x
) || FLOATP (y
))
2850 return fmod_float (x
, y
);
2856 xsignal0 (Qarith_error
);
2860 /* If the "remainder" comes out with the wrong sign, fix it. */
2861 if (i2
< 0 ? i1
> 0 : i1
< 0)
2868 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2869 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2870 The value is always a number; markers are converted to numbers.
2871 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2876 return arith_driver (Amax
, nargs
, args
);
2879 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2880 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2881 The value is always a number; markers are converted to numbers.
2882 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2887 return arith_driver (Amin
, nargs
, args
);
2890 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2891 doc
: /* Return bitwise-and of all the arguments.
2892 Arguments may be integers, or markers converted to integers.
2893 usage: (logand &rest INTS-OR-MARKERS) */)
2898 return arith_driver (Alogand
, nargs
, args
);
2901 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2902 doc
: /* Return bitwise-or of all the arguments.
2903 Arguments may be integers, or markers converted to integers.
2904 usage: (logior &rest INTS-OR-MARKERS) */)
2909 return arith_driver (Alogior
, nargs
, args
);
2912 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2913 doc
: /* Return bitwise-exclusive-or of all the arguments.
2914 Arguments may be integers, or markers converted to integers.
2915 usage: (logxor &rest INTS-OR-MARKERS) */)
2920 return arith_driver (Alogxor
, nargs
, args
);
2923 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2924 doc
: /* Return VALUE with its bits shifted left by COUNT.
2925 If COUNT is negative, shifting is actually to the right.
2926 In this case, the sign bit is duplicated. */)
2928 register Lisp_Object value
, count
;
2930 register Lisp_Object val
;
2932 CHECK_NUMBER (value
);
2933 CHECK_NUMBER (count
);
2935 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2937 else if (XINT (count
) > 0)
2938 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2939 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2940 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2942 XSETINT (val
, XINT (value
) >> -XINT (count
));
2946 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2947 doc
: /* Return VALUE with its bits shifted left by COUNT.
2948 If COUNT is negative, shifting is actually to the right.
2949 In this case, zeros are shifted in on the left. */)
2951 register Lisp_Object value
, count
;
2953 register Lisp_Object val
;
2955 CHECK_NUMBER (value
);
2956 CHECK_NUMBER (count
);
2958 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2960 else if (XINT (count
) > 0)
2961 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2962 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2965 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2969 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2970 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2971 Markers are converted to integers. */)
2973 register Lisp_Object number
;
2975 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2977 if (FLOATP (number
))
2978 return (make_float (1.0 + XFLOAT_DATA (number
)));
2980 XSETINT (number
, XINT (number
) + 1);
2984 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2985 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2986 Markers are converted to integers. */)
2988 register Lisp_Object number
;
2990 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2992 if (FLOATP (number
))
2993 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2995 XSETINT (number
, XINT (number
) - 1);
2999 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3000 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3002 register Lisp_Object number
;
3004 CHECK_NUMBER (number
);
3005 XSETINT (number
, ~XINT (number
));
3009 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3010 doc
: /* Return the byteorder for the machine.
3011 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3012 lowercase l) for small endian machines. */)
3015 unsigned i
= 0x04030201;
3016 int order
= *(char *)&i
== 1 ? 108 : 66;
3018 return make_number (order
);
3026 Lisp_Object error_tail
, arith_tail
;
3028 Qquote
= intern ("quote");
3029 Qlambda
= intern ("lambda");
3030 Qsubr
= intern ("subr");
3031 Qerror_conditions
= intern ("error-conditions");
3032 Qerror_message
= intern ("error-message");
3033 Qtop_level
= intern ("top-level");
3035 Qerror
= intern ("error");
3036 Qquit
= intern ("quit");
3037 Qwrong_type_argument
= intern ("wrong-type-argument");
3038 Qargs_out_of_range
= intern ("args-out-of-range");
3039 Qvoid_function
= intern ("void-function");
3040 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3041 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3042 Qvoid_variable
= intern ("void-variable");
3043 Qsetting_constant
= intern ("setting-constant");
3044 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3046 Qinvalid_function
= intern ("invalid-function");
3047 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3048 Qno_catch
= intern ("no-catch");
3049 Qend_of_file
= intern ("end-of-file");
3050 Qarith_error
= intern ("arith-error");
3051 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3052 Qend_of_buffer
= intern ("end-of-buffer");
3053 Qbuffer_read_only
= intern ("buffer-read-only");
3054 Qtext_read_only
= intern ("text-read-only");
3055 Qmark_inactive
= intern ("mark-inactive");
3057 Qlistp
= intern ("listp");
3058 Qconsp
= intern ("consp");
3059 Qsymbolp
= intern ("symbolp");
3060 Qkeywordp
= intern ("keywordp");
3061 Qintegerp
= intern ("integerp");
3062 Qnatnump
= intern ("natnump");
3063 Qwholenump
= intern ("wholenump");
3064 Qstringp
= intern ("stringp");
3065 Qarrayp
= intern ("arrayp");
3066 Qsequencep
= intern ("sequencep");
3067 Qbufferp
= intern ("bufferp");
3068 Qvectorp
= intern ("vectorp");
3069 Qchar_or_string_p
= intern ("char-or-string-p");
3070 Qmarkerp
= intern ("markerp");
3071 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3072 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3073 Qboundp
= intern ("boundp");
3074 Qfboundp
= intern ("fboundp");
3076 Qfloatp
= intern ("floatp");
3077 Qnumberp
= intern ("numberp");
3078 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3080 Qchar_table_p
= intern ("char-table-p");
3081 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3083 Qsubrp
= intern ("subrp");
3084 Qunevalled
= intern ("unevalled");
3085 Qmany
= intern ("many");
3087 Qcdr
= intern ("cdr");
3089 /* Handle automatic advice activation */
3090 Qad_advice_info
= intern ("ad-advice-info");
3091 Qad_activate_internal
= intern ("ad-activate-internal");
3093 error_tail
= Fcons (Qerror
, Qnil
);
3095 /* ERROR is used as a signaler for random errors for which nothing else is right */
3097 Fput (Qerror
, Qerror_conditions
,
3099 Fput (Qerror
, Qerror_message
,
3100 build_string ("error"));
3102 Fput (Qquit
, Qerror_conditions
,
3103 Fcons (Qquit
, Qnil
));
3104 Fput (Qquit
, Qerror_message
,
3105 build_string ("Quit"));
3107 Fput (Qwrong_type_argument
, Qerror_conditions
,
3108 Fcons (Qwrong_type_argument
, error_tail
));
3109 Fput (Qwrong_type_argument
, Qerror_message
,
3110 build_string ("Wrong type argument"));
3112 Fput (Qargs_out_of_range
, Qerror_conditions
,
3113 Fcons (Qargs_out_of_range
, error_tail
));
3114 Fput (Qargs_out_of_range
, Qerror_message
,
3115 build_string ("Args out of range"));
3117 Fput (Qvoid_function
, Qerror_conditions
,
3118 Fcons (Qvoid_function
, error_tail
));
3119 Fput (Qvoid_function
, Qerror_message
,
3120 build_string ("Symbol's function definition is void"));
3122 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3123 Fcons (Qcyclic_function_indirection
, error_tail
));
3124 Fput (Qcyclic_function_indirection
, Qerror_message
,
3125 build_string ("Symbol's chain of function indirections contains a loop"));
3127 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3128 Fcons (Qcyclic_variable_indirection
, error_tail
));
3129 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3130 build_string ("Symbol's chain of variable indirections contains a loop"));
3132 Qcircular_list
= intern ("circular-list");
3133 staticpro (&Qcircular_list
);
3134 Fput (Qcircular_list
, Qerror_conditions
,
3135 Fcons (Qcircular_list
, error_tail
));
3136 Fput (Qcircular_list
, Qerror_message
,
3137 build_string ("List contains a loop"));
3139 Fput (Qvoid_variable
, Qerror_conditions
,
3140 Fcons (Qvoid_variable
, error_tail
));
3141 Fput (Qvoid_variable
, Qerror_message
,
3142 build_string ("Symbol's value as variable is void"));
3144 Fput (Qsetting_constant
, Qerror_conditions
,
3145 Fcons (Qsetting_constant
, error_tail
));
3146 Fput (Qsetting_constant
, Qerror_message
,
3147 build_string ("Attempt to set a constant symbol"));
3149 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3150 Fcons (Qinvalid_read_syntax
, error_tail
));
3151 Fput (Qinvalid_read_syntax
, Qerror_message
,
3152 build_string ("Invalid read syntax"));
3154 Fput (Qinvalid_function
, Qerror_conditions
,
3155 Fcons (Qinvalid_function
, error_tail
));
3156 Fput (Qinvalid_function
, Qerror_message
,
3157 build_string ("Invalid function"));
3159 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3160 Fcons (Qwrong_number_of_arguments
, error_tail
));
3161 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3162 build_string ("Wrong number of arguments"));
3164 Fput (Qno_catch
, Qerror_conditions
,
3165 Fcons (Qno_catch
, error_tail
));
3166 Fput (Qno_catch
, Qerror_message
,
3167 build_string ("No catch for tag"));
3169 Fput (Qend_of_file
, Qerror_conditions
,
3170 Fcons (Qend_of_file
, error_tail
));
3171 Fput (Qend_of_file
, Qerror_message
,
3172 build_string ("End of file during parsing"));
3174 arith_tail
= Fcons (Qarith_error
, error_tail
);
3175 Fput (Qarith_error
, Qerror_conditions
,
3177 Fput (Qarith_error
, Qerror_message
,
3178 build_string ("Arithmetic error"));
3180 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3181 Fcons (Qbeginning_of_buffer
, error_tail
));
3182 Fput (Qbeginning_of_buffer
, Qerror_message
,
3183 build_string ("Beginning of buffer"));
3185 Fput (Qend_of_buffer
, Qerror_conditions
,
3186 Fcons (Qend_of_buffer
, error_tail
));
3187 Fput (Qend_of_buffer
, Qerror_message
,
3188 build_string ("End of buffer"));
3190 Fput (Qbuffer_read_only
, Qerror_conditions
,
3191 Fcons (Qbuffer_read_only
, error_tail
));
3192 Fput (Qbuffer_read_only
, Qerror_message
,
3193 build_string ("Buffer is read-only"));
3195 Fput (Qtext_read_only
, Qerror_conditions
,
3196 Fcons (Qtext_read_only
, error_tail
));
3197 Fput (Qtext_read_only
, Qerror_message
,
3198 build_string ("Text is read-only"));
3200 Qrange_error
= intern ("range-error");
3201 Qdomain_error
= intern ("domain-error");
3202 Qsingularity_error
= intern ("singularity-error");
3203 Qoverflow_error
= intern ("overflow-error");
3204 Qunderflow_error
= intern ("underflow-error");
3206 Fput (Qdomain_error
, Qerror_conditions
,
3207 Fcons (Qdomain_error
, arith_tail
));
3208 Fput (Qdomain_error
, Qerror_message
,
3209 build_string ("Arithmetic domain error"));
3211 Fput (Qrange_error
, Qerror_conditions
,
3212 Fcons (Qrange_error
, arith_tail
));
3213 Fput (Qrange_error
, Qerror_message
,
3214 build_string ("Arithmetic range error"));
3216 Fput (Qsingularity_error
, Qerror_conditions
,
3217 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3218 Fput (Qsingularity_error
, Qerror_message
,
3219 build_string ("Arithmetic singularity error"));
3221 Fput (Qoverflow_error
, Qerror_conditions
,
3222 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3223 Fput (Qoverflow_error
, Qerror_message
,
3224 build_string ("Arithmetic overflow error"));
3226 Fput (Qunderflow_error
, Qerror_conditions
,
3227 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3228 Fput (Qunderflow_error
, Qerror_message
,
3229 build_string ("Arithmetic underflow error"));
3231 staticpro (&Qrange_error
);
3232 staticpro (&Qdomain_error
);
3233 staticpro (&Qsingularity_error
);
3234 staticpro (&Qoverflow_error
);
3235 staticpro (&Qunderflow_error
);
3239 staticpro (&Qquote
);
3240 staticpro (&Qlambda
);
3242 staticpro (&Qunbound
);
3243 staticpro (&Qerror_conditions
);
3244 staticpro (&Qerror_message
);
3245 staticpro (&Qtop_level
);
3247 staticpro (&Qerror
);
3249 staticpro (&Qwrong_type_argument
);
3250 staticpro (&Qargs_out_of_range
);
3251 staticpro (&Qvoid_function
);
3252 staticpro (&Qcyclic_function_indirection
);
3253 staticpro (&Qcyclic_variable_indirection
);
3254 staticpro (&Qvoid_variable
);
3255 staticpro (&Qsetting_constant
);
3256 staticpro (&Qinvalid_read_syntax
);
3257 staticpro (&Qwrong_number_of_arguments
);
3258 staticpro (&Qinvalid_function
);
3259 staticpro (&Qno_catch
);
3260 staticpro (&Qend_of_file
);
3261 staticpro (&Qarith_error
);
3262 staticpro (&Qbeginning_of_buffer
);
3263 staticpro (&Qend_of_buffer
);
3264 staticpro (&Qbuffer_read_only
);
3265 staticpro (&Qtext_read_only
);
3266 staticpro (&Qmark_inactive
);
3268 staticpro (&Qlistp
);
3269 staticpro (&Qconsp
);
3270 staticpro (&Qsymbolp
);
3271 staticpro (&Qkeywordp
);
3272 staticpro (&Qintegerp
);
3273 staticpro (&Qnatnump
);
3274 staticpro (&Qwholenump
);
3275 staticpro (&Qstringp
);
3276 staticpro (&Qarrayp
);
3277 staticpro (&Qsequencep
);
3278 staticpro (&Qbufferp
);
3279 staticpro (&Qvectorp
);
3280 staticpro (&Qchar_or_string_p
);
3281 staticpro (&Qmarkerp
);
3282 staticpro (&Qbuffer_or_string_p
);
3283 staticpro (&Qinteger_or_marker_p
);
3284 staticpro (&Qfloatp
);
3285 staticpro (&Qnumberp
);
3286 staticpro (&Qnumber_or_marker_p
);
3287 staticpro (&Qchar_table_p
);
3288 staticpro (&Qvector_or_char_table_p
);
3289 staticpro (&Qsubrp
);
3291 staticpro (&Qunevalled
);
3293 staticpro (&Qboundp
);
3294 staticpro (&Qfboundp
);
3296 staticpro (&Qad_advice_info
);
3297 staticpro (&Qad_activate_internal
);
3299 /* Types that type-of returns. */
3300 Qinteger
= intern ("integer");
3301 Qsymbol
= intern ("symbol");
3302 Qstring
= intern ("string");
3303 Qcons
= intern ("cons");
3304 Qmarker
= intern ("marker");
3305 Qoverlay
= intern ("overlay");
3306 Qfloat
= intern ("float");
3307 Qwindow_configuration
= intern ("window-configuration");
3308 Qprocess
= intern ("process");
3309 Qwindow
= intern ("window");
3310 /* Qsubr = intern ("subr"); */
3311 Qcompiled_function
= intern ("compiled-function");
3312 Qbuffer
= intern ("buffer");
3313 Qframe
= intern ("frame");
3314 Qvector
= intern ("vector");
3315 Qchar_table
= intern ("char-table");
3316 Qbool_vector
= intern ("bool-vector");
3317 Qhash_table
= intern ("hash-table");
3319 staticpro (&Qinteger
);
3320 staticpro (&Qsymbol
);
3321 staticpro (&Qstring
);
3323 staticpro (&Qmarker
);
3324 staticpro (&Qoverlay
);
3325 staticpro (&Qfloat
);
3326 staticpro (&Qwindow_configuration
);
3327 staticpro (&Qprocess
);
3328 staticpro (&Qwindow
);
3329 /* staticpro (&Qsubr); */
3330 staticpro (&Qcompiled_function
);
3331 staticpro (&Qbuffer
);
3332 staticpro (&Qframe
);
3333 staticpro (&Qvector
);
3334 staticpro (&Qchar_table
);
3335 staticpro (&Qbool_vector
);
3336 staticpro (&Qhash_table
);
3338 defsubr (&Sindirect_variable
);
3339 defsubr (&Sinteractive_form
);
3342 defsubr (&Stype_of
);
3347 defsubr (&Sintegerp
);
3348 defsubr (&Sinteger_or_marker_p
);
3349 defsubr (&Snumberp
);
3350 defsubr (&Snumber_or_marker_p
);
3352 defsubr (&Snatnump
);
3353 defsubr (&Ssymbolp
);
3354 defsubr (&Skeywordp
);
3355 defsubr (&Sstringp
);
3356 defsubr (&Smultibyte_string_p
);
3357 defsubr (&Svectorp
);
3358 defsubr (&Schar_table_p
);
3359 defsubr (&Svector_or_char_table_p
);
3360 defsubr (&Sbool_vector_p
);
3362 defsubr (&Ssequencep
);
3363 defsubr (&Sbufferp
);
3364 defsubr (&Smarkerp
);
3366 defsubr (&Sbyte_code_function_p
);
3367 defsubr (&Schar_or_string_p
);
3370 defsubr (&Scar_safe
);
3371 defsubr (&Scdr_safe
);
3374 defsubr (&Ssymbol_function
);
3375 defsubr (&Sindirect_function
);
3376 defsubr (&Ssymbol_plist
);
3377 defsubr (&Ssymbol_name
);
3378 defsubr (&Smakunbound
);
3379 defsubr (&Sfmakunbound
);
3381 defsubr (&Sfboundp
);
3383 defsubr (&Sdefalias
);
3384 defsubr (&Ssetplist
);
3385 defsubr (&Ssymbol_value
);
3387 defsubr (&Sdefault_boundp
);
3388 defsubr (&Sdefault_value
);
3389 defsubr (&Sset_default
);
3390 defsubr (&Ssetq_default
);
3391 defsubr (&Smake_variable_buffer_local
);
3392 defsubr (&Smake_local_variable
);
3393 defsubr (&Skill_local_variable
);
3394 defsubr (&Smake_variable_frame_local
);
3395 defsubr (&Slocal_variable_p
);
3396 defsubr (&Slocal_variable_if_set_p
);
3397 defsubr (&Svariable_binding_locus
);
3398 #if 0 /* XXX Remove this. --lorentey */
3399 defsubr (&Sterminal_local_value
);
3400 defsubr (&Sset_terminal_local_value
);
3404 defsubr (&Snumber_to_string
);
3405 defsubr (&Sstring_to_number
);
3406 defsubr (&Seqlsign
);
3429 defsubr (&Sbyteorder
);
3430 defsubr (&Ssubr_arity
);
3431 defsubr (&Ssubr_name
);
3433 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3435 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3436 doc
: /* The largest value that is representable in a Lisp integer. */);
3437 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3439 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3440 doc
: /* The smallest value that is representable in a Lisp integer. */);
3441 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3448 #if defined(USG) && !defined(POSIX_SIGNALS)
3449 /* USG systems forget handlers when they are used;
3450 must reestablish each time */
3451 signal (signo
, arith_error
);
3454 /* VMS systems are like USG. */
3455 signal (signo
, arith_error
);
3459 #else /* not BSD4_1 */
3460 sigsetmask (SIGEMPTYMASK
);
3461 #endif /* not BSD4_1 */
3463 SIGNAL_THREAD_CHECK (signo
);
3464 xsignal0 (Qarith_error
);
3470 /* Don't do this if just dumping out.
3471 We don't want to call `signal' in this case
3472 so that we don't have trouble with dumping
3473 signal-delivering routines in an inconsistent state. */
3477 #endif /* CANNOT_DUMP */
3478 signal (SIGFPE
, arith_error
);
3481 signal (SIGEMT
, arith_error
);
3485 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3486 (do not change this comment) */