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 if (XSUBR (fun
)->prompt
)
774 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
776 else if (COMPILEDP (fun
))
778 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
779 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
781 else if (CONSP (fun
))
783 Lisp_Object funcar
= XCAR (fun
);
784 if (EQ (funcar
, Qlambda
))
785 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
786 else if (EQ (funcar
, Qautoload
))
790 do_autoload (fun
, cmd
);
792 return Finteractive_form (cmd
);
799 /***********************************************************************
800 Getting and Setting Values of Symbols
801 ***********************************************************************/
803 /* Return the symbol holding SYMBOL's value. Signal
804 `cyclic-variable-indirection' if SYMBOL's chain of variable
805 indirections contains a loop. */
808 indirect_variable (symbol
)
811 Lisp_Object tortoise
, hare
;
813 hare
= tortoise
= symbol
;
815 while (XSYMBOL (hare
)->indirect_variable
)
817 hare
= XSYMBOL (hare
)->value
;
818 if (!XSYMBOL (hare
)->indirect_variable
)
821 hare
= XSYMBOL (hare
)->value
;
822 tortoise
= XSYMBOL (tortoise
)->value
;
824 if (EQ (hare
, tortoise
))
825 xsignal1 (Qcyclic_variable_indirection
, symbol
);
832 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
833 doc
: /* Return the variable at the end of OBJECT's variable chain.
834 If OBJECT is a symbol, follow all variable indirections and return the final
835 variable. If OBJECT is not a symbol, just return it.
836 Signal a cyclic-variable-indirection error if there is a loop in the
837 variable chain of symbols. */)
841 if (SYMBOLP (object
))
842 object
= indirect_variable (object
);
847 /* Given the raw contents of a symbol value cell,
848 return the Lisp value of the symbol.
849 This does not handle buffer-local variables; use
850 swap_in_symval_forwarding for that. */
853 do_symval_forwarding (valcontents
)
854 register Lisp_Object valcontents
;
856 register Lisp_Object val
;
858 if (MISCP (valcontents
))
859 switch (XMISCTYPE (valcontents
))
861 case Lisp_Misc_Intfwd
:
862 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
865 case Lisp_Misc_Boolfwd
:
866 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
868 case Lisp_Misc_Objfwd
:
869 return *XOBJFWD (valcontents
)->objvar
;
871 case Lisp_Misc_Buffer_Objfwd
:
872 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
873 return PER_BUFFER_VALUE (current_buffer
, offset
);
875 case Lisp_Misc_Kboard_Objfwd
:
876 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
877 /* We used to simply use current_kboard here, but from Lisp
878 code, it's value is often unexpected. It seems nicer to
879 allow constructions like this to work as intuitively expected:
881 (with-selected-frame frame
882 (define-key local-function-map "\eOP" [f1]))
884 On the other hand, this affects the semantics of
885 last-command and real-last-command, and people may rely on
886 that. I took a quick look at the Lisp codebase, and I
887 don't think anything will break. --lorentey */
888 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
893 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
894 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
895 buffer-independent contents of the value cell: forwarded just one
896 step past the buffer-localness.
898 BUF non-zero means set the value in buffer BUF instead of the
899 current buffer. This only plays a role for per-buffer variables. */
902 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
904 register Lisp_Object valcontents
, newval
;
907 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
910 switch (XMISCTYPE (valcontents
))
912 case Lisp_Misc_Intfwd
:
913 CHECK_NUMBER (newval
);
914 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
915 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
916 error ("Value out of range for variable `%s'",
917 SDATA (SYMBOL_NAME (symbol
)));
920 case Lisp_Misc_Boolfwd
:
921 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
924 case Lisp_Misc_Objfwd
:
925 *XOBJFWD (valcontents
)->objvar
= newval
;
927 /* If this variable is a default for something stored
928 in the buffer itself, such as default-fill-column,
929 find the buffers that don't have local values for it
931 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
932 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
934 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
935 - (char *) &buffer_defaults
);
936 int idx
= PER_BUFFER_IDX (offset
);
943 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
948 buf
= Fcdr (XCAR (tail
));
949 if (!BUFFERP (buf
)) continue;
952 if (! PER_BUFFER_VALUE_P (b
, idx
))
953 PER_BUFFER_VALUE (b
, offset
) = newval
;
958 case Lisp_Misc_Buffer_Objfwd
:
960 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
963 type
= PER_BUFFER_TYPE (offset
);
964 if (! NILP (type
) && ! NILP (newval
)
965 && XTYPE (newval
) != XINT (type
))
966 buffer_slot_type_mismatch (offset
);
969 buf
= current_buffer
;
970 PER_BUFFER_VALUE (buf
, offset
) = newval
;
974 case Lisp_Misc_Kboard_Objfwd
:
976 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
977 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
978 *(Lisp_Object
*) p
= newval
;
989 valcontents
= SYMBOL_VALUE (symbol
);
990 if (BUFFER_LOCAL_VALUEP (valcontents
)
991 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
992 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
994 SET_SYMBOL_VALUE (symbol
, newval
);
998 /* Set up SYMBOL to refer to its global binding.
999 This makes it safe to alter the status of other bindings. */
1002 swap_in_global_binding (symbol
)
1005 Lisp_Object valcontents
, cdr
;
1007 valcontents
= SYMBOL_VALUE (symbol
);
1008 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1009 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1011 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1013 /* Unload the previously loaded binding. */
1014 Fsetcdr (XCAR (cdr
),
1015 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1017 /* Select the global binding in the symbol. */
1019 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1021 /* Indicate that the global binding is set up now. */
1022 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1023 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1024 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1025 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1028 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1029 VALCONTENTS is the contents of its value cell,
1030 which points to a struct Lisp_Buffer_Local_Value.
1032 Return the value forwarded one step past the buffer-local stage.
1033 This could be another forwarding pointer. */
1036 swap_in_symval_forwarding (symbol
, valcontents
)
1037 Lisp_Object symbol
, valcontents
;
1039 register Lisp_Object tem1
;
1041 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1044 || current_buffer
!= XBUFFER (tem1
)
1045 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1046 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1048 if (XSYMBOL (symbol
)->indirect_variable
)
1049 symbol
= indirect_variable (symbol
);
1051 /* Unload the previously loaded binding. */
1052 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1054 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1055 /* Choose the new binding. */
1056 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1057 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1058 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1061 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1062 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1064 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1066 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1069 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1071 /* Load the new binding. */
1072 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1073 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1074 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1075 store_symval_forwarding (symbol
,
1076 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1079 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1082 /* Find the value of a symbol, returning Qunbound if it's not bound.
1083 This is helpful for code which just wants to get a variable's value
1084 if it has one, without signaling an error.
1085 Note that it must not be possible to quit
1086 within this function. Great care is required for this. */
1089 find_symbol_value (symbol
)
1092 register Lisp_Object valcontents
;
1093 register Lisp_Object val
;
1095 CHECK_SYMBOL (symbol
);
1096 valcontents
= SYMBOL_VALUE (symbol
);
1098 if (BUFFER_LOCAL_VALUEP (valcontents
)
1099 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1100 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1102 if (MISCP (valcontents
))
1104 switch (XMISCTYPE (valcontents
))
1106 case Lisp_Misc_Intfwd
:
1107 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1110 case Lisp_Misc_Boolfwd
:
1111 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1113 case Lisp_Misc_Objfwd
:
1114 return *XOBJFWD (valcontents
)->objvar
;
1116 case Lisp_Misc_Buffer_Objfwd
:
1117 return PER_BUFFER_VALUE (current_buffer
,
1118 XBUFFER_OBJFWD (valcontents
)->offset
);
1120 case Lisp_Misc_Kboard_Objfwd
:
1121 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1122 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1129 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1130 doc
: /* Return SYMBOL's value. Error if that is void. */)
1136 val
= find_symbol_value (symbol
);
1137 if (!EQ (val
, Qunbound
))
1140 xsignal1 (Qvoid_variable
, symbol
);
1143 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1144 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1146 register Lisp_Object symbol
, newval
;
1148 return set_internal (symbol
, newval
, current_buffer
, 0);
1151 /* Return 1 if SYMBOL currently has a let-binding
1152 which was made in the buffer that is now current. */
1155 let_shadows_buffer_binding_p (symbol
)
1158 volatile struct specbinding
*p
;
1160 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1162 && CONSP (p
->symbol
))
1164 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1165 if ((EQ (symbol
, let_bound_symbol
)
1166 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1167 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1168 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1172 return p
>= specpdl
;
1175 /* Store the value NEWVAL into SYMBOL.
1176 If buffer-locality is an issue, BUF specifies which buffer to use.
1177 (0 stands for the current buffer.)
1179 If BINDFLAG is zero, then if this symbol is supposed to become
1180 local in every buffer where it is set, then we make it local.
1181 If BINDFLAG is nonzero, we don't do that. */
1184 set_internal (symbol
, newval
, buf
, bindflag
)
1185 register Lisp_Object symbol
, newval
;
1189 int voide
= EQ (newval
, Qunbound
);
1191 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1194 buf
= current_buffer
;
1196 /* If restoring in a dead buffer, do nothing. */
1197 if (NILP (buf
->name
))
1200 CHECK_SYMBOL (symbol
);
1201 if (SYMBOL_CONSTANT_P (symbol
)
1202 && (NILP (Fkeywordp (symbol
))
1203 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1204 xsignal1 (Qsetting_constant
, symbol
);
1206 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1208 if (BUFFER_OBJFWDP (valcontents
))
1210 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1211 int idx
= PER_BUFFER_IDX (offset
);
1214 && !let_shadows_buffer_binding_p (symbol
))
1215 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1217 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1218 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1220 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1221 if (XSYMBOL (symbol
)->indirect_variable
)
1222 symbol
= indirect_variable (symbol
);
1224 /* What binding is loaded right now? */
1225 current_alist_element
1226 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1228 /* If the current buffer is not the buffer whose binding is
1229 loaded, or if there may be frame-local bindings and the frame
1230 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1231 the default binding is loaded, the loaded binding may be the
1233 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1234 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1235 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1236 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1237 || (BUFFER_LOCAL_VALUEP (valcontents
)
1238 && EQ (XCAR (current_alist_element
),
1239 current_alist_element
)))
1241 /* The currently loaded binding is not necessarily valid.
1242 We need to unload it, and choose a new binding. */
1244 /* Write out `realvalue' to the old loaded binding. */
1245 Fsetcdr (current_alist_element
,
1246 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1248 /* Find the new binding. */
1249 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1250 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1251 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1255 /* This buffer still sees the default value. */
1257 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1258 or if this is `let' rather than `set',
1259 make CURRENT-ALIST-ELEMENT point to itself,
1260 indicating that we're seeing the default value.
1261 Likewise if the variable has been let-bound
1262 in the current buffer. */
1263 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1264 || let_shadows_buffer_binding_p (symbol
))
1266 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1268 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1269 tem1
= Fassq (symbol
,
1270 XFRAME (selected_frame
)->param_alist
);
1273 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1275 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1277 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1278 and we're not within a let that was made for this buffer,
1279 create a new buffer-local binding for the variable.
1280 That means, give this buffer a new assoc for a local value
1281 and load that binding. */
1284 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1285 buf
->local_var_alist
1286 = Fcons (tem1
, buf
->local_var_alist
);
1290 /* Record which binding is now loaded. */
1291 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1294 /* Set `buffer' and `frame' slots for the binding now loaded. */
1295 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1296 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1298 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1301 /* If storing void (making the symbol void), forward only through
1302 buffer-local indicator, not through Lisp_Objfwd, etc. */
1304 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1306 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1308 /* If we just set a variable whose current binding is frame-local,
1309 store the new value in the frame parameter too. */
1311 if (BUFFER_LOCAL_VALUEP (valcontents
)
1312 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1314 /* What binding is loaded right now? */
1315 current_alist_element
1316 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1318 /* If the current buffer is not the buffer whose binding is
1319 loaded, or if there may be frame-local bindings and the frame
1320 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1321 the default binding is loaded, the loaded binding may be the
1323 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1324 XSETCDR (current_alist_element
, newval
);
1330 /* Access or set a buffer-local symbol's default value. */
1332 /* Return the default value of SYMBOL, but don't check for voidness.
1333 Return Qunbound if it is void. */
1336 default_value (symbol
)
1339 register Lisp_Object valcontents
;
1341 CHECK_SYMBOL (symbol
);
1342 valcontents
= SYMBOL_VALUE (symbol
);
1344 /* For a built-in buffer-local variable, get the default value
1345 rather than letting do_symval_forwarding get the current value. */
1346 if (BUFFER_OBJFWDP (valcontents
))
1348 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1349 if (PER_BUFFER_IDX (offset
) != 0)
1350 return PER_BUFFER_DEFAULT (offset
);
1353 /* Handle user-created local variables. */
1354 if (BUFFER_LOCAL_VALUEP (valcontents
)
1355 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1357 /* If var is set up for a buffer that lacks a local value for it,
1358 the current value is nominally the default value.
1359 But the `realvalue' slot may be more up to date, since
1360 ordinary setq stores just that slot. So use that. */
1361 Lisp_Object current_alist_element
, alist_element_car
;
1362 current_alist_element
1363 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1364 alist_element_car
= XCAR (current_alist_element
);
1365 if (EQ (alist_element_car
, current_alist_element
))
1366 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1368 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1370 /* For other variables, get the current value. */
1371 return do_symval_forwarding (valcontents
);
1374 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1375 doc
: /* Return t if SYMBOL has a non-void default value.
1376 This is the value that is seen in buffers that do not have their own values
1377 for this variable. */)
1381 register Lisp_Object value
;
1383 value
= default_value (symbol
);
1384 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1387 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1388 doc
: /* Return SYMBOL's default value.
1389 This is the value that is seen in buffers that do not have their own values
1390 for this variable. The default value is meaningful for variables with
1391 local bindings in certain buffers. */)
1395 register Lisp_Object value
;
1397 value
= default_value (symbol
);
1398 if (!EQ (value
, Qunbound
))
1401 xsignal1 (Qvoid_variable
, symbol
);
1404 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1405 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1406 The default value is seen in buffers that do not have their own values
1407 for this variable. */)
1409 Lisp_Object symbol
, value
;
1411 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1413 CHECK_SYMBOL (symbol
);
1414 valcontents
= SYMBOL_VALUE (symbol
);
1416 /* Handle variables like case-fold-search that have special slots
1417 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1419 if (BUFFER_OBJFWDP (valcontents
))
1421 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1422 int idx
= PER_BUFFER_IDX (offset
);
1424 PER_BUFFER_DEFAULT (offset
) = value
;
1426 /* If this variable is not always local in all buffers,
1427 set it in the buffers that don't nominally have a local value. */
1432 for (b
= all_buffers
; b
; b
= b
->next
)
1433 if (!PER_BUFFER_VALUE_P (b
, idx
))
1434 PER_BUFFER_VALUE (b
, offset
) = value
;
1439 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1440 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1441 return Fset (symbol
, value
);
1443 /* Store new value into the DEFAULT-VALUE slot. */
1444 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1446 /* If the default binding is now loaded, set the REALVALUE slot too. */
1447 current_alist_element
1448 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1449 alist_element_buffer
= Fcar (current_alist_element
);
1450 if (EQ (alist_element_buffer
, current_alist_element
))
1451 store_symval_forwarding (symbol
,
1452 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1458 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1459 doc
: /* Set the default value of variable VAR to VALUE.
1460 VAR, the variable name, is literal (not evaluated);
1461 VALUE is an expression: it is evaluated and its value returned.
1462 The default value of a variable is seen in buffers
1463 that do not have their own values for the variable.
1465 More generally, you can use multiple variables and values, as in
1466 (setq-default VAR VALUE VAR VALUE...)
1467 This sets each VAR's default value to the corresponding VALUE.
1468 The VALUE for the Nth VAR can refer to the new default values
1470 usage: (setq-default [VAR VALUE]...) */)
1474 register Lisp_Object args_left
;
1475 register Lisp_Object val
, symbol
;
1476 struct gcpro gcpro1
;
1486 val
= Feval (Fcar (Fcdr (args_left
)));
1487 symbol
= XCAR (args_left
);
1488 Fset_default (symbol
, val
);
1489 args_left
= Fcdr (XCDR (args_left
));
1491 while (!NILP (args_left
));
1497 /* Lisp functions for creating and removing buffer-local variables. */
1499 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1500 1, 1, "vMake Variable Buffer Local: ",
1501 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1502 At any time, the value for the current buffer is in effect,
1503 unless the variable has never been set in this buffer,
1504 in which case the default value is in effect.
1505 Note that binding the variable with `let', or setting it while
1506 a `let'-style binding made in this buffer is in effect,
1507 does not make the variable buffer-local. Return VARIABLE.
1509 In most cases it is better to use `make-local-variable',
1510 which makes a variable local in just one buffer.
1512 The function `default-value' gets the default value and `set-default' sets it. */)
1514 register Lisp_Object variable
;
1516 register Lisp_Object tem
, valcontents
, newval
;
1518 CHECK_SYMBOL (variable
);
1519 variable
= indirect_variable (variable
);
1521 valcontents
= SYMBOL_VALUE (variable
);
1522 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1523 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1525 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1527 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1529 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1532 if (EQ (valcontents
, Qunbound
))
1533 SET_SYMBOL_VALUE (variable
, Qnil
);
1534 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1536 newval
= allocate_misc ();
1537 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1538 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1539 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1540 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1541 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1542 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1543 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1544 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1545 SET_SYMBOL_VALUE (variable
, newval
);
1549 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1550 1, 1, "vMake Local Variable: ",
1551 doc
: /* Make VARIABLE have a separate value in the current buffer.
1552 Other buffers will continue to share a common default value.
1553 \(The buffer-local value of VARIABLE starts out as the same value
1554 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1557 If the variable is already arranged to become local when set,
1558 this function causes a local value to exist for this buffer,
1559 just as setting the variable would do.
1561 This function returns VARIABLE, and therefore
1562 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1565 See also `make-variable-buffer-local'.
1567 Do not use `make-local-variable' to make a hook variable buffer-local.
1568 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1570 register Lisp_Object variable
;
1572 register Lisp_Object tem
, valcontents
;
1574 CHECK_SYMBOL (variable
);
1575 variable
= indirect_variable (variable
);
1577 valcontents
= SYMBOL_VALUE (variable
);
1578 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1579 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1581 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1583 tem
= Fboundp (variable
);
1585 /* Make sure the symbol has a local value in this particular buffer,
1586 by setting it to the same value it already has. */
1587 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1590 /* Make sure symbol is set up to hold per-buffer values. */
1591 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1594 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1596 newval
= allocate_misc ();
1597 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1598 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1599 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1600 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1601 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1602 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1603 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1604 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1605 SET_SYMBOL_VALUE (variable
, newval
);
1607 /* Make sure this buffer has its own value of symbol. */
1608 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1611 /* Swap out any local binding for some other buffer, and make
1612 sure the current value is permanently recorded, if it's the
1614 find_symbol_value (variable
);
1616 current_buffer
->local_var_alist
1617 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1618 current_buffer
->local_var_alist
);
1620 /* Make sure symbol does not think it is set up for this buffer;
1621 force it to look once again for this buffer's value. */
1623 Lisp_Object
*pvalbuf
;
1625 valcontents
= SYMBOL_VALUE (variable
);
1627 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1628 if (current_buffer
== XBUFFER (*pvalbuf
))
1630 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1634 /* If the symbol forwards into a C variable, then load the binding
1635 for this buffer now. If C code modifies the variable before we
1636 load the binding in, then that new value will clobber the default
1637 binding the next time we unload it. */
1638 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1639 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1640 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1645 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1646 1, 1, "vKill Local Variable: ",
1647 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1648 From now on the default value will apply in this buffer. Return VARIABLE. */)
1650 register Lisp_Object variable
;
1652 register Lisp_Object tem
, valcontents
;
1654 CHECK_SYMBOL (variable
);
1655 variable
= indirect_variable (variable
);
1657 valcontents
= SYMBOL_VALUE (variable
);
1659 if (BUFFER_OBJFWDP (valcontents
))
1661 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1662 int idx
= PER_BUFFER_IDX (offset
);
1666 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1667 PER_BUFFER_VALUE (current_buffer
, offset
)
1668 = PER_BUFFER_DEFAULT (offset
);
1673 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1674 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1677 /* Get rid of this buffer's alist element, if any. */
1679 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1681 current_buffer
->local_var_alist
1682 = Fdelq (tem
, current_buffer
->local_var_alist
);
1684 /* If the symbol is set up with the current buffer's binding
1685 loaded, recompute its value. We have to do it now, or else
1686 forwarded objects won't work right. */
1688 Lisp_Object
*pvalbuf
, buf
;
1689 valcontents
= SYMBOL_VALUE (variable
);
1690 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1691 XSETBUFFER (buf
, current_buffer
);
1692 if (EQ (buf
, *pvalbuf
))
1695 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1696 find_symbol_value (variable
);
1703 /* Lisp functions for creating and removing buffer-local variables. */
1705 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1706 1, 1, "vMake Variable Frame Local: ",
1707 doc
: /* Enable VARIABLE to have frame-local bindings.
1708 This does not create any frame-local bindings for VARIABLE,
1709 it just makes them possible.
1711 A frame-local binding is actually a frame parameter value.
1712 If a frame F has a value for the frame parameter named VARIABLE,
1713 that also acts as a frame-local binding for VARIABLE in F--
1714 provided this function has been called to enable VARIABLE
1715 to have frame-local bindings at all.
1717 The only way to create a frame-local binding for VARIABLE in a frame
1718 is to set the VARIABLE frame parameter of that frame. See
1719 `modify-frame-parameters' for how to set frame parameters.
1721 Buffer-local bindings take precedence over frame-local bindings. */)
1723 register Lisp_Object variable
;
1725 register Lisp_Object tem
, valcontents
, newval
;
1727 CHECK_SYMBOL (variable
);
1728 variable
= indirect_variable (variable
);
1730 valcontents
= SYMBOL_VALUE (variable
);
1731 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1732 || BUFFER_OBJFWDP (valcontents
))
1733 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1735 if (BUFFER_LOCAL_VALUEP (valcontents
)
1736 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1738 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1742 if (EQ (valcontents
, Qunbound
))
1743 SET_SYMBOL_VALUE (variable
, Qnil
);
1744 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1746 newval
= allocate_misc ();
1747 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1748 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1749 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1750 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1751 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1752 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1753 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1754 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1755 SET_SYMBOL_VALUE (variable
, newval
);
1759 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1761 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1762 BUFFER defaults to the current buffer. */)
1764 register Lisp_Object variable
, buffer
;
1766 Lisp_Object valcontents
;
1767 register struct buffer
*buf
;
1770 buf
= current_buffer
;
1773 CHECK_BUFFER (buffer
);
1774 buf
= XBUFFER (buffer
);
1777 CHECK_SYMBOL (variable
);
1778 variable
= indirect_variable (variable
);
1780 valcontents
= SYMBOL_VALUE (variable
);
1781 if (BUFFER_LOCAL_VALUEP (valcontents
)
1782 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1784 Lisp_Object tail
, elt
;
1786 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1789 if (EQ (variable
, XCAR (elt
)))
1793 if (BUFFER_OBJFWDP (valcontents
))
1795 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1796 int idx
= PER_BUFFER_IDX (offset
);
1797 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1803 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1805 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1806 More precisely, this means that setting the variable \(with `set' or`setq'),
1807 while it does not have a `let'-style binding that was made in BUFFER,
1808 will produce a buffer local binding. See Info node
1809 `(elisp)Creating Buffer-Local'.
1810 BUFFER defaults to the current buffer. */)
1812 register Lisp_Object variable
, buffer
;
1814 Lisp_Object valcontents
;
1815 register struct buffer
*buf
;
1818 buf
= current_buffer
;
1821 CHECK_BUFFER (buffer
);
1822 buf
= XBUFFER (buffer
);
1825 CHECK_SYMBOL (variable
);
1826 variable
= indirect_variable (variable
);
1828 valcontents
= SYMBOL_VALUE (variable
);
1830 /* This means that make-variable-buffer-local was done. */
1831 if (BUFFER_LOCAL_VALUEP (valcontents
))
1833 /* All these slots become local if they are set. */
1834 if (BUFFER_OBJFWDP (valcontents
))
1836 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1838 Lisp_Object tail
, elt
;
1839 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1842 if (EQ (variable
, XCAR (elt
)))
1849 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1851 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1852 If the current binding is buffer-local, the value is the current buffer.
1853 If the current binding is frame-local, the value is the selected frame.
1854 If the current binding is global (the default), the value is nil. */)
1856 register Lisp_Object variable
;
1858 Lisp_Object valcontents
;
1860 CHECK_SYMBOL (variable
);
1861 variable
= indirect_variable (variable
);
1863 /* Make sure the current binding is actually swapped in. */
1864 find_symbol_value (variable
);
1866 valcontents
= XSYMBOL (variable
)->value
;
1868 if (BUFFER_LOCAL_VALUEP (valcontents
)
1869 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1870 || BUFFER_OBJFWDP (valcontents
))
1872 /* For a local variable, record both the symbol and which
1873 buffer's or frame's value we are saving. */
1874 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1875 return Fcurrent_buffer ();
1876 else if (!BUFFER_OBJFWDP (valcontents
)
1877 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1878 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1884 /* This code is disabled now that we use the selected frame to return
1885 keyboard-local-values. */
1887 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1889 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1890 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1891 If SYMBOL is not a terminal-local variable, then return its normal
1892 value, like `symbol-value'.
1894 TERMINAL may be a terminal id, a frame, or nil (meaning the
1895 selected frame's terminal device). */)
1898 Lisp_Object terminal
;
1901 struct terminal
*t
= get_terminal (terminal
, 1);
1902 push_kboard (t
->kboard
);
1903 result
= Fsymbol_value (symbol
);
1908 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1909 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1910 If VARIABLE is not a terminal-local variable, then set its normal
1911 binding, like `set'.
1913 TERMINAL may be a terminal id, a frame, or nil (meaning the
1914 selected frame's terminal device). */)
1915 (symbol
, terminal
, value
)
1917 Lisp_Object terminal
;
1921 struct terminal
*t
= get_terminal (terminal
, 1);
1922 push_kboard (d
->kboard
);
1923 result
= Fset (symbol
, value
);
1929 /* Find the function at the end of a chain of symbol function indirections. */
1931 /* If OBJECT is a symbol, find the end of its function chain and
1932 return the value found there. If OBJECT is not a symbol, just
1933 return it. If there is a cycle in the function chain, signal a
1934 cyclic-function-indirection error.
1936 This is like Findirect_function, except that it doesn't signal an
1937 error if the chain ends up unbound. */
1939 indirect_function (object
)
1940 register Lisp_Object object
;
1942 Lisp_Object tortoise
, hare
;
1944 hare
= tortoise
= object
;
1948 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1950 hare
= XSYMBOL (hare
)->function
;
1951 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1953 hare
= XSYMBOL (hare
)->function
;
1955 tortoise
= XSYMBOL (tortoise
)->function
;
1957 if (EQ (hare
, tortoise
))
1958 xsignal1 (Qcyclic_function_indirection
, object
);
1964 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1965 doc
: /* Return the function at the end of OBJECT's function chain.
1966 If OBJECT is not a symbol, just return it. Otherwise, follow all
1967 function indirections to find the final function binding and return it.
1968 If the final symbol in the chain is unbound, signal a void-function error.
1969 Optional arg NOERROR non-nil means to return nil instead of signalling.
1970 Signal a cyclic-function-indirection error if there is a loop in the
1971 function chain of symbols. */)
1973 register Lisp_Object object
;
1974 Lisp_Object noerror
;
1978 /* Optimize for no indirection. */
1980 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1981 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1982 result
= indirect_function (result
);
1983 if (!EQ (result
, Qunbound
))
1987 xsignal1 (Qvoid_function
, object
);
1992 /* Extract and set vector and string elements */
1994 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1995 doc
: /* Return the element of ARRAY at index IDX.
1996 ARRAY may be a vector, a string, a char-table, a bool-vector,
1997 or a byte-code object. IDX starts at 0. */)
1999 register Lisp_Object array
;
2002 register int idxval
;
2005 idxval
= XINT (idx
);
2006 if (STRINGP (array
))
2010 if (idxval
< 0 || idxval
>= SCHARS (array
))
2011 args_out_of_range (array
, idx
);
2012 if (! STRING_MULTIBYTE (array
))
2013 return make_number ((unsigned char) SREF (array
, idxval
));
2014 idxval_byte
= string_char_to_byte (array
, idxval
);
2016 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2017 SBYTES (array
) - idxval_byte
);
2018 return make_number (c
);
2020 else if (BOOL_VECTOR_P (array
))
2024 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2025 args_out_of_range (array
, idx
);
2027 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2028 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2030 else if (CHAR_TABLE_P (array
))
2037 args_out_of_range (array
, idx
);
2038 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2040 if (! SINGLE_BYTE_CHAR_P (idxval
))
2041 args_out_of_range (array
, idx
);
2042 /* For ASCII and 8-bit European characters, the element is
2043 stored in the top table. */
2044 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2048 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2049 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2050 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2051 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2054 val
= XCHAR_TABLE (array
)->defalt
;
2055 while (NILP (val
)) /* Follow parents until we find some value. */
2057 array
= XCHAR_TABLE (array
)->parent
;
2060 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2062 val
= XCHAR_TABLE (array
)->defalt
;
2069 Lisp_Object sub_table
;
2070 Lisp_Object current_default
;
2072 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2073 if (code
[1] < 32) code
[1] = -1;
2074 else if (code
[2] < 32) code
[2] = -1;
2076 /* Here, the possible range of CODE[0] (== charset ID) is
2077 128..MAX_CHARSET. Since the top level char table contains
2078 data for multibyte characters after 256th element, we must
2079 increment CODE[0] by 128 to get a correct index. */
2081 code
[3] = -1; /* anchor */
2083 try_parent_char_table
:
2084 current_default
= XCHAR_TABLE (array
)->defalt
;
2086 for (i
= 0; code
[i
] >= 0; i
++)
2088 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2089 if (SUB_CHAR_TABLE_P (val
))
2092 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2093 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2098 val
= current_default
;
2101 array
= XCHAR_TABLE (array
)->parent
;
2103 goto try_parent_char_table
;
2108 /* Reaching here means IDXVAL is a generic character in
2109 which each character or a group has independent value.
2110 Essentially it's nonsense to get a value for such a
2111 generic character, but for backward compatibility, we try
2112 the default value and parent. */
2113 val
= current_default
;
2116 array
= XCHAR_TABLE (array
)->parent
;
2118 goto try_parent_char_table
;
2126 if (VECTORP (array
))
2127 size
= XVECTOR (array
)->size
;
2128 else if (COMPILEDP (array
))
2129 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2131 wrong_type_argument (Qarrayp
, array
);
2133 if (idxval
< 0 || idxval
>= size
)
2134 args_out_of_range (array
, idx
);
2135 return XVECTOR (array
)->contents
[idxval
];
2139 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2140 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2141 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2142 bool-vector. IDX starts at 0. */)
2143 (array
, idx
, newelt
)
2144 register Lisp_Object array
;
2145 Lisp_Object idx
, newelt
;
2147 register int idxval
;
2150 idxval
= XINT (idx
);
2151 CHECK_ARRAY (array
, Qarrayp
);
2152 CHECK_IMPURE (array
);
2154 if (VECTORP (array
))
2156 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2157 args_out_of_range (array
, idx
);
2158 XVECTOR (array
)->contents
[idxval
] = newelt
;
2160 else if (BOOL_VECTOR_P (array
))
2164 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2165 args_out_of_range (array
, idx
);
2167 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2169 if (! NILP (newelt
))
2170 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2172 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2173 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2175 else if (CHAR_TABLE_P (array
))
2178 args_out_of_range (array
, idx
);
2179 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2181 if (! SINGLE_BYTE_CHAR_P (idxval
))
2182 args_out_of_range (array
, idx
);
2183 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2190 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2191 if (code
[1] < 32) code
[1] = -1;
2192 else if (code
[2] < 32) code
[2] = -1;
2194 /* See the comment of the corresponding part in Faref. */
2196 code
[3] = -1; /* anchor */
2197 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2199 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2200 if (SUB_CHAR_TABLE_P (val
))
2206 /* VAL is a leaf. Create a sub char table with the
2207 initial value VAL and look into it. */
2209 temp
= make_sub_char_table (val
);
2210 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2214 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2217 else if (STRING_MULTIBYTE (array
))
2219 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2220 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2222 if (idxval
< 0 || idxval
>= SCHARS (array
))
2223 args_out_of_range (array
, idx
);
2224 CHECK_NUMBER (newelt
);
2226 nbytes
= SBYTES (array
);
2228 idxval_byte
= string_char_to_byte (array
, idxval
);
2229 p1
= SDATA (array
) + idxval_byte
;
2230 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2231 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2232 if (prev_bytes
!= new_bytes
)
2234 /* We must relocate the string data. */
2235 int nchars
= SCHARS (array
);
2239 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2240 bcopy (SDATA (array
), str
, nbytes
);
2241 allocate_string_data (XSTRING (array
), nchars
,
2242 nbytes
+ new_bytes
- prev_bytes
);
2243 bcopy (str
, SDATA (array
), idxval_byte
);
2244 p1
= SDATA (array
) + idxval_byte
;
2245 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2246 nbytes
- (idxval_byte
+ prev_bytes
));
2248 clear_string_char_byte_cache ();
2255 if (idxval
< 0 || idxval
>= SCHARS (array
))
2256 args_out_of_range (array
, idx
);
2257 CHECK_NUMBER (newelt
);
2259 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2260 SSET (array
, idxval
, XINT (newelt
));
2263 /* We must relocate the string data while converting it to
2265 int idxval_byte
, prev_bytes
, new_bytes
;
2266 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2267 unsigned char *origstr
= SDATA (array
), *str
;
2271 nchars
= SCHARS (array
);
2272 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2273 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2275 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2276 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2277 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2279 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2280 allocate_string_data (XSTRING (array
), nchars
,
2281 nbytes
+ new_bytes
- prev_bytes
);
2282 bcopy (str
, SDATA (array
), idxval_byte
);
2283 p1
= SDATA (array
) + idxval_byte
;
2286 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2287 nbytes
- (idxval_byte
+ prev_bytes
));
2289 clear_string_char_byte_cache ();
2296 /* Arithmetic functions */
2298 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2301 arithcompare (num1
, num2
, comparison
)
2302 Lisp_Object num1
, num2
;
2303 enum comparison comparison
;
2305 double f1
= 0, f2
= 0;
2308 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2309 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2311 if (FLOATP (num1
) || FLOATP (num2
))
2314 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2315 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2321 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2326 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2331 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2336 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2341 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2346 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2355 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2356 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2358 register Lisp_Object num1
, num2
;
2360 return arithcompare (num1
, num2
, equal
);
2363 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2364 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2366 register Lisp_Object num1
, num2
;
2368 return arithcompare (num1
, num2
, less
);
2371 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2372 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2374 register Lisp_Object num1
, num2
;
2376 return arithcompare (num1
, num2
, grtr
);
2379 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2380 doc
: /* Return t if first arg is less than or equal to second arg.
2381 Both must be numbers or markers. */)
2383 register Lisp_Object num1
, num2
;
2385 return arithcompare (num1
, num2
, less_or_equal
);
2388 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2389 doc
: /* Return t if first arg is greater than or equal to second arg.
2390 Both must be numbers or markers. */)
2392 register Lisp_Object num1
, num2
;
2394 return arithcompare (num1
, num2
, grtr_or_equal
);
2397 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2398 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2400 register Lisp_Object num1
, num2
;
2402 return arithcompare (num1
, num2
, notequal
);
2405 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2406 doc
: /* Return t if NUMBER is zero. */)
2408 register Lisp_Object number
;
2410 CHECK_NUMBER_OR_FLOAT (number
);
2412 if (FLOATP (number
))
2414 if (XFLOAT_DATA (number
) == 0.0)
2424 /* Convert between long values and pairs of Lisp integers.
2425 Note that long_to_cons returns a single Lisp integer
2426 when the value fits in one. */
2432 unsigned long top
= i
>> 16;
2433 unsigned int bot
= i
& 0xFFFF;
2435 return make_number (bot
);
2436 if (top
== (unsigned long)-1 >> 16)
2437 return Fcons (make_number (-1), make_number (bot
));
2438 return Fcons (make_number (top
), make_number (bot
));
2445 Lisp_Object top
, bot
;
2452 return ((XINT (top
) << 16) | XINT (bot
));
2455 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2456 doc
: /* Return the decimal representation of NUMBER as a string.
2457 Uses a minus sign if negative.
2458 NUMBER may be an integer or a floating point number. */)
2462 char buffer
[VALBITS
];
2464 CHECK_NUMBER_OR_FLOAT (number
);
2466 if (FLOATP (number
))
2468 char pigbuf
[350]; /* see comments in float_to_string */
2470 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2471 return build_string (pigbuf
);
2474 if (sizeof (int) == sizeof (EMACS_INT
))
2475 sprintf (buffer
, "%d", XINT (number
));
2476 else if (sizeof (long) == sizeof (EMACS_INT
))
2477 sprintf (buffer
, "%ld", (long) XINT (number
));
2480 return build_string (buffer
);
2484 digit_to_number (character
, base
)
2485 int character
, base
;
2489 if (character
>= '0' && character
<= '9')
2490 digit
= character
- '0';
2491 else if (character
>= 'a' && character
<= 'z')
2492 digit
= character
- 'a' + 10;
2493 else if (character
>= 'A' && character
<= 'Z')
2494 digit
= character
- 'A' + 10;
2504 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2505 doc
: /* Parse STRING as a decimal number and return the number.
2506 This parses both integers and floating point numbers.
2507 It ignores leading spaces and tabs.
2509 If BASE, interpret STRING as a number in that base. If BASE isn't
2510 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2511 If the base used is not 10, floating point is not recognized. */)
2513 register Lisp_Object string
, base
;
2515 register unsigned char *p
;
2520 CHECK_STRING (string
);
2526 CHECK_NUMBER (base
);
2528 if (b
< 2 || b
> 16)
2529 xsignal1 (Qargs_out_of_range
, base
);
2532 /* Skip any whitespace at the front of the number. Some versions of
2533 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2535 while (*p
== ' ' || *p
== '\t')
2546 if (isfloat_string (p
) && b
== 10)
2547 val
= make_float (sign
* atof (p
));
2554 int digit
= digit_to_number (*p
++, b
);
2560 val
= make_fixnum_or_float (sign
* v
);
2580 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2581 int, Lisp_Object
*));
2582 extern Lisp_Object
fmod_float ();
2585 arith_driver (code
, nargs
, args
)
2588 register Lisp_Object
*args
;
2590 register Lisp_Object val
;
2591 register int argnum
;
2592 register EMACS_INT accum
= 0;
2593 register EMACS_INT next
;
2595 switch (SWITCH_ENUM_CAST (code
))
2613 for (argnum
= 0; argnum
< nargs
; argnum
++)
2615 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2617 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2620 return float_arith_driver ((double) accum
, argnum
, code
,
2623 next
= XINT (args
[argnum
]);
2624 switch (SWITCH_ENUM_CAST (code
))
2630 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2641 xsignal0 (Qarith_error
);
2655 if (!argnum
|| next
> accum
)
2659 if (!argnum
|| next
< accum
)
2665 XSETINT (val
, accum
);
2670 #define isnan(x) ((x) != (x))
2673 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2675 register int argnum
;
2678 register Lisp_Object
*args
;
2680 register Lisp_Object val
;
2683 for (; argnum
< nargs
; argnum
++)
2685 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2686 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2690 next
= XFLOAT_DATA (val
);
2694 args
[argnum
] = val
; /* runs into a compiler bug. */
2695 next
= XINT (args
[argnum
]);
2697 switch (SWITCH_ENUM_CAST (code
))
2703 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2713 if (! IEEE_FLOATING_POINT
&& next
== 0)
2714 xsignal0 (Qarith_error
);
2721 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2723 if (!argnum
|| isnan (next
) || next
> accum
)
2727 if (!argnum
|| isnan (next
) || next
< accum
)
2733 return make_float (accum
);
2737 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2738 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2739 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2744 return arith_driver (Aadd
, nargs
, args
);
2747 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2748 doc
: /* Negate number or subtract numbers or markers and return the result.
2749 With one arg, negates it. With more than one arg,
2750 subtracts all but the first from the first.
2751 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2756 return arith_driver (Asub
, nargs
, args
);
2759 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2760 doc
: /* Return product of any number of arguments, which are numbers or markers.
2761 usage: (* &rest NUMBERS-OR-MARKERS) */)
2766 return arith_driver (Amult
, nargs
, args
);
2769 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2770 doc
: /* Return first argument divided by all the remaining arguments.
2771 The arguments must be numbers or markers.
2772 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2778 for (argnum
= 2; argnum
< nargs
; argnum
++)
2779 if (FLOATP (args
[argnum
]))
2780 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2781 return arith_driver (Adiv
, nargs
, args
);
2784 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2785 doc
: /* Return remainder of X divided by Y.
2786 Both must be integers or markers. */)
2788 register Lisp_Object x
, y
;
2792 CHECK_NUMBER_COERCE_MARKER (x
);
2793 CHECK_NUMBER_COERCE_MARKER (y
);
2795 if (XFASTINT (y
) == 0)
2796 xsignal0 (Qarith_error
);
2798 XSETINT (val
, XINT (x
) % XINT (y
));
2812 /* If the magnitude of the result exceeds that of the divisor, or
2813 the sign of the result does not agree with that of the dividend,
2814 iterate with the reduced value. This does not yield a
2815 particularly accurate result, but at least it will be in the
2816 range promised by fmod. */
2818 r
-= f2
* floor (r
/ f2
);
2819 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2823 #endif /* ! HAVE_FMOD */
2825 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2826 doc
: /* Return X modulo Y.
2827 The result falls between zero (inclusive) and Y (exclusive).
2828 Both X and Y must be numbers or markers. */)
2830 register Lisp_Object x
, y
;
2835 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2836 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2838 if (FLOATP (x
) || FLOATP (y
))
2839 return fmod_float (x
, y
);
2845 xsignal0 (Qarith_error
);
2849 /* If the "remainder" comes out with the wrong sign, fix it. */
2850 if (i2
< 0 ? i1
> 0 : i1
< 0)
2857 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2858 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2859 The value is always a number; markers are converted to numbers.
2860 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2865 return arith_driver (Amax
, nargs
, args
);
2868 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2869 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2870 The value is always a number; markers are converted to numbers.
2871 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2876 return arith_driver (Amin
, nargs
, args
);
2879 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2880 doc
: /* Return bitwise-and of all the arguments.
2881 Arguments may be integers, or markers converted to integers.
2882 usage: (logand &rest INTS-OR-MARKERS) */)
2887 return arith_driver (Alogand
, nargs
, args
);
2890 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2891 doc
: /* Return bitwise-or of all the arguments.
2892 Arguments may be integers, or markers converted to integers.
2893 usage: (logior &rest INTS-OR-MARKERS) */)
2898 return arith_driver (Alogior
, nargs
, args
);
2901 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2902 doc
: /* Return bitwise-exclusive-or of all the arguments.
2903 Arguments may be integers, or markers converted to integers.
2904 usage: (logxor &rest INTS-OR-MARKERS) */)
2909 return arith_driver (Alogxor
, nargs
, args
);
2912 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2913 doc
: /* Return VALUE with its bits shifted left by COUNT.
2914 If COUNT is negative, shifting is actually to the right.
2915 In this case, the sign bit is duplicated. */)
2917 register Lisp_Object value
, count
;
2919 register Lisp_Object val
;
2921 CHECK_NUMBER (value
);
2922 CHECK_NUMBER (count
);
2924 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2926 else if (XINT (count
) > 0)
2927 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2928 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2929 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2931 XSETINT (val
, XINT (value
) >> -XINT (count
));
2935 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2936 doc
: /* Return VALUE with its bits shifted left by COUNT.
2937 If COUNT is negative, shifting is actually to the right.
2938 In this case, zeros are shifted in on the left. */)
2940 register Lisp_Object value
, count
;
2942 register Lisp_Object val
;
2944 CHECK_NUMBER (value
);
2945 CHECK_NUMBER (count
);
2947 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2949 else if (XINT (count
) > 0)
2950 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2951 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2954 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2958 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2959 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2960 Markers are converted to integers. */)
2962 register Lisp_Object number
;
2964 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2966 if (FLOATP (number
))
2967 return (make_float (1.0 + XFLOAT_DATA (number
)));
2969 XSETINT (number
, XINT (number
) + 1);
2973 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2974 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2975 Markers are converted to integers. */)
2977 register Lisp_Object number
;
2979 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2981 if (FLOATP (number
))
2982 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2984 XSETINT (number
, XINT (number
) - 1);
2988 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2989 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2991 register Lisp_Object number
;
2993 CHECK_NUMBER (number
);
2994 XSETINT (number
, ~XINT (number
));
2998 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2999 doc
: /* Return the byteorder for the machine.
3000 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3001 lowercase l) for small endian machines. */)
3004 unsigned i
= 0x04030201;
3005 int order
= *(char *)&i
== 1 ? 108 : 66;
3007 return make_number (order
);
3015 Lisp_Object error_tail
, arith_tail
;
3017 Qquote
= intern ("quote");
3018 Qlambda
= intern ("lambda");
3019 Qsubr
= intern ("subr");
3020 Qerror_conditions
= intern ("error-conditions");
3021 Qerror_message
= intern ("error-message");
3022 Qtop_level
= intern ("top-level");
3024 Qerror
= intern ("error");
3025 Qquit
= intern ("quit");
3026 Qwrong_type_argument
= intern ("wrong-type-argument");
3027 Qargs_out_of_range
= intern ("args-out-of-range");
3028 Qvoid_function
= intern ("void-function");
3029 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3030 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3031 Qvoid_variable
= intern ("void-variable");
3032 Qsetting_constant
= intern ("setting-constant");
3033 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3035 Qinvalid_function
= intern ("invalid-function");
3036 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3037 Qno_catch
= intern ("no-catch");
3038 Qend_of_file
= intern ("end-of-file");
3039 Qarith_error
= intern ("arith-error");
3040 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3041 Qend_of_buffer
= intern ("end-of-buffer");
3042 Qbuffer_read_only
= intern ("buffer-read-only");
3043 Qtext_read_only
= intern ("text-read-only");
3044 Qmark_inactive
= intern ("mark-inactive");
3046 Qlistp
= intern ("listp");
3047 Qconsp
= intern ("consp");
3048 Qsymbolp
= intern ("symbolp");
3049 Qkeywordp
= intern ("keywordp");
3050 Qintegerp
= intern ("integerp");
3051 Qnatnump
= intern ("natnump");
3052 Qwholenump
= intern ("wholenump");
3053 Qstringp
= intern ("stringp");
3054 Qarrayp
= intern ("arrayp");
3055 Qsequencep
= intern ("sequencep");
3056 Qbufferp
= intern ("bufferp");
3057 Qvectorp
= intern ("vectorp");
3058 Qchar_or_string_p
= intern ("char-or-string-p");
3059 Qmarkerp
= intern ("markerp");
3060 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3061 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3062 Qboundp
= intern ("boundp");
3063 Qfboundp
= intern ("fboundp");
3065 Qfloatp
= intern ("floatp");
3066 Qnumberp
= intern ("numberp");
3067 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3069 Qchar_table_p
= intern ("char-table-p");
3070 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3072 Qsubrp
= intern ("subrp");
3073 Qunevalled
= intern ("unevalled");
3074 Qmany
= intern ("many");
3076 Qcdr
= intern ("cdr");
3078 /* Handle automatic advice activation */
3079 Qad_advice_info
= intern ("ad-advice-info");
3080 Qad_activate_internal
= intern ("ad-activate-internal");
3082 error_tail
= Fcons (Qerror
, Qnil
);
3084 /* ERROR is used as a signaler for random errors for which nothing else is right */
3086 Fput (Qerror
, Qerror_conditions
,
3088 Fput (Qerror
, Qerror_message
,
3089 build_string ("error"));
3091 Fput (Qquit
, Qerror_conditions
,
3092 Fcons (Qquit
, Qnil
));
3093 Fput (Qquit
, Qerror_message
,
3094 build_string ("Quit"));
3096 Fput (Qwrong_type_argument
, Qerror_conditions
,
3097 Fcons (Qwrong_type_argument
, error_tail
));
3098 Fput (Qwrong_type_argument
, Qerror_message
,
3099 build_string ("Wrong type argument"));
3101 Fput (Qargs_out_of_range
, Qerror_conditions
,
3102 Fcons (Qargs_out_of_range
, error_tail
));
3103 Fput (Qargs_out_of_range
, Qerror_message
,
3104 build_string ("Args out of range"));
3106 Fput (Qvoid_function
, Qerror_conditions
,
3107 Fcons (Qvoid_function
, error_tail
));
3108 Fput (Qvoid_function
, Qerror_message
,
3109 build_string ("Symbol's function definition is void"));
3111 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3112 Fcons (Qcyclic_function_indirection
, error_tail
));
3113 Fput (Qcyclic_function_indirection
, Qerror_message
,
3114 build_string ("Symbol's chain of function indirections contains a loop"));
3116 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3117 Fcons (Qcyclic_variable_indirection
, error_tail
));
3118 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3119 build_string ("Symbol's chain of variable indirections contains a loop"));
3121 Qcircular_list
= intern ("circular-list");
3122 staticpro (&Qcircular_list
);
3123 Fput (Qcircular_list
, Qerror_conditions
,
3124 Fcons (Qcircular_list
, error_tail
));
3125 Fput (Qcircular_list
, Qerror_message
,
3126 build_string ("List contains a loop"));
3128 Fput (Qvoid_variable
, Qerror_conditions
,
3129 Fcons (Qvoid_variable
, error_tail
));
3130 Fput (Qvoid_variable
, Qerror_message
,
3131 build_string ("Symbol's value as variable is void"));
3133 Fput (Qsetting_constant
, Qerror_conditions
,
3134 Fcons (Qsetting_constant
, error_tail
));
3135 Fput (Qsetting_constant
, Qerror_message
,
3136 build_string ("Attempt to set a constant symbol"));
3138 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3139 Fcons (Qinvalid_read_syntax
, error_tail
));
3140 Fput (Qinvalid_read_syntax
, Qerror_message
,
3141 build_string ("Invalid read syntax"));
3143 Fput (Qinvalid_function
, Qerror_conditions
,
3144 Fcons (Qinvalid_function
, error_tail
));
3145 Fput (Qinvalid_function
, Qerror_message
,
3146 build_string ("Invalid function"));
3148 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3149 Fcons (Qwrong_number_of_arguments
, error_tail
));
3150 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3151 build_string ("Wrong number of arguments"));
3153 Fput (Qno_catch
, Qerror_conditions
,
3154 Fcons (Qno_catch
, error_tail
));
3155 Fput (Qno_catch
, Qerror_message
,
3156 build_string ("No catch for tag"));
3158 Fput (Qend_of_file
, Qerror_conditions
,
3159 Fcons (Qend_of_file
, error_tail
));
3160 Fput (Qend_of_file
, Qerror_message
,
3161 build_string ("End of file during parsing"));
3163 arith_tail
= Fcons (Qarith_error
, error_tail
);
3164 Fput (Qarith_error
, Qerror_conditions
,
3166 Fput (Qarith_error
, Qerror_message
,
3167 build_string ("Arithmetic error"));
3169 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3170 Fcons (Qbeginning_of_buffer
, error_tail
));
3171 Fput (Qbeginning_of_buffer
, Qerror_message
,
3172 build_string ("Beginning of buffer"));
3174 Fput (Qend_of_buffer
, Qerror_conditions
,
3175 Fcons (Qend_of_buffer
, error_tail
));
3176 Fput (Qend_of_buffer
, Qerror_message
,
3177 build_string ("End of buffer"));
3179 Fput (Qbuffer_read_only
, Qerror_conditions
,
3180 Fcons (Qbuffer_read_only
, error_tail
));
3181 Fput (Qbuffer_read_only
, Qerror_message
,
3182 build_string ("Buffer is read-only"));
3184 Fput (Qtext_read_only
, Qerror_conditions
,
3185 Fcons (Qtext_read_only
, error_tail
));
3186 Fput (Qtext_read_only
, Qerror_message
,
3187 build_string ("Text is read-only"));
3189 Qrange_error
= intern ("range-error");
3190 Qdomain_error
= intern ("domain-error");
3191 Qsingularity_error
= intern ("singularity-error");
3192 Qoverflow_error
= intern ("overflow-error");
3193 Qunderflow_error
= intern ("underflow-error");
3195 Fput (Qdomain_error
, Qerror_conditions
,
3196 Fcons (Qdomain_error
, arith_tail
));
3197 Fput (Qdomain_error
, Qerror_message
,
3198 build_string ("Arithmetic domain error"));
3200 Fput (Qrange_error
, Qerror_conditions
,
3201 Fcons (Qrange_error
, arith_tail
));
3202 Fput (Qrange_error
, Qerror_message
,
3203 build_string ("Arithmetic range error"));
3205 Fput (Qsingularity_error
, Qerror_conditions
,
3206 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3207 Fput (Qsingularity_error
, Qerror_message
,
3208 build_string ("Arithmetic singularity error"));
3210 Fput (Qoverflow_error
, Qerror_conditions
,
3211 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3212 Fput (Qoverflow_error
, Qerror_message
,
3213 build_string ("Arithmetic overflow error"));
3215 Fput (Qunderflow_error
, Qerror_conditions
,
3216 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3217 Fput (Qunderflow_error
, Qerror_message
,
3218 build_string ("Arithmetic underflow error"));
3220 staticpro (&Qrange_error
);
3221 staticpro (&Qdomain_error
);
3222 staticpro (&Qsingularity_error
);
3223 staticpro (&Qoverflow_error
);
3224 staticpro (&Qunderflow_error
);
3228 staticpro (&Qquote
);
3229 staticpro (&Qlambda
);
3231 staticpro (&Qunbound
);
3232 staticpro (&Qerror_conditions
);
3233 staticpro (&Qerror_message
);
3234 staticpro (&Qtop_level
);
3236 staticpro (&Qerror
);
3238 staticpro (&Qwrong_type_argument
);
3239 staticpro (&Qargs_out_of_range
);
3240 staticpro (&Qvoid_function
);
3241 staticpro (&Qcyclic_function_indirection
);
3242 staticpro (&Qcyclic_variable_indirection
);
3243 staticpro (&Qvoid_variable
);
3244 staticpro (&Qsetting_constant
);
3245 staticpro (&Qinvalid_read_syntax
);
3246 staticpro (&Qwrong_number_of_arguments
);
3247 staticpro (&Qinvalid_function
);
3248 staticpro (&Qno_catch
);
3249 staticpro (&Qend_of_file
);
3250 staticpro (&Qarith_error
);
3251 staticpro (&Qbeginning_of_buffer
);
3252 staticpro (&Qend_of_buffer
);
3253 staticpro (&Qbuffer_read_only
);
3254 staticpro (&Qtext_read_only
);
3255 staticpro (&Qmark_inactive
);
3257 staticpro (&Qlistp
);
3258 staticpro (&Qconsp
);
3259 staticpro (&Qsymbolp
);
3260 staticpro (&Qkeywordp
);
3261 staticpro (&Qintegerp
);
3262 staticpro (&Qnatnump
);
3263 staticpro (&Qwholenump
);
3264 staticpro (&Qstringp
);
3265 staticpro (&Qarrayp
);
3266 staticpro (&Qsequencep
);
3267 staticpro (&Qbufferp
);
3268 staticpro (&Qvectorp
);
3269 staticpro (&Qchar_or_string_p
);
3270 staticpro (&Qmarkerp
);
3271 staticpro (&Qbuffer_or_string_p
);
3272 staticpro (&Qinteger_or_marker_p
);
3273 staticpro (&Qfloatp
);
3274 staticpro (&Qnumberp
);
3275 staticpro (&Qnumber_or_marker_p
);
3276 staticpro (&Qchar_table_p
);
3277 staticpro (&Qvector_or_char_table_p
);
3278 staticpro (&Qsubrp
);
3280 staticpro (&Qunevalled
);
3282 staticpro (&Qboundp
);
3283 staticpro (&Qfboundp
);
3285 staticpro (&Qad_advice_info
);
3286 staticpro (&Qad_activate_internal
);
3288 /* Types that type-of returns. */
3289 Qinteger
= intern ("integer");
3290 Qsymbol
= intern ("symbol");
3291 Qstring
= intern ("string");
3292 Qcons
= intern ("cons");
3293 Qmarker
= intern ("marker");
3294 Qoverlay
= intern ("overlay");
3295 Qfloat
= intern ("float");
3296 Qwindow_configuration
= intern ("window-configuration");
3297 Qprocess
= intern ("process");
3298 Qwindow
= intern ("window");
3299 /* Qsubr = intern ("subr"); */
3300 Qcompiled_function
= intern ("compiled-function");
3301 Qbuffer
= intern ("buffer");
3302 Qframe
= intern ("frame");
3303 Qvector
= intern ("vector");
3304 Qchar_table
= intern ("char-table");
3305 Qbool_vector
= intern ("bool-vector");
3306 Qhash_table
= intern ("hash-table");
3308 staticpro (&Qinteger
);
3309 staticpro (&Qsymbol
);
3310 staticpro (&Qstring
);
3312 staticpro (&Qmarker
);
3313 staticpro (&Qoverlay
);
3314 staticpro (&Qfloat
);
3315 staticpro (&Qwindow_configuration
);
3316 staticpro (&Qprocess
);
3317 staticpro (&Qwindow
);
3318 /* staticpro (&Qsubr); */
3319 staticpro (&Qcompiled_function
);
3320 staticpro (&Qbuffer
);
3321 staticpro (&Qframe
);
3322 staticpro (&Qvector
);
3323 staticpro (&Qchar_table
);
3324 staticpro (&Qbool_vector
);
3325 staticpro (&Qhash_table
);
3327 defsubr (&Sindirect_variable
);
3328 defsubr (&Sinteractive_form
);
3331 defsubr (&Stype_of
);
3336 defsubr (&Sintegerp
);
3337 defsubr (&Sinteger_or_marker_p
);
3338 defsubr (&Snumberp
);
3339 defsubr (&Snumber_or_marker_p
);
3341 defsubr (&Snatnump
);
3342 defsubr (&Ssymbolp
);
3343 defsubr (&Skeywordp
);
3344 defsubr (&Sstringp
);
3345 defsubr (&Smultibyte_string_p
);
3346 defsubr (&Svectorp
);
3347 defsubr (&Schar_table_p
);
3348 defsubr (&Svector_or_char_table_p
);
3349 defsubr (&Sbool_vector_p
);
3351 defsubr (&Ssequencep
);
3352 defsubr (&Sbufferp
);
3353 defsubr (&Smarkerp
);
3355 defsubr (&Sbyte_code_function_p
);
3356 defsubr (&Schar_or_string_p
);
3359 defsubr (&Scar_safe
);
3360 defsubr (&Scdr_safe
);
3363 defsubr (&Ssymbol_function
);
3364 defsubr (&Sindirect_function
);
3365 defsubr (&Ssymbol_plist
);
3366 defsubr (&Ssymbol_name
);
3367 defsubr (&Smakunbound
);
3368 defsubr (&Sfmakunbound
);
3370 defsubr (&Sfboundp
);
3372 defsubr (&Sdefalias
);
3373 defsubr (&Ssetplist
);
3374 defsubr (&Ssymbol_value
);
3376 defsubr (&Sdefault_boundp
);
3377 defsubr (&Sdefault_value
);
3378 defsubr (&Sset_default
);
3379 defsubr (&Ssetq_default
);
3380 defsubr (&Smake_variable_buffer_local
);
3381 defsubr (&Smake_local_variable
);
3382 defsubr (&Skill_local_variable
);
3383 defsubr (&Smake_variable_frame_local
);
3384 defsubr (&Slocal_variable_p
);
3385 defsubr (&Slocal_variable_if_set_p
);
3386 defsubr (&Svariable_binding_locus
);
3387 #if 0 /* XXX Remove this. --lorentey */
3388 defsubr (&Sterminal_local_value
);
3389 defsubr (&Sset_terminal_local_value
);
3393 defsubr (&Snumber_to_string
);
3394 defsubr (&Sstring_to_number
);
3395 defsubr (&Seqlsign
);
3418 defsubr (&Sbyteorder
);
3419 defsubr (&Ssubr_arity
);
3420 defsubr (&Ssubr_name
);
3422 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3424 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3425 doc
: /* The largest value that is representable in a Lisp integer. */);
3426 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3428 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3429 doc
: /* The smallest value that is representable in a Lisp integer. */);
3430 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3437 #if defined(USG) && !defined(POSIX_SIGNALS)
3438 /* USG systems forget handlers when they are used;
3439 must reestablish each time */
3440 signal (signo
, arith_error
);
3443 /* VMS systems are like USG. */
3444 signal (signo
, arith_error
);
3448 #else /* not BSD4_1 */
3449 sigsetmask (SIGEMPTYMASK
);
3450 #endif /* not BSD4_1 */
3452 SIGNAL_THREAD_CHECK (signo
);
3453 xsignal0 (Qarith_error
);
3459 /* Don't do this if just dumping out.
3460 We don't want to call `signal' in this case
3461 so that we don't have trouble with dumping
3462 signal-delivering routines in an inconsistent state. */
3466 #endif /* CANNOT_DUMP */
3467 signal (SIGFPE
, arith_error
);
3470 signal (SIGEMT
, arith_error
);
3474 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3475 (do not change this comment) */