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 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 2, 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 Fsignal (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 Fsignal (Qwrong_type_argument
, list2 (predicate
, value
));
124 /* This function is marked as NO_RETURN, gcc would warn if it has a
125 return statement or if falls off the function. Other compilers
126 warn if no return statement is present. */
137 error ("Attempt to modify read-only object");
141 args_out_of_range (a1
, a2
)
145 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
149 args_out_of_range_3 (a1
, a2
, a3
)
150 Lisp_Object a1
, a2
, a3
;
153 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
156 /* On some machines, XINT needs a temporary location.
157 Here it is, in case it is needed. */
159 int sign_extend_temp
;
161 /* On a few machines, XINT can only be done by calling this. */
164 sign_extend_lisp_int (num
)
167 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
168 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
170 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
173 /* Data type predicates */
175 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
176 doc
: /* Return t if the two args are the same Lisp object. */)
178 Lisp_Object obj1
, obj2
;
185 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
186 doc
: /* Return t if OBJECT is nil. */)
195 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
196 doc
: /* Return a symbol representing the type of OBJECT.
197 The symbol returned names the object's basic type;
198 for example, (type-of 1) returns `integer'. */)
202 switch (XGCTYPE (object
))
217 switch (XMISCTYPE (object
))
219 case Lisp_Misc_Marker
:
221 case Lisp_Misc_Overlay
:
223 case Lisp_Misc_Float
:
228 case Lisp_Vectorlike
:
229 if (GC_WINDOW_CONFIGURATIONP (object
))
230 return Qwindow_configuration
;
231 if (GC_PROCESSP (object
))
233 if (GC_WINDOWP (object
))
235 if (GC_SUBRP (object
))
237 if (GC_COMPILEDP (object
))
238 return Qcompiled_function
;
239 if (GC_BUFFERP (object
))
241 if (GC_CHAR_TABLE_P (object
))
243 if (GC_BOOL_VECTOR_P (object
))
245 if (GC_FRAMEP (object
))
247 if (GC_HASH_TABLE_P (object
))
259 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
260 doc
: /* Return t if OBJECT is a cons cell. */)
269 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
270 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
279 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
281 Otherwise, return nil. */)
285 if (CONSP (object
) || NILP (object
))
290 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
291 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
295 if (CONSP (object
) || NILP (object
))
300 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
301 doc
: /* Return t if OBJECT is a symbol. */)
305 if (SYMBOLP (object
))
310 /* Define this in C to avoid unnecessarily consing up the symbol
312 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
313 doc
: /* Return t if OBJECT is a keyword.
314 This means that it is a symbol with a print name beginning with `:'
315 interned in the initial obarray. */)
320 && SREF (SYMBOL_NAME (object
), 0) == ':'
321 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
326 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
327 doc
: /* Return t if OBJECT is a vector. */)
331 if (VECTORP (object
))
336 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
337 doc
: /* Return t if OBJECT is a string. */)
341 if (STRINGP (object
))
346 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
348 doc
: /* Return t if OBJECT is a multibyte string. */)
352 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
357 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
358 doc
: /* Return t if OBJECT is a char-table. */)
362 if (CHAR_TABLE_P (object
))
367 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
368 Svector_or_char_table_p
, 1, 1, 0,
369 doc
: /* Return t if OBJECT is a char-table or vector. */)
373 if (VECTORP (object
) || CHAR_TABLE_P (object
))
378 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
379 doc
: /* Return t if OBJECT is a bool-vector. */)
383 if (BOOL_VECTOR_P (object
))
388 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
389 doc
: /* Return t if OBJECT is an array (string or vector). */)
398 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
399 doc
: /* Return t if OBJECT is a sequence (list or array). */)
401 register Lisp_Object object
;
403 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
408 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
409 doc
: /* Return t if OBJECT is an editor buffer. */)
413 if (BUFFERP (object
))
418 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
423 if (MARKERP (object
))
428 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
429 doc
: /* Return t if OBJECT is a built-in function. */)
438 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
440 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
444 if (COMPILEDP (object
))
449 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
450 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
452 register Lisp_Object object
;
454 if (INTEGERP (object
) || STRINGP (object
))
459 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
460 doc
: /* Return t if OBJECT is an integer. */)
464 if (INTEGERP (object
))
469 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
470 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
472 register Lisp_Object object
;
474 if (MARKERP (object
) || INTEGERP (object
))
479 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
480 doc
: /* Return t if OBJECT is a nonnegative integer. */)
484 if (NATNUMP (object
))
489 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
490 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
494 if (NUMBERP (object
))
500 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
501 Snumber_or_marker_p
, 1, 1, 0,
502 doc
: /* Return t if OBJECT is a number or a marker. */)
506 if (NUMBERP (object
) || MARKERP (object
))
511 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
512 doc
: /* Return t if OBJECT is a floating point number. */)
522 /* Extract and set components of lists */
524 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
525 doc
: /* Return the car of LIST. If arg is nil, return nil.
526 Error if arg is not nil and not a cons cell. See also `car-safe'.
528 See Info node `(elisp)Cons Cells' for a discussion of related basic
529 Lisp concepts such as car, cdr, cons cell and list. */)
531 register Lisp_Object list
;
536 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
537 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
541 return CAR_SAFE (object
);
544 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
545 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
546 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
548 See Info node `(elisp)Cons Cells' for a discussion of related basic
549 Lisp concepts such as cdr, car, cons cell and list. */)
551 register Lisp_Object list
;
556 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
557 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
561 return CDR_SAFE (object
);
564 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
565 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
567 register Lisp_Object cell
, newcar
;
571 XSETCAR (cell
, newcar
);
575 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
576 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
578 register Lisp_Object cell
, newcdr
;
582 XSETCDR (cell
, newcdr
);
586 /* Extract and set components of symbols */
588 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
589 doc
: /* Return t if SYMBOL's value is not void. */)
591 register Lisp_Object symbol
;
593 Lisp_Object valcontents
;
594 CHECK_SYMBOL (symbol
);
596 valcontents
= SYMBOL_VALUE (symbol
);
598 if (BUFFER_LOCAL_VALUEP (valcontents
)
599 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
600 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
602 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
605 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
606 doc
: /* Return t if SYMBOL's function definition is not void. */)
608 register Lisp_Object symbol
;
610 CHECK_SYMBOL (symbol
);
611 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
614 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
615 doc
: /* Make SYMBOL's value be void.
618 register Lisp_Object symbol
;
620 CHECK_SYMBOL (symbol
);
621 if (XSYMBOL (symbol
)->constant
)
622 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
623 Fset (symbol
, Qunbound
);
627 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
628 doc
: /* Make SYMBOL's function definition be void.
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
);
634 if (NILP (symbol
) || EQ (symbol
, Qt
))
635 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
636 XSYMBOL (symbol
)->function
= Qunbound
;
640 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
641 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
643 register Lisp_Object symbol
;
645 CHECK_SYMBOL (symbol
);
646 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
647 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
648 return XSYMBOL (symbol
)->function
;
651 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
652 doc
: /* Return SYMBOL's property list. */)
654 register Lisp_Object symbol
;
656 CHECK_SYMBOL (symbol
);
657 return XSYMBOL (symbol
)->plist
;
660 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
661 doc
: /* Return SYMBOL's name, a string. */)
663 register Lisp_Object symbol
;
665 register Lisp_Object name
;
667 CHECK_SYMBOL (symbol
);
668 name
= SYMBOL_NAME (symbol
);
672 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
673 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
675 register Lisp_Object symbol
, definition
;
677 CHECK_SYMBOL (symbol
);
678 if (NILP (symbol
) || EQ (symbol
, Qt
))
679 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
680 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
681 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
683 XSYMBOL (symbol
)->function
= definition
;
684 /* Handle automatic advice activation */
685 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
687 call2 (Qad_activate_internal
, symbol
, Qnil
);
688 definition
= XSYMBOL (symbol
)->function
;
693 extern Lisp_Object Qfunction_documentation
;
695 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
696 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
697 Associates the function with the current load file, if any.
698 The optional third argument DOCSTRING specifies the documentation string
699 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
700 determined by DEFINITION. */)
701 (symbol
, definition
, docstring
)
702 register Lisp_Object symbol
, definition
, docstring
;
704 CHECK_SYMBOL (symbol
);
705 if (CONSP (XSYMBOL (symbol
)->function
)
706 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
707 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
708 definition
= Ffset (symbol
, definition
);
709 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
710 if (!NILP (docstring
))
711 Fput (symbol
, Qfunction_documentation
, docstring
);
715 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
716 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
718 register Lisp_Object symbol
, newplist
;
720 CHECK_SYMBOL (symbol
);
721 XSYMBOL (symbol
)->plist
= newplist
;
725 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
726 doc
: /* Return minimum and maximum number of args allowed for SUBR.
727 SUBR must be a built-in function.
728 The returned value is a pair (MIN . MAX). MIN is the minimum number
729 of args. MAX is the maximum number or the symbol `many', for a
730 function with `&rest' args, or `unevalled' for a special form. */)
734 short minargs
, maxargs
;
736 minargs
= XSUBR (subr
)->min_args
;
737 maxargs
= XSUBR (subr
)->max_args
;
739 return Fcons (make_number (minargs
), Qmany
);
740 else if (maxargs
== UNEVALLED
)
741 return Fcons (make_number (minargs
), Qunevalled
);
743 return Fcons (make_number (minargs
), make_number (maxargs
));
746 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
747 doc
: /* Return name of subroutine SUBR.
748 SUBR must be a built-in function. */)
754 name
= XSUBR (subr
)->symbol_name
;
755 return make_string (name
, strlen (name
));
758 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
759 doc
: /* Return the interactive form of CMD or nil if none.
760 If CMD is not a command, the return value is nil.
761 Value, if non-nil, is a list \(interactive SPEC). */)
765 Lisp_Object fun
= indirect_function (cmd
);
769 if (XSUBR (fun
)->prompt
)
770 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
772 else if (COMPILEDP (fun
))
774 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
775 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
777 else if (CONSP (fun
))
779 Lisp_Object funcar
= XCAR (fun
);
780 if (EQ (funcar
, Qlambda
))
781 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
782 else if (EQ (funcar
, Qautoload
))
786 do_autoload (fun
, cmd
);
788 return Finteractive_form (cmd
);
795 /***********************************************************************
796 Getting and Setting Values of Symbols
797 ***********************************************************************/
799 /* Return the symbol holding SYMBOL's value. Signal
800 `cyclic-variable-indirection' if SYMBOL's chain of variable
801 indirections contains a loop. */
804 indirect_variable (symbol
)
807 Lisp_Object tortoise
, hare
;
809 hare
= tortoise
= symbol
;
811 while (XSYMBOL (hare
)->indirect_variable
)
813 hare
= XSYMBOL (hare
)->value
;
814 if (!XSYMBOL (hare
)->indirect_variable
)
817 hare
= XSYMBOL (hare
)->value
;
818 tortoise
= XSYMBOL (tortoise
)->value
;
820 if (EQ (hare
, tortoise
))
821 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
828 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
829 doc
: /* Return the variable at the end of OBJECT's variable chain.
830 If OBJECT is a symbol, follow all variable indirections and return the final
831 variable. If OBJECT is not a symbol, just return it.
832 Signal a cyclic-variable-indirection error if there is a loop in the
833 variable chain of symbols. */)
837 if (SYMBOLP (object
))
838 object
= indirect_variable (object
);
843 /* Given the raw contents of a symbol value cell,
844 return the Lisp value of the symbol.
845 This does not handle buffer-local variables; use
846 swap_in_symval_forwarding for that. */
849 do_symval_forwarding (valcontents
)
850 register Lisp_Object valcontents
;
852 register Lisp_Object val
;
854 if (MISCP (valcontents
))
855 switch (XMISCTYPE (valcontents
))
857 case Lisp_Misc_Intfwd
:
858 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
861 case Lisp_Misc_Boolfwd
:
862 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
864 case Lisp_Misc_Objfwd
:
865 return *XOBJFWD (valcontents
)->objvar
;
867 case Lisp_Misc_Buffer_Objfwd
:
868 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
869 return PER_BUFFER_VALUE (current_buffer
, offset
);
871 case Lisp_Misc_Kboard_Objfwd
:
872 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
873 /* We used to simply use current_kboard here, but from Lisp
874 code, it's value is often unexpected. It seems nicer to
875 allow constructions like this to work as intuitively expected:
877 (with-selected-frame frame
878 (define-key local-function-map "\eOP" [f1]))
880 On the other hand, this affects the semantics of
881 last-command and real-last-command, and people may rely on
882 that. I took a quick look at the Lisp codebase, and I
883 don't think anything will break. --lorentey */
884 return *(Lisp_Object
*)(offset
+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
889 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
890 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
891 buffer-independent contents of the value cell: forwarded just one
892 step past the buffer-localness.
894 BUF non-zero means set the value in buffer BUF instead of the
895 current buffer. This only plays a role for per-buffer variables. */
898 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
900 register Lisp_Object valcontents
, newval
;
903 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
906 switch (XMISCTYPE (valcontents
))
908 case Lisp_Misc_Intfwd
:
909 CHECK_NUMBER (newval
);
910 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
911 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
912 error ("Value out of range for variable `%s'",
913 SDATA (SYMBOL_NAME (symbol
)));
916 case Lisp_Misc_Boolfwd
:
917 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
920 case Lisp_Misc_Objfwd
:
921 *XOBJFWD (valcontents
)->objvar
= newval
;
923 /* If this variable is a default for something stored
924 in the buffer itself, such as default-fill-column,
925 find the buffers that don't have local values for it
927 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
928 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
930 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
931 - (char *) &buffer_defaults
);
932 int idx
= PER_BUFFER_IDX (offset
);
939 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
944 buf
= Fcdr (XCAR (tail
));
945 if (!BUFFERP (buf
)) continue;
948 if (! PER_BUFFER_VALUE_P (b
, idx
))
949 PER_BUFFER_VALUE (b
, offset
) = newval
;
954 case Lisp_Misc_Buffer_Objfwd
:
956 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
959 type
= PER_BUFFER_TYPE (offset
);
960 if (! NILP (type
) && ! NILP (newval
)
961 && XTYPE (newval
) != XINT (type
))
962 buffer_slot_type_mismatch (offset
);
965 buf
= current_buffer
;
966 PER_BUFFER_VALUE (buf
, offset
) = newval
;
970 case Lisp_Misc_Kboard_Objfwd
:
972 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
973 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
974 *(Lisp_Object
*) p
= newval
;
985 valcontents
= SYMBOL_VALUE (symbol
);
986 if (BUFFER_LOCAL_VALUEP (valcontents
)
987 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
988 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
990 SET_SYMBOL_VALUE (symbol
, newval
);
994 /* Set up SYMBOL to refer to its global binding.
995 This makes it safe to alter the status of other bindings. */
998 swap_in_global_binding (symbol
)
1001 Lisp_Object valcontents
, cdr
;
1003 valcontents
= SYMBOL_VALUE (symbol
);
1004 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1005 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1007 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1009 /* Unload the previously loaded binding. */
1010 Fsetcdr (XCAR (cdr
),
1011 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1013 /* Select the global binding in the symbol. */
1015 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1017 /* Indicate that the global binding is set up now. */
1018 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1019 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1020 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1021 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1024 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1025 VALCONTENTS is the contents of its value cell,
1026 which points to a struct Lisp_Buffer_Local_Value.
1028 Return the value forwarded one step past the buffer-local stage.
1029 This could be another forwarding pointer. */
1032 swap_in_symval_forwarding (symbol
, valcontents
)
1033 Lisp_Object symbol
, valcontents
;
1035 register Lisp_Object tem1
;
1037 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1040 || current_buffer
!= XBUFFER (tem1
)
1041 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1042 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1044 if (XSYMBOL (symbol
)->indirect_variable
)
1045 symbol
= indirect_variable (symbol
);
1047 /* Unload the previously loaded binding. */
1048 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1050 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1051 /* Choose the new binding. */
1052 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1053 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1054 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1057 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1058 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1060 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1062 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1065 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1067 /* Load the new binding. */
1068 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1069 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1070 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1071 store_symval_forwarding (symbol
,
1072 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1075 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1078 /* Find the value of a symbol, returning Qunbound if it's not bound.
1079 This is helpful for code which just wants to get a variable's value
1080 if it has one, without signaling an error.
1081 Note that it must not be possible to quit
1082 within this function. Great care is required for this. */
1085 find_symbol_value (symbol
)
1088 register Lisp_Object valcontents
;
1089 register Lisp_Object val
;
1091 CHECK_SYMBOL (symbol
);
1092 valcontents
= SYMBOL_VALUE (symbol
);
1094 if (BUFFER_LOCAL_VALUEP (valcontents
)
1095 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1096 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1098 if (MISCP (valcontents
))
1100 switch (XMISCTYPE (valcontents
))
1102 case Lisp_Misc_Intfwd
:
1103 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1106 case Lisp_Misc_Boolfwd
:
1107 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1109 case Lisp_Misc_Objfwd
:
1110 return *XOBJFWD (valcontents
)->objvar
;
1112 case Lisp_Misc_Buffer_Objfwd
:
1113 return PER_BUFFER_VALUE (current_buffer
,
1114 XBUFFER_OBJFWD (valcontents
)->offset
);
1116 case Lisp_Misc_Kboard_Objfwd
:
1117 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1118 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
1125 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1126 doc
: /* Return SYMBOL's value. Error if that is void. */)
1132 val
= find_symbol_value (symbol
);
1133 if (EQ (val
, Qunbound
))
1134 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1139 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1140 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1142 register Lisp_Object symbol
, newval
;
1144 return set_internal (symbol
, newval
, current_buffer
, 0);
1147 /* Return 1 if SYMBOL currently has a let-binding
1148 which was made in the buffer that is now current. */
1151 let_shadows_buffer_binding_p (symbol
)
1154 volatile struct specbinding
*p
;
1156 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1158 && CONSP (p
->symbol
))
1160 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1161 if ((EQ (symbol
, let_bound_symbol
)
1162 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1163 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1164 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1168 return p
>= specpdl
;
1171 /* Store the value NEWVAL into SYMBOL.
1172 If buffer-locality is an issue, BUF specifies which buffer to use.
1173 (0 stands for the current buffer.)
1175 If BINDFLAG is zero, then if this symbol is supposed to become
1176 local in every buffer where it is set, then we make it local.
1177 If BINDFLAG is nonzero, we don't do that. */
1180 set_internal (symbol
, newval
, buf
, bindflag
)
1181 register Lisp_Object symbol
, newval
;
1185 int voide
= EQ (newval
, Qunbound
);
1187 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1190 buf
= current_buffer
;
1192 /* If restoring in a dead buffer, do nothing. */
1193 if (NILP (buf
->name
))
1196 CHECK_SYMBOL (symbol
);
1197 if (SYMBOL_CONSTANT_P (symbol
)
1198 && (NILP (Fkeywordp (symbol
))
1199 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1200 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1202 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1204 if (BUFFER_OBJFWDP (valcontents
))
1206 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1207 int idx
= PER_BUFFER_IDX (offset
);
1210 && !let_shadows_buffer_binding_p (symbol
))
1211 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1213 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1214 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1216 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1217 if (XSYMBOL (symbol
)->indirect_variable
)
1218 symbol
= indirect_variable (symbol
);
1220 /* What binding is loaded right now? */
1221 current_alist_element
1222 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1224 /* If the current buffer is not the buffer whose binding is
1225 loaded, or if there may be frame-local bindings and the frame
1226 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1227 the default binding is loaded, the loaded binding may be the
1229 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1230 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1231 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1232 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1233 || (BUFFER_LOCAL_VALUEP (valcontents
)
1234 && EQ (XCAR (current_alist_element
),
1235 current_alist_element
)))
1237 /* The currently loaded binding is not necessarily valid.
1238 We need to unload it, and choose a new binding. */
1240 /* Write out `realvalue' to the old loaded binding. */
1241 Fsetcdr (current_alist_element
,
1242 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1244 /* Find the new binding. */
1245 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1246 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1247 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1251 /* This buffer still sees the default value. */
1253 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1254 or if this is `let' rather than `set',
1255 make CURRENT-ALIST-ELEMENT point to itself,
1256 indicating that we're seeing the default value.
1257 Likewise if the variable has been let-bound
1258 in the current buffer. */
1259 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1260 || let_shadows_buffer_binding_p (symbol
))
1262 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1264 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1265 tem1
= Fassq (symbol
,
1266 XFRAME (selected_frame
)->param_alist
);
1269 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1271 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1273 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1274 and we're not within a let that was made for this buffer,
1275 create a new buffer-local binding for the variable.
1276 That means, give this buffer a new assoc for a local value
1277 and load that binding. */
1280 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1281 buf
->local_var_alist
1282 = Fcons (tem1
, buf
->local_var_alist
);
1286 /* Record which binding is now loaded. */
1287 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1290 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1291 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1292 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1294 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1297 /* If storing void (making the symbol void), forward only through
1298 buffer-local indicator, not through Lisp_Objfwd, etc. */
1300 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1302 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1304 /* If we just set a variable whose current binding is frame-local,
1305 store the new value in the frame parameter too. */
1307 if (BUFFER_LOCAL_VALUEP (valcontents
)
1308 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1310 /* What binding is loaded right now? */
1311 current_alist_element
1312 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1314 /* If the current buffer is not the buffer whose binding is
1315 loaded, or if there may be frame-local bindings and the frame
1316 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1317 the default binding is loaded, the loaded binding may be the
1319 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1320 XSETCDR (current_alist_element
, newval
);
1326 /* Access or set a buffer-local symbol's default value. */
1328 /* Return the default value of SYMBOL, but don't check for voidness.
1329 Return Qunbound if it is void. */
1332 default_value (symbol
)
1335 register Lisp_Object valcontents
;
1337 CHECK_SYMBOL (symbol
);
1338 valcontents
= SYMBOL_VALUE (symbol
);
1340 /* For a built-in buffer-local variable, get the default value
1341 rather than letting do_symval_forwarding get the current value. */
1342 if (BUFFER_OBJFWDP (valcontents
))
1344 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1345 if (PER_BUFFER_IDX (offset
) != 0)
1346 return PER_BUFFER_DEFAULT (offset
);
1349 /* Handle user-created local variables. */
1350 if (BUFFER_LOCAL_VALUEP (valcontents
)
1351 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1353 /* If var is set up for a buffer that lacks a local value for it,
1354 the current value is nominally the default value.
1355 But the `realvalue' slot may be more up to date, since
1356 ordinary setq stores just that slot. So use that. */
1357 Lisp_Object current_alist_element
, alist_element_car
;
1358 current_alist_element
1359 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1360 alist_element_car
= XCAR (current_alist_element
);
1361 if (EQ (alist_element_car
, current_alist_element
))
1362 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1364 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1366 /* For other variables, get the current value. */
1367 return do_symval_forwarding (valcontents
);
1370 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1371 doc
: /* Return t if SYMBOL has a non-void default value.
1372 This is the value that is seen in buffers that do not have their own values
1373 for this variable. */)
1377 register Lisp_Object value
;
1379 value
= default_value (symbol
);
1380 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1383 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1384 doc
: /* Return SYMBOL's default value.
1385 This is the value that is seen in buffers that do not have their own values
1386 for this variable. The default value is meaningful for variables with
1387 local bindings in certain buffers. */)
1391 register Lisp_Object value
;
1393 value
= default_value (symbol
);
1394 if (EQ (value
, Qunbound
))
1395 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1399 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1400 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1401 The default value is seen in buffers that do not have their own values
1402 for this variable. */)
1404 Lisp_Object symbol
, value
;
1406 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1408 CHECK_SYMBOL (symbol
);
1409 valcontents
= SYMBOL_VALUE (symbol
);
1411 /* Handle variables like case-fold-search that have special slots
1412 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1414 if (BUFFER_OBJFWDP (valcontents
))
1416 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1417 int idx
= PER_BUFFER_IDX (offset
);
1419 PER_BUFFER_DEFAULT (offset
) = value
;
1421 /* If this variable is not always local in all buffers,
1422 set it in the buffers that don't nominally have a local value. */
1427 for (b
= all_buffers
; b
; b
= b
->next
)
1428 if (!PER_BUFFER_VALUE_P (b
, idx
))
1429 PER_BUFFER_VALUE (b
, offset
) = value
;
1434 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1435 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1436 return Fset (symbol
, value
);
1438 /* Store new value into the DEFAULT-VALUE slot. */
1439 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1441 /* If the default binding is now loaded, set the REALVALUE slot too. */
1442 current_alist_element
1443 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1444 alist_element_buffer
= Fcar (current_alist_element
);
1445 if (EQ (alist_element_buffer
, current_alist_element
))
1446 store_symval_forwarding (symbol
,
1447 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1453 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1454 doc
: /* Set the default value of variable VAR to VALUE.
1455 VAR, the variable name, is literal (not evaluated);
1456 VALUE is an expression: it is evaluated and its value returned.
1457 The default value of a variable is seen in buffers
1458 that do not have their own values for the variable.
1460 More generally, you can use multiple variables and values, as in
1461 (setq-default VAR VALUE VAR VALUE...)
1462 This sets each VAR's default value to the corresponding VALUE.
1463 The VALUE for the Nth VAR can refer to the new default values
1465 usage: (setq-default [VAR VALUE...]) */)
1469 register Lisp_Object args_left
;
1470 register Lisp_Object val
, symbol
;
1471 struct gcpro gcpro1
;
1481 val
= Feval (Fcar (Fcdr (args_left
)));
1482 symbol
= XCAR (args_left
);
1483 Fset_default (symbol
, val
);
1484 args_left
= Fcdr (XCDR (args_left
));
1486 while (!NILP (args_left
));
1492 /* Lisp functions for creating and removing buffer-local variables. */
1494 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1495 1, 1, "vMake Variable Buffer Local: ",
1496 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1497 At any time, the value for the current buffer is in effect,
1498 unless the variable has never been set in this buffer,
1499 in which case the default value is in effect.
1500 Note that binding the variable with `let', or setting it while
1501 a `let'-style binding made in this buffer is in effect,
1502 does not make the variable buffer-local. Return VARIABLE.
1504 In most cases it is better to use `make-local-variable',
1505 which makes a variable local in just one buffer.
1507 The function `default-value' gets the default value and `set-default' sets it. */)
1509 register Lisp_Object variable
;
1511 register Lisp_Object tem
, valcontents
, newval
;
1513 CHECK_SYMBOL (variable
);
1514 variable
= indirect_variable (variable
);
1516 valcontents
= SYMBOL_VALUE (variable
);
1517 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1518 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1520 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1522 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1524 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1527 if (EQ (valcontents
, Qunbound
))
1528 SET_SYMBOL_VALUE (variable
, Qnil
);
1529 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1531 newval
= allocate_misc ();
1532 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1533 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1534 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1535 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1536 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1537 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1538 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1539 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1540 SET_SYMBOL_VALUE (variable
, newval
);
1544 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1545 1, 1, "vMake Local Variable: ",
1546 doc
: /* Make VARIABLE have a separate value in the current buffer.
1547 Other buffers will continue to share a common default value.
1548 \(The buffer-local value of VARIABLE starts out as the same value
1549 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1552 If the variable is already arranged to become local when set,
1553 this function causes a local value to exist for this buffer,
1554 just as setting the variable would do.
1556 This function returns VARIABLE, and therefore
1557 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1560 See also `make-variable-buffer-local'.
1562 Do not use `make-local-variable' to make a hook variable buffer-local.
1563 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1565 register Lisp_Object variable
;
1567 register Lisp_Object tem
, valcontents
;
1569 CHECK_SYMBOL (variable
);
1570 variable
= indirect_variable (variable
);
1572 valcontents
= SYMBOL_VALUE (variable
);
1573 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1574 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1576 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1578 tem
= Fboundp (variable
);
1580 /* Make sure the symbol has a local value in this particular buffer,
1581 by setting it to the same value it already has. */
1582 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1585 /* Make sure symbol is set up to hold per-buffer values. */
1586 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1589 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1591 newval
= allocate_misc ();
1592 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1593 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1594 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1595 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1596 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1597 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1598 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1599 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1600 SET_SYMBOL_VALUE (variable
, newval
);;
1602 /* Make sure this buffer has its own value of symbol. */
1603 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1606 /* Swap out any local binding for some other buffer, and make
1607 sure the current value is permanently recorded, if it's the
1609 find_symbol_value (variable
);
1611 current_buffer
->local_var_alist
1612 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1613 current_buffer
->local_var_alist
);
1615 /* Make sure symbol does not think it is set up for this buffer;
1616 force it to look once again for this buffer's value. */
1618 Lisp_Object
*pvalbuf
;
1620 valcontents
= SYMBOL_VALUE (variable
);
1622 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1623 if (current_buffer
== XBUFFER (*pvalbuf
))
1625 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1629 /* If the symbol forwards into a C variable, then load the binding
1630 for this buffer now. If C code modifies the variable before we
1631 load the binding in, then that new value will clobber the default
1632 binding the next time we unload it. */
1633 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1634 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1635 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1640 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1641 1, 1, "vKill Local Variable: ",
1642 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1643 From now on the default value will apply in this buffer. Return VARIABLE. */)
1645 register Lisp_Object variable
;
1647 register Lisp_Object tem
, valcontents
;
1649 CHECK_SYMBOL (variable
);
1650 variable
= indirect_variable (variable
);
1652 valcontents
= SYMBOL_VALUE (variable
);
1654 if (BUFFER_OBJFWDP (valcontents
))
1656 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1657 int idx
= PER_BUFFER_IDX (offset
);
1661 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1662 PER_BUFFER_VALUE (current_buffer
, offset
)
1663 = PER_BUFFER_DEFAULT (offset
);
1668 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1669 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1672 /* Get rid of this buffer's alist element, if any. */
1674 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1676 current_buffer
->local_var_alist
1677 = Fdelq (tem
, current_buffer
->local_var_alist
);
1679 /* If the symbol is set up with the current buffer's binding
1680 loaded, recompute its value. We have to do it now, or else
1681 forwarded objects won't work right. */
1683 Lisp_Object
*pvalbuf
, buf
;
1684 valcontents
= SYMBOL_VALUE (variable
);
1685 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1686 XSETBUFFER (buf
, current_buffer
);
1687 if (EQ (buf
, *pvalbuf
))
1690 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1691 find_symbol_value (variable
);
1698 /* Lisp functions for creating and removing buffer-local variables. */
1700 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1701 1, 1, "vMake Variable Frame Local: ",
1702 doc
: /* Enable VARIABLE to have frame-local bindings.
1703 This does not create any frame-local bindings for VARIABLE,
1704 it just makes them possible.
1706 A frame-local binding is actually a frame parameter value.
1707 If a frame F has a value for the frame parameter named VARIABLE,
1708 that also acts as a frame-local binding for VARIABLE in F--
1709 provided this function has been called to enable VARIABLE
1710 to have frame-local bindings at all.
1712 The only way to create a frame-local binding for VARIABLE in a frame
1713 is to set the VARIABLE frame parameter of that frame. See
1714 `modify-frame-parameters' for how to set frame parameters.
1716 Buffer-local bindings take precedence over frame-local bindings. */)
1718 register Lisp_Object variable
;
1720 register Lisp_Object tem
, valcontents
, newval
;
1722 CHECK_SYMBOL (variable
);
1723 variable
= indirect_variable (variable
);
1725 valcontents
= SYMBOL_VALUE (variable
);
1726 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1727 || BUFFER_OBJFWDP (valcontents
))
1728 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1730 if (BUFFER_LOCAL_VALUEP (valcontents
)
1731 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1733 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1737 if (EQ (valcontents
, Qunbound
))
1738 SET_SYMBOL_VALUE (variable
, Qnil
);
1739 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1741 newval
= allocate_misc ();
1742 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1743 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1744 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1745 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1746 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1747 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1748 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1749 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1750 SET_SYMBOL_VALUE (variable
, newval
);
1754 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1756 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1757 BUFFER defaults to the current buffer. */)
1759 register Lisp_Object variable
, buffer
;
1761 Lisp_Object valcontents
;
1762 register struct buffer
*buf
;
1765 buf
= current_buffer
;
1768 CHECK_BUFFER (buffer
);
1769 buf
= XBUFFER (buffer
);
1772 CHECK_SYMBOL (variable
);
1773 variable
= indirect_variable (variable
);
1775 valcontents
= SYMBOL_VALUE (variable
);
1776 if (BUFFER_LOCAL_VALUEP (valcontents
)
1777 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1779 Lisp_Object tail
, elt
;
1781 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1784 if (EQ (variable
, XCAR (elt
)))
1788 if (BUFFER_OBJFWDP (valcontents
))
1790 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1791 int idx
= PER_BUFFER_IDX (offset
);
1792 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1798 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1800 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1801 More precisely, this means that setting the variable \(with `set' or`setq'),
1802 while it does not have a `let'-style binding that was made in BUFFER,
1803 will produce a buffer local binding. See Info node
1804 `(elisp)Creating Buffer-Local'.
1805 BUFFER defaults to the current buffer. */)
1807 register Lisp_Object variable
, buffer
;
1809 Lisp_Object valcontents
;
1810 register struct buffer
*buf
;
1813 buf
= current_buffer
;
1816 CHECK_BUFFER (buffer
);
1817 buf
= XBUFFER (buffer
);
1820 CHECK_SYMBOL (variable
);
1821 variable
= indirect_variable (variable
);
1823 valcontents
= SYMBOL_VALUE (variable
);
1825 /* This means that make-variable-buffer-local was done. */
1826 if (BUFFER_LOCAL_VALUEP (valcontents
))
1828 /* All these slots become local if they are set. */
1829 if (BUFFER_OBJFWDP (valcontents
))
1831 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1833 Lisp_Object tail
, elt
;
1834 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1837 if (EQ (variable
, XCAR (elt
)))
1844 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1846 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1847 If the current binding is buffer-local, the value is the current buffer.
1848 If the current binding is frame-local, the value is the selected frame.
1849 If the current binding is global (the default), the value is nil. */)
1851 register Lisp_Object variable
;
1853 Lisp_Object valcontents
;
1855 CHECK_SYMBOL (variable
);
1856 variable
= indirect_variable (variable
);
1858 /* Make sure the current binding is actually swapped in. */
1859 find_symbol_value (variable
);
1861 valcontents
= XSYMBOL (variable
)->value
;
1863 if (BUFFER_LOCAL_VALUEP (valcontents
)
1864 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1865 || BUFFER_OBJFWDP (valcontents
))
1867 /* For a local variable, record both the symbol and which
1868 buffer's or frame's value we are saving. */
1869 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1870 return Fcurrent_buffer ();
1871 else if (!BUFFER_OBJFWDP (valcontents
)
1872 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1873 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1879 /* This code is disabled now that we use the selected frame to return
1880 keyboard-local-values. */
1882 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1884 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1885 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1886 If SYMBOL is not a terminal-local variable, then return its normal
1887 value, like `symbol-value'.
1889 TERMINAL may be a terminal id, a frame, or nil (meaning the
1890 selected frame's terminal device). */)
1893 Lisp_Object terminal
;
1896 struct terminal
*t
= get_terminal (terminal
, 1);
1897 push_kboard (t
->kboard
);
1898 result
= Fsymbol_value (symbol
);
1903 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1904 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1905 If VARIABLE is not a terminal-local variable, then set its normal
1906 binding, like `set'.
1908 TERMINAL may be a terminal id, a frame, or nil (meaning the
1909 selected frame's terminal device). */)
1910 (symbol
, terminal
, value
)
1912 Lisp_Object terminal
;
1916 struct terminal
*t
= get_terminal (terminal
, 1);
1917 push_kboard (d
->kboard
);
1918 result
= Fset (symbol
, value
);
1924 /* Find the function at the end of a chain of symbol function indirections. */
1926 /* If OBJECT is a symbol, find the end of its function chain and
1927 return the value found there. If OBJECT is not a symbol, just
1928 return it. If there is a cycle in the function chain, signal a
1929 cyclic-function-indirection error.
1931 This is like Findirect_function, except that it doesn't signal an
1932 error if the chain ends up unbound. */
1934 indirect_function (object
)
1935 register Lisp_Object object
;
1937 Lisp_Object tortoise
, hare
;
1939 hare
= tortoise
= object
;
1943 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1945 hare
= XSYMBOL (hare
)->function
;
1946 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1948 hare
= XSYMBOL (hare
)->function
;
1950 tortoise
= XSYMBOL (tortoise
)->function
;
1952 if (EQ (hare
, tortoise
))
1953 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1959 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1960 doc
: /* Return the function at the end of OBJECT's function chain.
1961 If OBJECT is not a symbol, just return it. Otherwise, follow all
1962 function indirections to find the final function binding and return it.
1963 If the final symbol in the chain is unbound, signal a void-function error.
1964 Optional arg NOERROR non-nil means to return nil instead of signalling.
1965 Signal a cyclic-function-indirection error if there is a loop in the
1966 function chain of symbols. */)
1968 register Lisp_Object object
;
1969 Lisp_Object noerror
;
1973 /* Optimize for no indirection. */
1975 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1976 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1977 result
= indirect_function (result
);
1978 if (!EQ (result
, Qunbound
))
1982 Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1987 /* Extract and set vector and string elements */
1989 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1990 doc
: /* Return the element of ARRAY at index IDX.
1991 ARRAY may be a vector, a string, a char-table, a bool-vector,
1992 or a byte-code object. IDX starts at 0. */)
1994 register Lisp_Object array
;
1997 register int idxval
;
2000 idxval
= XINT (idx
);
2001 if (STRINGP (array
))
2005 if (idxval
< 0 || idxval
>= SCHARS (array
))
2006 args_out_of_range (array
, idx
);
2007 if (! STRING_MULTIBYTE (array
))
2008 return make_number ((unsigned char) SREF (array
, idxval
));
2009 idxval_byte
= string_char_to_byte (array
, idxval
);
2011 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
2012 SBYTES (array
) - idxval_byte
);
2013 return make_number (c
);
2015 else if (BOOL_VECTOR_P (array
))
2019 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2020 args_out_of_range (array
, idx
);
2022 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2023 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2025 else if (CHAR_TABLE_P (array
))
2032 args_out_of_range (array
, idx
);
2033 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2035 if (! SINGLE_BYTE_CHAR_P (idxval
))
2036 args_out_of_range (array
, idx
);
2037 /* For ASCII and 8-bit European characters, the element is
2038 stored in the top table. */
2039 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2043 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2044 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2045 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2046 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
2049 val
= XCHAR_TABLE (array
)->defalt
;
2050 while (NILP (val
)) /* Follow parents until we find some value. */
2052 array
= XCHAR_TABLE (array
)->parent
;
2055 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2057 val
= XCHAR_TABLE (array
)->defalt
;
2064 Lisp_Object sub_table
;
2065 Lisp_Object current_default
;
2067 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2068 if (code
[1] < 32) code
[1] = -1;
2069 else if (code
[2] < 32) code
[2] = -1;
2071 /* Here, the possible range of CODE[0] (== charset ID) is
2072 128..MAX_CHARSET. Since the top level char table contains
2073 data for multibyte characters after 256th element, we must
2074 increment CODE[0] by 128 to get a correct index. */
2076 code
[3] = -1; /* anchor */
2078 try_parent_char_table
:
2079 current_default
= XCHAR_TABLE (array
)->defalt
;
2081 for (i
= 0; code
[i
] >= 0; i
++)
2083 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2084 if (SUB_CHAR_TABLE_P (val
))
2087 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2088 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2093 val
= current_default
;
2096 array
= XCHAR_TABLE (array
)->parent
;
2098 goto try_parent_char_table
;
2103 /* Reaching here means IDXVAL is a generic character in
2104 which each character or a group has independent value.
2105 Essentially it's nonsense to get a value for such a
2106 generic character, but for backward compatibility, we try
2107 the default value and parent. */
2108 val
= current_default
;
2111 array
= XCHAR_TABLE (array
)->parent
;
2113 goto try_parent_char_table
;
2121 if (VECTORP (array
))
2122 size
= XVECTOR (array
)->size
;
2123 else if (COMPILEDP (array
))
2124 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2126 wrong_type_argument (Qarrayp
, array
);
2128 if (idxval
< 0 || idxval
>= size
)
2129 args_out_of_range (array
, idx
);
2130 return XVECTOR (array
)->contents
[idxval
];
2134 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2135 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2136 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2137 bool-vector. IDX starts at 0. */)
2138 (array
, idx
, newelt
)
2139 register Lisp_Object array
;
2140 Lisp_Object idx
, newelt
;
2142 register int idxval
;
2145 idxval
= XINT (idx
);
2146 CHECK_ARRAY (array
, Qarrayp
);
2147 CHECK_IMPURE (array
);
2149 if (VECTORP (array
))
2151 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2152 args_out_of_range (array
, idx
);
2153 XVECTOR (array
)->contents
[idxval
] = newelt
;
2155 else if (BOOL_VECTOR_P (array
))
2159 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2160 args_out_of_range (array
, idx
);
2162 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2164 if (! NILP (newelt
))
2165 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2167 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2168 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2170 else if (CHAR_TABLE_P (array
))
2173 args_out_of_range (array
, idx
);
2174 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2176 if (! SINGLE_BYTE_CHAR_P (idxval
))
2177 args_out_of_range (array
, idx
);
2178 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2185 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2186 if (code
[1] < 32) code
[1] = -1;
2187 else if (code
[2] < 32) code
[2] = -1;
2189 /* See the comment of the corresponding part in Faref. */
2191 code
[3] = -1; /* anchor */
2192 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2194 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2195 if (SUB_CHAR_TABLE_P (val
))
2201 /* VAL is a leaf. Create a sub char table with the
2202 initial value VAL and look into it. */
2204 temp
= make_sub_char_table (val
);
2205 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2209 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2212 else if (STRING_MULTIBYTE (array
))
2214 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2215 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2217 if (idxval
< 0 || idxval
>= SCHARS (array
))
2218 args_out_of_range (array
, idx
);
2219 CHECK_NUMBER (newelt
);
2221 nbytes
= SBYTES (array
);
2223 idxval_byte
= string_char_to_byte (array
, idxval
);
2224 p1
= SDATA (array
) + idxval_byte
;
2225 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2226 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2227 if (prev_bytes
!= new_bytes
)
2229 /* We must relocate the string data. */
2230 int nchars
= SCHARS (array
);
2234 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2235 bcopy (SDATA (array
), str
, nbytes
);
2236 allocate_string_data (XSTRING (array
), nchars
,
2237 nbytes
+ new_bytes
- prev_bytes
);
2238 bcopy (str
, SDATA (array
), idxval_byte
);
2239 p1
= SDATA (array
) + idxval_byte
;
2240 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2241 nbytes
- (idxval_byte
+ prev_bytes
));
2243 clear_string_char_byte_cache ();
2250 if (idxval
< 0 || idxval
>= SCHARS (array
))
2251 args_out_of_range (array
, idx
);
2252 CHECK_NUMBER (newelt
);
2254 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2255 SSET (array
, idxval
, XINT (newelt
));
2258 /* We must relocate the string data while converting it to
2260 int idxval_byte
, prev_bytes
, new_bytes
;
2261 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2262 unsigned char *origstr
= SDATA (array
), *str
;
2266 nchars
= SCHARS (array
);
2267 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2268 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2270 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2271 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2272 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2274 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2275 allocate_string_data (XSTRING (array
), nchars
,
2276 nbytes
+ new_bytes
- prev_bytes
);
2277 bcopy (str
, SDATA (array
), idxval_byte
);
2278 p1
= SDATA (array
) + idxval_byte
;
2281 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2282 nbytes
- (idxval_byte
+ prev_bytes
));
2284 clear_string_char_byte_cache ();
2291 /* Arithmetic functions */
2293 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2296 arithcompare (num1
, num2
, comparison
)
2297 Lisp_Object num1
, num2
;
2298 enum comparison comparison
;
2300 double f1
= 0, f2
= 0;
2303 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2304 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2306 if (FLOATP (num1
) || FLOATP (num2
))
2309 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2310 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2316 if (floatp
? f1
== f2
: XINT (num1
) == 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
))
2350 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2351 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2353 register Lisp_Object num1
, num2
;
2355 return arithcompare (num1
, num2
, equal
);
2358 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2359 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2361 register Lisp_Object num1
, num2
;
2363 return arithcompare (num1
, num2
, less
);
2366 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2367 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2369 register Lisp_Object num1
, num2
;
2371 return arithcompare (num1
, num2
, grtr
);
2374 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2375 doc
: /* Return t if first arg is less than or equal to second arg.
2376 Both must be numbers or markers. */)
2378 register Lisp_Object num1
, num2
;
2380 return arithcompare (num1
, num2
, less_or_equal
);
2383 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2384 doc
: /* Return t if first arg is greater than or equal to second arg.
2385 Both must be numbers or markers. */)
2387 register Lisp_Object num1
, num2
;
2389 return arithcompare (num1
, num2
, grtr_or_equal
);
2392 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2393 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2395 register Lisp_Object num1
, num2
;
2397 return arithcompare (num1
, num2
, notequal
);
2400 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2401 doc
: /* Return t if NUMBER is zero. */)
2403 register Lisp_Object number
;
2405 CHECK_NUMBER_OR_FLOAT (number
);
2407 if (FLOATP (number
))
2409 if (XFLOAT_DATA (number
) == 0.0)
2419 /* Convert between long values and pairs of Lisp integers. */
2425 unsigned long top
= i
>> 16;
2426 unsigned int bot
= i
& 0xFFFF;
2428 return make_number (bot
);
2429 if (top
== (unsigned long)-1 >> 16)
2430 return Fcons (make_number (-1), make_number (bot
));
2431 return Fcons (make_number (top
), make_number (bot
));
2438 Lisp_Object top
, bot
;
2445 return ((XINT (top
) << 16) | XINT (bot
));
2448 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2449 doc
: /* Return the decimal representation of NUMBER as a string.
2450 Uses a minus sign if negative.
2451 NUMBER may be an integer or a floating point number. */)
2455 char buffer
[VALBITS
];
2457 CHECK_NUMBER_OR_FLOAT (number
);
2459 if (FLOATP (number
))
2461 char pigbuf
[350]; /* see comments in float_to_string */
2463 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2464 return build_string (pigbuf
);
2467 if (sizeof (int) == sizeof (EMACS_INT
))
2468 sprintf (buffer
, "%d", XINT (number
));
2469 else if (sizeof (long) == sizeof (EMACS_INT
))
2470 sprintf (buffer
, "%ld", (long) XINT (number
));
2473 return build_string (buffer
);
2477 digit_to_number (character
, base
)
2478 int character
, base
;
2482 if (character
>= '0' && character
<= '9')
2483 digit
= character
- '0';
2484 else if (character
>= 'a' && character
<= 'z')
2485 digit
= character
- 'a' + 10;
2486 else if (character
>= 'A' && character
<= 'Z')
2487 digit
= character
- 'A' + 10;
2497 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2498 doc
: /* Parse STRING as a decimal number and return the number.
2499 This parses both integers and floating point numbers.
2500 It ignores leading spaces and tabs.
2502 If BASE, interpret STRING as a number in that base. If BASE isn't
2503 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2504 If the base used is not 10, floating point is not recognized. */)
2506 register Lisp_Object string
, base
;
2508 register unsigned char *p
;
2513 CHECK_STRING (string
);
2519 CHECK_NUMBER (base
);
2521 if (b
< 2 || b
> 16)
2522 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2525 /* Skip any whitespace at the front of the number. Some versions of
2526 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2528 while (*p
== ' ' || *p
== '\t')
2539 if (isfloat_string (p
) && b
== 10)
2540 val
= make_float (sign
* atof (p
));
2547 int digit
= digit_to_number (*p
++, b
);
2553 val
= make_fixnum_or_float (sign
* v
);
2573 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2574 int, Lisp_Object
*));
2575 extern Lisp_Object
fmod_float ();
2578 arith_driver (code
, nargs
, args
)
2581 register Lisp_Object
*args
;
2583 register Lisp_Object val
;
2584 register int argnum
;
2585 register EMACS_INT accum
= 0;
2586 register EMACS_INT next
;
2588 switch (SWITCH_ENUM_CAST (code
))
2606 for (argnum
= 0; argnum
< nargs
; argnum
++)
2608 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2610 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2613 return float_arith_driver ((double) accum
, argnum
, code
,
2616 next
= XINT (args
[argnum
]);
2617 switch (SWITCH_ENUM_CAST (code
))
2623 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2634 Fsignal (Qarith_error
, Qnil
);
2648 if (!argnum
|| next
> accum
)
2652 if (!argnum
|| next
< accum
)
2658 XSETINT (val
, accum
);
2663 #define isnan(x) ((x) != (x))
2666 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2668 register int argnum
;
2671 register Lisp_Object
*args
;
2673 register Lisp_Object val
;
2676 for (; argnum
< nargs
; argnum
++)
2678 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2679 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2683 next
= XFLOAT_DATA (val
);
2687 args
[argnum
] = val
; /* runs into a compiler bug. */
2688 next
= XINT (args
[argnum
]);
2690 switch (SWITCH_ENUM_CAST (code
))
2696 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2706 if (! IEEE_FLOATING_POINT
&& next
== 0)
2707 Fsignal (Qarith_error
, Qnil
);
2714 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2716 if (!argnum
|| isnan (next
) || next
> accum
)
2720 if (!argnum
|| isnan (next
) || next
< accum
)
2726 return make_float (accum
);
2730 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2731 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2732 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2737 return arith_driver (Aadd
, nargs
, args
);
2740 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2741 doc
: /* Negate number or subtract numbers or markers and return the result.
2742 With one arg, negates it. With more than one arg,
2743 subtracts all but the first from the first.
2744 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2749 return arith_driver (Asub
, nargs
, args
);
2752 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2753 doc
: /* Return product of any number of arguments, which are numbers or markers.
2754 usage: (* &rest NUMBERS-OR-MARKERS) */)
2759 return arith_driver (Amult
, nargs
, args
);
2762 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2763 doc
: /* Return first argument divided by all the remaining arguments.
2764 The arguments must be numbers or markers.
2765 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2771 for (argnum
= 2; argnum
< nargs
; argnum
++)
2772 if (FLOATP (args
[argnum
]))
2773 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2774 return arith_driver (Adiv
, nargs
, args
);
2777 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2778 doc
: /* Return remainder of X divided by Y.
2779 Both must be integers or markers. */)
2781 register Lisp_Object x
, y
;
2785 CHECK_NUMBER_COERCE_MARKER (x
);
2786 CHECK_NUMBER_COERCE_MARKER (y
);
2788 if (XFASTINT (y
) == 0)
2789 Fsignal (Qarith_error
, Qnil
);
2791 XSETINT (val
, XINT (x
) % XINT (y
));
2805 /* If the magnitude of the result exceeds that of the divisor, or
2806 the sign of the result does not agree with that of the dividend,
2807 iterate with the reduced value. This does not yield a
2808 particularly accurate result, but at least it will be in the
2809 range promised by fmod. */
2811 r
-= f2
* floor (r
/ f2
);
2812 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2816 #endif /* ! HAVE_FMOD */
2818 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2819 doc
: /* Return X modulo Y.
2820 The result falls between zero (inclusive) and Y (exclusive).
2821 Both X and Y must be numbers or markers. */)
2823 register Lisp_Object x
, y
;
2828 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2829 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2831 if (FLOATP (x
) || FLOATP (y
))
2832 return fmod_float (x
, y
);
2838 Fsignal (Qarith_error
, Qnil
);
2842 /* If the "remainder" comes out with the wrong sign, fix it. */
2843 if (i2
< 0 ? i1
> 0 : i1
< 0)
2850 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2851 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2852 The value is always a number; markers are converted to numbers.
2853 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2858 return arith_driver (Amax
, nargs
, args
);
2861 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2862 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2863 The value is always a number; markers are converted to numbers.
2864 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2869 return arith_driver (Amin
, nargs
, args
);
2872 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2873 doc
: /* Return bitwise-and of all the arguments.
2874 Arguments may be integers, or markers converted to integers.
2875 usage: (logand &rest INTS-OR-MARKERS) */)
2880 return arith_driver (Alogand
, nargs
, args
);
2883 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2884 doc
: /* Return bitwise-or of all the arguments.
2885 Arguments may be integers, or markers converted to integers.
2886 usage: (logior &rest INTS-OR-MARKERS) */)
2891 return arith_driver (Alogior
, nargs
, args
);
2894 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2895 doc
: /* Return bitwise-exclusive-or of all the arguments.
2896 Arguments may be integers, or markers converted to integers.
2897 usage: (logxor &rest INTS-OR-MARKERS) */)
2902 return arith_driver (Alogxor
, nargs
, args
);
2905 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2906 doc
: /* Return VALUE with its bits shifted left by COUNT.
2907 If COUNT is negative, shifting is actually to the right.
2908 In this case, the sign bit is duplicated. */)
2910 register Lisp_Object value
, count
;
2912 register Lisp_Object val
;
2914 CHECK_NUMBER (value
);
2915 CHECK_NUMBER (count
);
2917 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2919 else if (XINT (count
) > 0)
2920 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2921 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2922 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2924 XSETINT (val
, XINT (value
) >> -XINT (count
));
2928 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2929 doc
: /* Return VALUE with its bits shifted left by COUNT.
2930 If COUNT is negative, shifting is actually to the right.
2931 In this case, zeros are shifted in on the left. */)
2933 register Lisp_Object value
, count
;
2935 register Lisp_Object val
;
2937 CHECK_NUMBER (value
);
2938 CHECK_NUMBER (count
);
2940 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2942 else if (XINT (count
) > 0)
2943 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2944 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2947 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2951 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2952 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2953 Markers are converted to integers. */)
2955 register Lisp_Object number
;
2957 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2959 if (FLOATP (number
))
2960 return (make_float (1.0 + XFLOAT_DATA (number
)));
2962 XSETINT (number
, XINT (number
) + 1);
2966 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2967 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2968 Markers are converted to integers. */)
2970 register Lisp_Object number
;
2972 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2974 if (FLOATP (number
))
2975 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2977 XSETINT (number
, XINT (number
) - 1);
2981 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2982 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2984 register Lisp_Object number
;
2986 CHECK_NUMBER (number
);
2987 XSETINT (number
, ~XINT (number
));
2991 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2992 doc
: /* Return the byteorder for the machine.
2993 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2994 lowercase l) for small endian machines. */)
2997 unsigned i
= 0x04030201;
2998 int order
= *(char *)&i
== 1 ? 108 : 66;
3000 return make_number (order
);
3008 Lisp_Object error_tail
, arith_tail
;
3010 Qquote
= intern ("quote");
3011 Qlambda
= intern ("lambda");
3012 Qsubr
= intern ("subr");
3013 Qerror_conditions
= intern ("error-conditions");
3014 Qerror_message
= intern ("error-message");
3015 Qtop_level
= intern ("top-level");
3017 Qerror
= intern ("error");
3018 Qquit
= intern ("quit");
3019 Qwrong_type_argument
= intern ("wrong-type-argument");
3020 Qargs_out_of_range
= intern ("args-out-of-range");
3021 Qvoid_function
= intern ("void-function");
3022 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
3023 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
3024 Qvoid_variable
= intern ("void-variable");
3025 Qsetting_constant
= intern ("setting-constant");
3026 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
3028 Qinvalid_function
= intern ("invalid-function");
3029 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
3030 Qno_catch
= intern ("no-catch");
3031 Qend_of_file
= intern ("end-of-file");
3032 Qarith_error
= intern ("arith-error");
3033 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
3034 Qend_of_buffer
= intern ("end-of-buffer");
3035 Qbuffer_read_only
= intern ("buffer-read-only");
3036 Qtext_read_only
= intern ("text-read-only");
3037 Qmark_inactive
= intern ("mark-inactive");
3039 Qlistp
= intern ("listp");
3040 Qconsp
= intern ("consp");
3041 Qsymbolp
= intern ("symbolp");
3042 Qkeywordp
= intern ("keywordp");
3043 Qintegerp
= intern ("integerp");
3044 Qnatnump
= intern ("natnump");
3045 Qwholenump
= intern ("wholenump");
3046 Qstringp
= intern ("stringp");
3047 Qarrayp
= intern ("arrayp");
3048 Qsequencep
= intern ("sequencep");
3049 Qbufferp
= intern ("bufferp");
3050 Qvectorp
= intern ("vectorp");
3051 Qchar_or_string_p
= intern ("char-or-string-p");
3052 Qmarkerp
= intern ("markerp");
3053 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
3054 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
3055 Qboundp
= intern ("boundp");
3056 Qfboundp
= intern ("fboundp");
3058 Qfloatp
= intern ("floatp");
3059 Qnumberp
= intern ("numberp");
3060 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3062 Qchar_table_p
= intern ("char-table-p");
3063 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3065 Qsubrp
= intern ("subrp");
3066 Qunevalled
= intern ("unevalled");
3067 Qmany
= intern ("many");
3069 Qcdr
= intern ("cdr");
3071 /* Handle automatic advice activation */
3072 Qad_advice_info
= intern ("ad-advice-info");
3073 Qad_activate_internal
= intern ("ad-activate-internal");
3075 error_tail
= Fcons (Qerror
, Qnil
);
3077 /* ERROR is used as a signaler for random errors for which nothing else is right */
3079 Fput (Qerror
, Qerror_conditions
,
3081 Fput (Qerror
, Qerror_message
,
3082 build_string ("error"));
3084 Fput (Qquit
, Qerror_conditions
,
3085 Fcons (Qquit
, Qnil
));
3086 Fput (Qquit
, Qerror_message
,
3087 build_string ("Quit"));
3089 Fput (Qwrong_type_argument
, Qerror_conditions
,
3090 Fcons (Qwrong_type_argument
, error_tail
));
3091 Fput (Qwrong_type_argument
, Qerror_message
,
3092 build_string ("Wrong type argument"));
3094 Fput (Qargs_out_of_range
, Qerror_conditions
,
3095 Fcons (Qargs_out_of_range
, error_tail
));
3096 Fput (Qargs_out_of_range
, Qerror_message
,
3097 build_string ("Args out of range"));
3099 Fput (Qvoid_function
, Qerror_conditions
,
3100 Fcons (Qvoid_function
, error_tail
));
3101 Fput (Qvoid_function
, Qerror_message
,
3102 build_string ("Symbol's function definition is void"));
3104 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3105 Fcons (Qcyclic_function_indirection
, error_tail
));
3106 Fput (Qcyclic_function_indirection
, Qerror_message
,
3107 build_string ("Symbol's chain of function indirections contains a loop"));
3109 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3110 Fcons (Qcyclic_variable_indirection
, error_tail
));
3111 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3112 build_string ("Symbol's chain of variable indirections contains a loop"));
3114 Qcircular_list
= intern ("circular-list");
3115 staticpro (&Qcircular_list
);
3116 Fput (Qcircular_list
, Qerror_conditions
,
3117 Fcons (Qcircular_list
, error_tail
));
3118 Fput (Qcircular_list
, Qerror_message
,
3119 build_string ("List contains a loop"));
3121 Fput (Qvoid_variable
, Qerror_conditions
,
3122 Fcons (Qvoid_variable
, error_tail
));
3123 Fput (Qvoid_variable
, Qerror_message
,
3124 build_string ("Symbol's value as variable is void"));
3126 Fput (Qsetting_constant
, Qerror_conditions
,
3127 Fcons (Qsetting_constant
, error_tail
));
3128 Fput (Qsetting_constant
, Qerror_message
,
3129 build_string ("Attempt to set a constant symbol"));
3131 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3132 Fcons (Qinvalid_read_syntax
, error_tail
));
3133 Fput (Qinvalid_read_syntax
, Qerror_message
,
3134 build_string ("Invalid read syntax"));
3136 Fput (Qinvalid_function
, Qerror_conditions
,
3137 Fcons (Qinvalid_function
, error_tail
));
3138 Fput (Qinvalid_function
, Qerror_message
,
3139 build_string ("Invalid function"));
3141 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3142 Fcons (Qwrong_number_of_arguments
, error_tail
));
3143 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3144 build_string ("Wrong number of arguments"));
3146 Fput (Qno_catch
, Qerror_conditions
,
3147 Fcons (Qno_catch
, error_tail
));
3148 Fput (Qno_catch
, Qerror_message
,
3149 build_string ("No catch for tag"));
3151 Fput (Qend_of_file
, Qerror_conditions
,
3152 Fcons (Qend_of_file
, error_tail
));
3153 Fput (Qend_of_file
, Qerror_message
,
3154 build_string ("End of file during parsing"));
3156 arith_tail
= Fcons (Qarith_error
, error_tail
);
3157 Fput (Qarith_error
, Qerror_conditions
,
3159 Fput (Qarith_error
, Qerror_message
,
3160 build_string ("Arithmetic error"));
3162 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3163 Fcons (Qbeginning_of_buffer
, error_tail
));
3164 Fput (Qbeginning_of_buffer
, Qerror_message
,
3165 build_string ("Beginning of buffer"));
3167 Fput (Qend_of_buffer
, Qerror_conditions
,
3168 Fcons (Qend_of_buffer
, error_tail
));
3169 Fput (Qend_of_buffer
, Qerror_message
,
3170 build_string ("End of buffer"));
3172 Fput (Qbuffer_read_only
, Qerror_conditions
,
3173 Fcons (Qbuffer_read_only
, error_tail
));
3174 Fput (Qbuffer_read_only
, Qerror_message
,
3175 build_string ("Buffer is read-only"));
3177 Fput (Qtext_read_only
, Qerror_conditions
,
3178 Fcons (Qtext_read_only
, error_tail
));
3179 Fput (Qtext_read_only
, Qerror_message
,
3180 build_string ("Text is read-only"));
3182 Qrange_error
= intern ("range-error");
3183 Qdomain_error
= intern ("domain-error");
3184 Qsingularity_error
= intern ("singularity-error");
3185 Qoverflow_error
= intern ("overflow-error");
3186 Qunderflow_error
= intern ("underflow-error");
3188 Fput (Qdomain_error
, Qerror_conditions
,
3189 Fcons (Qdomain_error
, arith_tail
));
3190 Fput (Qdomain_error
, Qerror_message
,
3191 build_string ("Arithmetic domain error"));
3193 Fput (Qrange_error
, Qerror_conditions
,
3194 Fcons (Qrange_error
, arith_tail
));
3195 Fput (Qrange_error
, Qerror_message
,
3196 build_string ("Arithmetic range error"));
3198 Fput (Qsingularity_error
, Qerror_conditions
,
3199 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3200 Fput (Qsingularity_error
, Qerror_message
,
3201 build_string ("Arithmetic singularity error"));
3203 Fput (Qoverflow_error
, Qerror_conditions
,
3204 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3205 Fput (Qoverflow_error
, Qerror_message
,
3206 build_string ("Arithmetic overflow error"));
3208 Fput (Qunderflow_error
, Qerror_conditions
,
3209 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3210 Fput (Qunderflow_error
, Qerror_message
,
3211 build_string ("Arithmetic underflow error"));
3213 staticpro (&Qrange_error
);
3214 staticpro (&Qdomain_error
);
3215 staticpro (&Qsingularity_error
);
3216 staticpro (&Qoverflow_error
);
3217 staticpro (&Qunderflow_error
);
3221 staticpro (&Qquote
);
3222 staticpro (&Qlambda
);
3224 staticpro (&Qunbound
);
3225 staticpro (&Qerror_conditions
);
3226 staticpro (&Qerror_message
);
3227 staticpro (&Qtop_level
);
3229 staticpro (&Qerror
);
3231 staticpro (&Qwrong_type_argument
);
3232 staticpro (&Qargs_out_of_range
);
3233 staticpro (&Qvoid_function
);
3234 staticpro (&Qcyclic_function_indirection
);
3235 staticpro (&Qcyclic_variable_indirection
);
3236 staticpro (&Qvoid_variable
);
3237 staticpro (&Qsetting_constant
);
3238 staticpro (&Qinvalid_read_syntax
);
3239 staticpro (&Qwrong_number_of_arguments
);
3240 staticpro (&Qinvalid_function
);
3241 staticpro (&Qno_catch
);
3242 staticpro (&Qend_of_file
);
3243 staticpro (&Qarith_error
);
3244 staticpro (&Qbeginning_of_buffer
);
3245 staticpro (&Qend_of_buffer
);
3246 staticpro (&Qbuffer_read_only
);
3247 staticpro (&Qtext_read_only
);
3248 staticpro (&Qmark_inactive
);
3250 staticpro (&Qlistp
);
3251 staticpro (&Qconsp
);
3252 staticpro (&Qsymbolp
);
3253 staticpro (&Qkeywordp
);
3254 staticpro (&Qintegerp
);
3255 staticpro (&Qnatnump
);
3256 staticpro (&Qwholenump
);
3257 staticpro (&Qstringp
);
3258 staticpro (&Qarrayp
);
3259 staticpro (&Qsequencep
);
3260 staticpro (&Qbufferp
);
3261 staticpro (&Qvectorp
);
3262 staticpro (&Qchar_or_string_p
);
3263 staticpro (&Qmarkerp
);
3264 staticpro (&Qbuffer_or_string_p
);
3265 staticpro (&Qinteger_or_marker_p
);
3266 staticpro (&Qfloatp
);
3267 staticpro (&Qnumberp
);
3268 staticpro (&Qnumber_or_marker_p
);
3269 staticpro (&Qchar_table_p
);
3270 staticpro (&Qvector_or_char_table_p
);
3271 staticpro (&Qsubrp
);
3273 staticpro (&Qunevalled
);
3275 staticpro (&Qboundp
);
3276 staticpro (&Qfboundp
);
3278 staticpro (&Qad_advice_info
);
3279 staticpro (&Qad_activate_internal
);
3281 /* Types that type-of returns. */
3282 Qinteger
= intern ("integer");
3283 Qsymbol
= intern ("symbol");
3284 Qstring
= intern ("string");
3285 Qcons
= intern ("cons");
3286 Qmarker
= intern ("marker");
3287 Qoverlay
= intern ("overlay");
3288 Qfloat
= intern ("float");
3289 Qwindow_configuration
= intern ("window-configuration");
3290 Qprocess
= intern ("process");
3291 Qwindow
= intern ("window");
3292 /* Qsubr = intern ("subr"); */
3293 Qcompiled_function
= intern ("compiled-function");
3294 Qbuffer
= intern ("buffer");
3295 Qframe
= intern ("frame");
3296 Qvector
= intern ("vector");
3297 Qchar_table
= intern ("char-table");
3298 Qbool_vector
= intern ("bool-vector");
3299 Qhash_table
= intern ("hash-table");
3301 staticpro (&Qinteger
);
3302 staticpro (&Qsymbol
);
3303 staticpro (&Qstring
);
3305 staticpro (&Qmarker
);
3306 staticpro (&Qoverlay
);
3307 staticpro (&Qfloat
);
3308 staticpro (&Qwindow_configuration
);
3309 staticpro (&Qprocess
);
3310 staticpro (&Qwindow
);
3311 /* staticpro (&Qsubr); */
3312 staticpro (&Qcompiled_function
);
3313 staticpro (&Qbuffer
);
3314 staticpro (&Qframe
);
3315 staticpro (&Qvector
);
3316 staticpro (&Qchar_table
);
3317 staticpro (&Qbool_vector
);
3318 staticpro (&Qhash_table
);
3320 defsubr (&Sindirect_variable
);
3321 defsubr (&Sinteractive_form
);
3324 defsubr (&Stype_of
);
3329 defsubr (&Sintegerp
);
3330 defsubr (&Sinteger_or_marker_p
);
3331 defsubr (&Snumberp
);
3332 defsubr (&Snumber_or_marker_p
);
3334 defsubr (&Snatnump
);
3335 defsubr (&Ssymbolp
);
3336 defsubr (&Skeywordp
);
3337 defsubr (&Sstringp
);
3338 defsubr (&Smultibyte_string_p
);
3339 defsubr (&Svectorp
);
3340 defsubr (&Schar_table_p
);
3341 defsubr (&Svector_or_char_table_p
);
3342 defsubr (&Sbool_vector_p
);
3344 defsubr (&Ssequencep
);
3345 defsubr (&Sbufferp
);
3346 defsubr (&Smarkerp
);
3348 defsubr (&Sbyte_code_function_p
);
3349 defsubr (&Schar_or_string_p
);
3352 defsubr (&Scar_safe
);
3353 defsubr (&Scdr_safe
);
3356 defsubr (&Ssymbol_function
);
3357 defsubr (&Sindirect_function
);
3358 defsubr (&Ssymbol_plist
);
3359 defsubr (&Ssymbol_name
);
3360 defsubr (&Smakunbound
);
3361 defsubr (&Sfmakunbound
);
3363 defsubr (&Sfboundp
);
3365 defsubr (&Sdefalias
);
3366 defsubr (&Ssetplist
);
3367 defsubr (&Ssymbol_value
);
3369 defsubr (&Sdefault_boundp
);
3370 defsubr (&Sdefault_value
);
3371 defsubr (&Sset_default
);
3372 defsubr (&Ssetq_default
);
3373 defsubr (&Smake_variable_buffer_local
);
3374 defsubr (&Smake_local_variable
);
3375 defsubr (&Skill_local_variable
);
3376 defsubr (&Smake_variable_frame_local
);
3377 defsubr (&Slocal_variable_p
);
3378 defsubr (&Slocal_variable_if_set_p
);
3379 defsubr (&Svariable_binding_locus
);
3380 #if 0 /* XXX Remove this. --lorentey */
3381 defsubr (&Sterminal_local_value
);
3382 defsubr (&Sset_terminal_local_value
);
3386 defsubr (&Snumber_to_string
);
3387 defsubr (&Sstring_to_number
);
3388 defsubr (&Seqlsign
);
3411 defsubr (&Sbyteorder
);
3412 defsubr (&Ssubr_arity
);
3413 defsubr (&Ssubr_name
);
3415 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3417 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3418 doc
: /* The largest value that is representable in a Lisp integer. */);
3419 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3421 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3422 doc
: /* The smallest value that is representable in a Lisp integer. */);
3423 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3430 #if defined(USG) && !defined(POSIX_SIGNALS)
3431 /* USG systems forget handlers when they are used;
3432 must reestablish each time */
3433 signal (signo
, arith_error
);
3436 /* VMS systems are like USG. */
3437 signal (signo
, arith_error
);
3441 #else /* not BSD4_1 */
3442 sigsetmask (SIGEMPTYMASK
);
3443 #endif /* not BSD4_1 */
3445 SIGNAL_THREAD_CHECK (signo
);
3446 Fsignal (Qarith_error
, Qnil
);
3452 /* Don't do this if just dumping out.
3453 We don't want to call `signal' in this case
3454 so that we don't have trouble with dumping
3455 signal-delivering routines in an inconsistent state. */
3459 #endif /* CANNOT_DUMP */
3460 signal (SIGFPE
, arith_error
);
3463 signal (SIGEMT
, arith_error
);
3467 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3468 (do not change this comment) */