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"
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
48 /* Work around a problem that happens because math.h on hpux 7
49 defines two static variables--which, in Emacs, are not really static,
50 because `static' is defined as nothing. The problem is that they are
51 here, in floatfns.c, and in lread.c.
52 These macros prevent the name conflict. */
53 #if defined (HPUX) && !defined (HPUX8)
54 #define _MAXLDBL data_c_maxldbl
55 #define _NMAXLDBL data_c_nmaxldbl
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
69 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
70 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
71 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
72 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
73 Lisp_Object Qtext_read_only
;
75 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
76 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
77 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
78 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
79 Lisp_Object Qboundp
, Qfboundp
;
80 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
83 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
85 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
86 Lisp_Object Qoverflow_error
, Qunderflow_error
;
89 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
92 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
93 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
95 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
96 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
97 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
99 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
101 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
105 circular_list_error (list
)
108 Fsignal (Qcircular_list
, list
);
113 wrong_type_argument (predicate
, value
)
114 register Lisp_Object predicate
, value
;
116 /* If VALUE is not even a valid Lisp object, abort here
117 where we can get a backtrace showing where it came from. */
118 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
121 Fsignal (Qwrong_type_argument
, list2 (predicate
, value
));
123 /* This function is marked as NO_RETURN, gcc would warn if it has a
124 return statement or if falls off the function. Other compilers
125 warn if no return statement is present. */
136 error ("Attempt to modify read-only object");
140 args_out_of_range (a1
, a2
)
144 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
148 args_out_of_range_3 (a1
, a2
, a3
)
149 Lisp_Object a1
, a2
, a3
;
152 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
155 /* On some machines, XINT needs a temporary location.
156 Here it is, in case it is needed. */
158 int sign_extend_temp
;
160 /* On a few machines, XINT can only be done by calling this. */
163 sign_extend_lisp_int (num
)
166 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
167 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
169 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
172 /* Data type predicates */
174 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
175 doc
: /* Return t if the two args are the same Lisp object. */)
177 Lisp_Object obj1
, obj2
;
184 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
185 doc
: /* Return t if OBJECT is nil. */)
194 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
195 doc
: /* Return a symbol representing the type of OBJECT.
196 The symbol returned names the object's basic type;
197 for example, (type-of 1) returns `integer'. */)
201 switch (XGCTYPE (object
))
216 switch (XMISCTYPE (object
))
218 case Lisp_Misc_Marker
:
220 case Lisp_Misc_Overlay
:
222 case Lisp_Misc_Float
:
227 case Lisp_Vectorlike
:
228 if (GC_WINDOW_CONFIGURATIONP (object
))
229 return Qwindow_configuration
;
230 if (GC_PROCESSP (object
))
232 if (GC_WINDOWP (object
))
234 if (GC_SUBRP (object
))
236 if (GC_COMPILEDP (object
))
237 return Qcompiled_function
;
238 if (GC_BUFFERP (object
))
240 if (GC_CHAR_TABLE_P (object
))
242 if (GC_BOOL_VECTOR_P (object
))
244 if (GC_FRAMEP (object
))
246 if (GC_HASH_TABLE_P (object
))
258 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
259 doc
: /* Return t if OBJECT is a cons cell. */)
268 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
269 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
278 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
279 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
280 Otherwise, return nil. */)
284 if (CONSP (object
) || NILP (object
))
289 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
290 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
294 if (CONSP (object
) || NILP (object
))
299 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
300 doc
: /* Return t if OBJECT is a symbol. */)
304 if (SYMBOLP (object
))
309 /* Define this in C to avoid unnecessarily consing up the symbol
311 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
312 doc
: /* Return t if OBJECT is a keyword.
313 This means that it is a symbol with a print name beginning with `:'
314 interned in the initial obarray. */)
319 && SREF (SYMBOL_NAME (object
), 0) == ':'
320 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
325 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
326 doc
: /* Return t if OBJECT is a vector. */)
330 if (VECTORP (object
))
335 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
336 doc
: /* Return t if OBJECT is a string. */)
340 if (STRINGP (object
))
345 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
347 doc
: /* Return t if OBJECT is a multibyte string. */)
351 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
356 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
357 doc
: /* Return t if OBJECT is a char-table. */)
361 if (CHAR_TABLE_P (object
))
366 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
367 Svector_or_char_table_p
, 1, 1, 0,
368 doc
: /* Return t if OBJECT is a char-table or vector. */)
372 if (VECTORP (object
) || CHAR_TABLE_P (object
))
377 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is a bool-vector. */)
382 if (BOOL_VECTOR_P (object
))
387 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
388 doc
: /* Return t if OBJECT is an array (string or vector). */)
397 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is a sequence (list or array). */)
400 register Lisp_Object object
;
402 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
407 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is an editor buffer. */)
412 if (BUFFERP (object
))
417 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
422 if (MARKERP (object
))
427 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
428 doc
: /* Return t if OBJECT is a built-in function. */)
437 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
439 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
443 if (COMPILEDP (object
))
448 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
449 doc
: /* Return t if OBJECT is a character (an integer) or a string. */)
451 register Lisp_Object object
;
453 if (INTEGERP (object
) || STRINGP (object
))
458 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
459 doc
: /* Return t if OBJECT is an integer. */)
463 if (INTEGERP (object
))
468 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
469 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
471 register Lisp_Object object
;
473 if (MARKERP (object
) || INTEGERP (object
))
478 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
479 doc
: /* Return t if OBJECT is a nonnegative integer. */)
483 if (NATNUMP (object
))
488 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
489 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
493 if (NUMBERP (object
))
499 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
500 Snumber_or_marker_p
, 1, 1, 0,
501 doc
: /* Return t if OBJECT is a number or a marker. */)
505 if (NUMBERP (object
) || MARKERP (object
))
510 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
511 doc
: /* Return t if OBJECT is a floating point number. */)
521 /* Extract and set components of lists */
523 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
524 doc
: /* Return the car of LIST. If arg is nil, return nil.
525 Error if arg is not nil and not a cons cell. See also `car-safe'.
527 See Info node `(elisp)Cons Cells' for a discussion of related basic
528 Lisp concepts such as car, cdr, cons cell and list. */)
530 register Lisp_Object list
;
535 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
536 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
540 return CAR_SAFE (object
);
543 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
544 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
545 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
547 See Info node `(elisp)Cons Cells' for a discussion of related basic
548 Lisp concepts such as cdr, car, cons cell and list. */)
550 register Lisp_Object list
;
555 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
556 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
560 return CDR_SAFE (object
);
563 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
564 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
566 register Lisp_Object cell
, newcar
;
570 XSETCAR (cell
, newcar
);
574 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
575 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
577 register Lisp_Object cell
, newcdr
;
581 XSETCDR (cell
, newcdr
);
585 /* Extract and set components of symbols */
587 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
588 doc
: /* Return t if SYMBOL's value is not void. */)
590 register Lisp_Object symbol
;
592 Lisp_Object valcontents
;
593 CHECK_SYMBOL (symbol
);
595 valcontents
= SYMBOL_VALUE (symbol
);
597 if (BUFFER_LOCAL_VALUEP (valcontents
)
598 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
599 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
601 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
604 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
605 doc
: /* Return t if SYMBOL's function definition is not void. */)
607 register Lisp_Object symbol
;
609 CHECK_SYMBOL (symbol
);
610 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
613 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
614 doc
: /* Make SYMBOL's value be void.
617 register Lisp_Object symbol
;
619 CHECK_SYMBOL (symbol
);
620 if (XSYMBOL (symbol
)->constant
)
621 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
622 Fset (symbol
, Qunbound
);
626 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
627 doc
: /* Make SYMBOL's function definition be void.
630 register Lisp_Object symbol
;
632 CHECK_SYMBOL (symbol
);
633 if (NILP (symbol
) || EQ (symbol
, Qt
))
634 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
635 XSYMBOL (symbol
)->function
= Qunbound
;
639 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
640 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
);
645 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
646 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
647 return XSYMBOL (symbol
)->function
;
650 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
651 doc
: /* Return SYMBOL's property list. */)
653 register Lisp_Object symbol
;
655 CHECK_SYMBOL (symbol
);
656 return XSYMBOL (symbol
)->plist
;
659 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
660 doc
: /* Return SYMBOL's name, a string. */)
662 register Lisp_Object symbol
;
664 register Lisp_Object name
;
666 CHECK_SYMBOL (symbol
);
667 name
= SYMBOL_NAME (symbol
);
671 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
672 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
674 register Lisp_Object symbol
, definition
;
676 CHECK_SYMBOL (symbol
);
677 if (NILP (symbol
) || EQ (symbol
, Qt
))
678 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
679 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
680 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
682 XSYMBOL (symbol
)->function
= definition
;
683 /* Handle automatic advice activation */
684 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
686 call2 (Qad_activate_internal
, symbol
, Qnil
);
687 definition
= XSYMBOL (symbol
)->function
;
692 extern Lisp_Object Qfunction_documentation
;
694 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
695 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
696 Associates the function with the current load file, if any.
697 The optional third argument DOCSTRING specifies the documentation string
698 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
699 determined by DEFINITION. */)
700 (symbol
, definition
, docstring
)
701 register Lisp_Object symbol
, definition
, docstring
;
703 CHECK_SYMBOL (symbol
);
704 if (CONSP (XSYMBOL (symbol
)->function
)
705 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
706 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
707 definition
= Ffset (symbol
, definition
);
708 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
709 if (!NILP (docstring
))
710 Fput (symbol
, Qfunction_documentation
, docstring
);
714 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
715 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
717 register Lisp_Object symbol
, newplist
;
719 CHECK_SYMBOL (symbol
);
720 XSYMBOL (symbol
)->plist
= newplist
;
724 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
725 doc
: /* Return minimum and maximum number of args allowed for SUBR.
726 SUBR must be a built-in function.
727 The returned value is a pair (MIN . MAX). MIN is the minimum number
728 of args. MAX is the maximum number or the symbol `many', for a
729 function with `&rest' args, or `unevalled' for a special form. */)
733 short minargs
, maxargs
;
735 minargs
= XSUBR (subr
)->min_args
;
736 maxargs
= XSUBR (subr
)->max_args
;
738 return Fcons (make_number (minargs
), Qmany
);
739 else if (maxargs
== UNEVALLED
)
740 return Fcons (make_number (minargs
), Qunevalled
);
742 return Fcons (make_number (minargs
), make_number (maxargs
));
745 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
746 doc
: /* Return name of subroutine SUBR.
747 SUBR must be a built-in function. */)
753 name
= XSUBR (subr
)->symbol_name
;
754 return make_string (name
, strlen (name
));
757 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
758 doc
: /* Return the interactive form of CMD or nil if none.
759 If CMD is not a command, the return value is nil.
760 Value, if non-nil, is a list \(interactive SPEC). */)
764 Lisp_Object fun
= indirect_function (cmd
);
768 if (XSUBR (fun
)->prompt
)
769 return list2 (Qinteractive
, build_string (XSUBR (fun
)->prompt
));
771 else if (COMPILEDP (fun
))
773 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
774 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
776 else if (CONSP (fun
))
778 Lisp_Object funcar
= XCAR (fun
);
779 if (EQ (funcar
, Qlambda
))
780 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
781 else if (EQ (funcar
, Qautoload
))
785 do_autoload (fun
, cmd
);
787 return Finteractive_form (cmd
);
794 /***********************************************************************
795 Getting and Setting Values of Symbols
796 ***********************************************************************/
798 /* Return the symbol holding SYMBOL's value. Signal
799 `cyclic-variable-indirection' if SYMBOL's chain of variable
800 indirections contains a loop. */
803 indirect_variable (symbol
)
806 Lisp_Object tortoise
, hare
;
808 hare
= tortoise
= symbol
;
810 while (XSYMBOL (hare
)->indirect_variable
)
812 hare
= XSYMBOL (hare
)->value
;
813 if (!XSYMBOL (hare
)->indirect_variable
)
816 hare
= XSYMBOL (hare
)->value
;
817 tortoise
= XSYMBOL (tortoise
)->value
;
819 if (EQ (hare
, tortoise
))
820 Fsignal (Qcyclic_variable_indirection
, Fcons (symbol
, Qnil
));
827 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
828 doc
: /* Return the variable at the end of OBJECT's variable chain.
829 If OBJECT is a symbol, follow all variable indirections and return the final
830 variable. If OBJECT is not a symbol, just return it.
831 Signal a cyclic-variable-indirection error if there is a loop in the
832 variable chain of symbols. */)
836 if (SYMBOLP (object
))
837 object
= indirect_variable (object
);
842 /* Given the raw contents of a symbol value cell,
843 return the Lisp value of the symbol.
844 This does not handle buffer-local variables; use
845 swap_in_symval_forwarding for that. */
848 do_symval_forwarding (valcontents
)
849 register Lisp_Object valcontents
;
851 register Lisp_Object val
;
853 if (MISCP (valcontents
))
854 switch (XMISCTYPE (valcontents
))
856 case Lisp_Misc_Intfwd
:
857 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
860 case Lisp_Misc_Boolfwd
:
861 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
863 case Lisp_Misc_Objfwd
:
864 return *XOBJFWD (valcontents
)->objvar
;
866 case Lisp_Misc_Buffer_Objfwd
:
867 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
868 return PER_BUFFER_VALUE (current_buffer
, offset
);
870 case Lisp_Misc_Kboard_Objfwd
:
871 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
872 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
877 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
878 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
879 buffer-independent contents of the value cell: forwarded just one
880 step past the buffer-localness.
882 BUF non-zero means set the value in buffer BUF instead of the
883 current buffer. This only plays a role for per-buffer variables. */
886 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
888 register Lisp_Object valcontents
, newval
;
891 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
894 switch (XMISCTYPE (valcontents
))
896 case Lisp_Misc_Intfwd
:
897 CHECK_NUMBER (newval
);
898 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
899 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
900 error ("Value out of range for variable `%s'",
901 SDATA (SYMBOL_NAME (symbol
)));
904 case Lisp_Misc_Boolfwd
:
905 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
908 case Lisp_Misc_Objfwd
:
909 *XOBJFWD (valcontents
)->objvar
= newval
;
911 /* If this variable is a default for something stored
912 in the buffer itself, such as default-fill-column,
913 find the buffers that don't have local values for it
915 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
916 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
918 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
919 - (char *) &buffer_defaults
);
920 int idx
= PER_BUFFER_IDX (offset
);
927 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
932 buf
= Fcdr (XCAR (tail
));
933 if (!BUFFERP (buf
)) continue;
936 if (! PER_BUFFER_VALUE_P (b
, idx
))
937 PER_BUFFER_VALUE (b
, offset
) = newval
;
942 case Lisp_Misc_Buffer_Objfwd
:
944 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
947 type
= PER_BUFFER_TYPE (offset
);
948 if (! NILP (type
) && ! NILP (newval
)
949 && XTYPE (newval
) != XINT (type
))
950 buffer_slot_type_mismatch (offset
);
953 buf
= current_buffer
;
954 PER_BUFFER_VALUE (buf
, offset
) = newval
;
958 case Lisp_Misc_Kboard_Objfwd
:
960 char *base
= (char *) current_kboard
;
961 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
962 *(Lisp_Object
*) p
= newval
;
973 valcontents
= SYMBOL_VALUE (symbol
);
974 if (BUFFER_LOCAL_VALUEP (valcontents
)
975 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
976 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
978 SET_SYMBOL_VALUE (symbol
, newval
);
982 /* Set up SYMBOL to refer to its global binding.
983 This makes it safe to alter the status of other bindings. */
986 swap_in_global_binding (symbol
)
989 Lisp_Object valcontents
, cdr
;
991 valcontents
= SYMBOL_VALUE (symbol
);
992 if (!BUFFER_LOCAL_VALUEP (valcontents
)
993 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
995 cdr
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
997 /* Unload the previously loaded binding. */
999 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1001 /* Select the global binding in the symbol. */
1003 store_symval_forwarding (symbol
, valcontents
, XCDR (cdr
), NULL
);
1005 /* Indicate that the global binding is set up now. */
1006 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= Qnil
;
1007 XBUFFER_LOCAL_VALUE (valcontents
)->buffer
= Qnil
;
1008 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1009 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1012 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1013 VALCONTENTS is the contents of its value cell,
1014 which points to a struct Lisp_Buffer_Local_Value.
1016 Return the value forwarded one step past the buffer-local stage.
1017 This could be another forwarding pointer. */
1020 swap_in_symval_forwarding (symbol
, valcontents
)
1021 Lisp_Object symbol
, valcontents
;
1023 register Lisp_Object tem1
;
1025 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1028 || current_buffer
!= XBUFFER (tem1
)
1029 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1030 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1032 if (XSYMBOL (symbol
)->indirect_variable
)
1033 symbol
= indirect_variable (symbol
);
1035 /* Unload the previously loaded binding. */
1036 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1038 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1039 /* Choose the new binding. */
1040 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1041 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1042 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1045 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1046 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1048 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1050 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1053 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1055 /* Load the new binding. */
1056 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1057 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1058 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1059 store_symval_forwarding (symbol
,
1060 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1063 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1066 /* Find the value of a symbol, returning Qunbound if it's not bound.
1067 This is helpful for code which just wants to get a variable's value
1068 if it has one, without signaling an error.
1069 Note that it must not be possible to quit
1070 within this function. Great care is required for this. */
1073 find_symbol_value (symbol
)
1076 register Lisp_Object valcontents
;
1077 register Lisp_Object val
;
1079 CHECK_SYMBOL (symbol
);
1080 valcontents
= SYMBOL_VALUE (symbol
);
1082 if (BUFFER_LOCAL_VALUEP (valcontents
)
1083 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1084 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1086 if (MISCP (valcontents
))
1088 switch (XMISCTYPE (valcontents
))
1090 case Lisp_Misc_Intfwd
:
1091 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
1094 case Lisp_Misc_Boolfwd
:
1095 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
1097 case Lisp_Misc_Objfwd
:
1098 return *XOBJFWD (valcontents
)->objvar
;
1100 case Lisp_Misc_Buffer_Objfwd
:
1101 return PER_BUFFER_VALUE (current_buffer
,
1102 XBUFFER_OBJFWD (valcontents
)->offset
);
1104 case Lisp_Misc_Kboard_Objfwd
:
1105 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
1106 + (char *)current_kboard
);
1113 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1114 doc
: /* Return SYMBOL's value. Error if that is void. */)
1120 val
= find_symbol_value (symbol
);
1121 if (EQ (val
, Qunbound
))
1122 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1127 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1128 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1130 register Lisp_Object symbol
, newval
;
1132 return set_internal (symbol
, newval
, current_buffer
, 0);
1135 /* Return 1 if SYMBOL currently has a let-binding
1136 which was made in the buffer that is now current. */
1139 let_shadows_buffer_binding_p (symbol
)
1142 volatile struct specbinding
*p
;
1144 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1146 && CONSP (p
->symbol
))
1148 Lisp_Object let_bound_symbol
= XCAR (p
->symbol
);
1149 if ((EQ (symbol
, let_bound_symbol
)
1150 || (XSYMBOL (let_bound_symbol
)->indirect_variable
1151 && EQ (symbol
, indirect_variable (let_bound_symbol
))))
1152 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1156 return p
>= specpdl
;
1159 /* Store the value NEWVAL into SYMBOL.
1160 If buffer-locality is an issue, BUF specifies which buffer to use.
1161 (0 stands for the current buffer.)
1163 If BINDFLAG is zero, then if this symbol is supposed to become
1164 local in every buffer where it is set, then we make it local.
1165 If BINDFLAG is nonzero, we don't do that. */
1168 set_internal (symbol
, newval
, buf
, bindflag
)
1169 register Lisp_Object symbol
, newval
;
1173 int voide
= EQ (newval
, Qunbound
);
1175 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1178 buf
= current_buffer
;
1180 /* If restoring in a dead buffer, do nothing. */
1181 if (NILP (buf
->name
))
1184 CHECK_SYMBOL (symbol
);
1185 if (SYMBOL_CONSTANT_P (symbol
)
1186 && (NILP (Fkeywordp (symbol
))
1187 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1188 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
1190 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1192 if (BUFFER_OBJFWDP (valcontents
))
1194 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1195 int idx
= PER_BUFFER_IDX (offset
);
1198 && !let_shadows_buffer_binding_p (symbol
))
1199 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1201 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1202 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1204 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1205 if (XSYMBOL (symbol
)->indirect_variable
)
1206 symbol
= indirect_variable (symbol
);
1208 /* What binding is loaded right now? */
1209 current_alist_element
1210 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1212 /* If the current buffer is not the buffer whose binding is
1213 loaded, or if there may be frame-local bindings and the frame
1214 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1215 the default binding is loaded, the loaded binding may be the
1217 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1218 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1219 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1220 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1221 || (BUFFER_LOCAL_VALUEP (valcontents
)
1222 && EQ (XCAR (current_alist_element
),
1223 current_alist_element
)))
1225 /* The currently loaded binding is not necessarily valid.
1226 We need to unload it, and choose a new binding. */
1228 /* Write out `realvalue' to the old loaded binding. */
1229 Fsetcdr (current_alist_element
,
1230 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1232 /* Find the new binding. */
1233 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1234 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1235 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1239 /* This buffer still sees the default value. */
1241 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1242 or if this is `let' rather than `set',
1243 make CURRENT-ALIST-ELEMENT point to itself,
1244 indicating that we're seeing the default value.
1245 Likewise if the variable has been let-bound
1246 in the current buffer. */
1247 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1248 || let_shadows_buffer_binding_p (symbol
))
1250 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1252 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1253 tem1
= Fassq (symbol
,
1254 XFRAME (selected_frame
)->param_alist
);
1257 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1259 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1261 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1262 and we're not within a let that was made for this buffer,
1263 create a new buffer-local binding for the variable.
1264 That means, give this buffer a new assoc for a local value
1265 and load that binding. */
1268 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1269 buf
->local_var_alist
1270 = Fcons (tem1
, buf
->local_var_alist
);
1274 /* Record which binding is now loaded. */
1275 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
,
1278 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1279 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1280 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1282 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1285 /* If storing void (making the symbol void), forward only through
1286 buffer-local indicator, not through Lisp_Objfwd, etc. */
1288 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1290 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1292 /* If we just set a variable whose current binding is frame-local,
1293 store the new value in the frame parameter too. */
1295 if (BUFFER_LOCAL_VALUEP (valcontents
)
1296 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1298 /* What binding is loaded right now? */
1299 current_alist_element
1300 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1302 /* If the current buffer is not the buffer whose binding is
1303 loaded, or if there may be frame-local bindings and the frame
1304 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1305 the default binding is loaded, the loaded binding may be the
1307 if (XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1308 XSETCDR (current_alist_element
, newval
);
1314 /* Access or set a buffer-local symbol's default value. */
1316 /* Return the default value of SYMBOL, but don't check for voidness.
1317 Return Qunbound if it is void. */
1320 default_value (symbol
)
1323 register Lisp_Object valcontents
;
1325 CHECK_SYMBOL (symbol
);
1326 valcontents
= SYMBOL_VALUE (symbol
);
1328 /* For a built-in buffer-local variable, get the default value
1329 rather than letting do_symval_forwarding get the current value. */
1330 if (BUFFER_OBJFWDP (valcontents
))
1332 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1333 if (PER_BUFFER_IDX (offset
) != 0)
1334 return PER_BUFFER_DEFAULT (offset
);
1337 /* Handle user-created local variables. */
1338 if (BUFFER_LOCAL_VALUEP (valcontents
)
1339 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1341 /* If var is set up for a buffer that lacks a local value for it,
1342 the current value is nominally the default value.
1343 But the `realvalue' slot may be more up to date, since
1344 ordinary setq stores just that slot. So use that. */
1345 Lisp_Object current_alist_element
, alist_element_car
;
1346 current_alist_element
1347 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1348 alist_element_car
= XCAR (current_alist_element
);
1349 if (EQ (alist_element_car
, current_alist_element
))
1350 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1352 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1354 /* For other variables, get the current value. */
1355 return do_symval_forwarding (valcontents
);
1358 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1359 doc
: /* Return t if SYMBOL has a non-void default value.
1360 This is the value that is seen in buffers that do not have their own values
1361 for this variable. */)
1365 register Lisp_Object value
;
1367 value
= default_value (symbol
);
1368 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1371 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1372 doc
: /* Return SYMBOL's default value.
1373 This is the value that is seen in buffers that do not have their own values
1374 for this variable. The default value is meaningful for variables with
1375 local bindings in certain buffers. */)
1379 register Lisp_Object value
;
1381 value
= default_value (symbol
);
1382 if (EQ (value
, Qunbound
))
1383 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1387 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1388 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1389 The default value is seen in buffers that do not have their own values
1390 for this variable. */)
1392 Lisp_Object symbol
, value
;
1394 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1396 CHECK_SYMBOL (symbol
);
1397 valcontents
= SYMBOL_VALUE (symbol
);
1399 /* Handle variables like case-fold-search that have special slots
1400 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1402 if (BUFFER_OBJFWDP (valcontents
))
1404 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1405 int idx
= PER_BUFFER_IDX (offset
);
1407 PER_BUFFER_DEFAULT (offset
) = value
;
1409 /* If this variable is not always local in all buffers,
1410 set it in the buffers that don't nominally have a local value. */
1415 for (b
= all_buffers
; b
; b
= b
->next
)
1416 if (!PER_BUFFER_VALUE_P (b
, idx
))
1417 PER_BUFFER_VALUE (b
, offset
) = value
;
1422 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1423 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1424 return Fset (symbol
, value
);
1426 /* Store new value into the DEFAULT-VALUE slot. */
1427 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1429 /* If the default binding is now loaded, set the REALVALUE slot too. */
1430 current_alist_element
1431 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1432 alist_element_buffer
= Fcar (current_alist_element
);
1433 if (EQ (alist_element_buffer
, current_alist_element
))
1434 store_symval_forwarding (symbol
,
1435 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1441 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1442 doc
: /* Set the default value of variable VAR to VALUE.
1443 VAR, the variable name, is literal (not evaluated);
1444 VALUE is an expression: it is evaluated and its value returned.
1445 The default value of a variable is seen in buffers
1446 that do not have their own values for the variable.
1448 More generally, you can use multiple variables and values, as in
1449 (setq-default VAR VALUE VAR VALUE...)
1450 This sets each VAR's default value to the corresponding VALUE.
1451 The VALUE for the Nth VAR can refer to the new default values
1453 usage: (setq-default [VAR VALUE...]) */)
1457 register Lisp_Object args_left
;
1458 register Lisp_Object val
, symbol
;
1459 struct gcpro gcpro1
;
1469 val
= Feval (Fcar (Fcdr (args_left
)));
1470 symbol
= XCAR (args_left
);
1471 Fset_default (symbol
, val
);
1472 args_left
= Fcdr (XCDR (args_left
));
1474 while (!NILP (args_left
));
1480 /* Lisp functions for creating and removing buffer-local variables. */
1482 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1483 1, 1, "vMake Variable Buffer Local: ",
1484 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1485 At any time, the value for the current buffer is in effect,
1486 unless the variable has never been set in this buffer,
1487 in which case the default value is in effect.
1488 Note that binding the variable with `let', or setting it while
1489 a `let'-style binding made in this buffer is in effect,
1490 does not make the variable buffer-local. Return VARIABLE.
1492 In most cases it is better to use `make-local-variable',
1493 which makes a variable local in just one buffer.
1495 The function `default-value' gets the default value and `set-default' sets it. */)
1497 register Lisp_Object variable
;
1499 register Lisp_Object tem
, valcontents
, newval
;
1501 CHECK_SYMBOL (variable
);
1502 variable
= indirect_variable (variable
);
1504 valcontents
= SYMBOL_VALUE (variable
);
1505 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1506 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1508 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1510 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1512 XMISCTYPE (SYMBOL_VALUE (variable
)) = Lisp_Misc_Buffer_Local_Value
;
1515 if (EQ (valcontents
, Qunbound
))
1516 SET_SYMBOL_VALUE (variable
, Qnil
);
1517 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1519 newval
= allocate_misc ();
1520 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1521 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1522 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1523 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1524 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1525 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1526 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1527 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1528 SET_SYMBOL_VALUE (variable
, newval
);
1532 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1533 1, 1, "vMake Local Variable: ",
1534 doc
: /* Make VARIABLE have a separate value in the current buffer.
1535 Other buffers will continue to share a common default value.
1536 \(The buffer-local value of VARIABLE starts out as the same value
1537 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1540 If the variable is already arranged to become local when set,
1541 this function causes a local value to exist for this buffer,
1542 just as setting the variable would do.
1544 This function returns VARIABLE, and therefore
1545 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1548 See also `make-variable-buffer-local'.
1550 Do not use `make-local-variable' to make a hook variable buffer-local.
1551 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1553 register Lisp_Object variable
;
1555 register Lisp_Object tem
, valcontents
;
1557 CHECK_SYMBOL (variable
);
1558 variable
= indirect_variable (variable
);
1560 valcontents
= SYMBOL_VALUE (variable
);
1561 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1562 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1564 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1566 tem
= Fboundp (variable
);
1568 /* Make sure the symbol has a local value in this particular buffer,
1569 by setting it to the same value it already has. */
1570 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1573 /* Make sure symbol is set up to hold per-buffer values. */
1574 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1577 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1579 newval
= allocate_misc ();
1580 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1581 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1582 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1583 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1584 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1585 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1586 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1587 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1588 SET_SYMBOL_VALUE (variable
, newval
);;
1590 /* Make sure this buffer has its own value of symbol. */
1591 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1594 /* Swap out any local binding for some other buffer, and make
1595 sure the current value is permanently recorded, if it's the
1597 find_symbol_value (variable
);
1599 current_buffer
->local_var_alist
1600 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->cdr
)),
1601 current_buffer
->local_var_alist
);
1603 /* Make sure symbol does not think it is set up for this buffer;
1604 force it to look once again for this buffer's value. */
1606 Lisp_Object
*pvalbuf
;
1608 valcontents
= SYMBOL_VALUE (variable
);
1610 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1611 if (current_buffer
== XBUFFER (*pvalbuf
))
1613 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1617 /* If the symbol forwards into a C variable, then load the binding
1618 for this buffer now. If C code modifies the variable before we
1619 load the binding in, then that new value will clobber the default
1620 binding the next time we unload it. */
1621 valcontents
= XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable
))->realvalue
;
1622 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1623 swap_in_symval_forwarding (variable
, SYMBOL_VALUE (variable
));
1628 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1629 1, 1, "vKill Local Variable: ",
1630 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1631 From now on the default value will apply in this buffer. Return VARIABLE. */)
1633 register Lisp_Object variable
;
1635 register Lisp_Object tem
, valcontents
;
1637 CHECK_SYMBOL (variable
);
1638 variable
= indirect_variable (variable
);
1640 valcontents
= SYMBOL_VALUE (variable
);
1642 if (BUFFER_OBJFWDP (valcontents
))
1644 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1645 int idx
= PER_BUFFER_IDX (offset
);
1649 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1650 PER_BUFFER_VALUE (current_buffer
, offset
)
1651 = PER_BUFFER_DEFAULT (offset
);
1656 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1657 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1660 /* Get rid of this buffer's alist element, if any. */
1662 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1664 current_buffer
->local_var_alist
1665 = Fdelq (tem
, current_buffer
->local_var_alist
);
1667 /* If the symbol is set up with the current buffer's binding
1668 loaded, recompute its value. We have to do it now, or else
1669 forwarded objects won't work right. */
1671 Lisp_Object
*pvalbuf
, buf
;
1672 valcontents
= SYMBOL_VALUE (variable
);
1673 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1674 XSETBUFFER (buf
, current_buffer
);
1675 if (EQ (buf
, *pvalbuf
))
1678 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1679 find_symbol_value (variable
);
1686 /* Lisp functions for creating and removing buffer-local variables. */
1688 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1689 1, 1, "vMake Variable Frame Local: ",
1690 doc
: /* Enable VARIABLE to have frame-local bindings.
1691 This does not create any frame-local bindings for VARIABLE,
1692 it just makes them possible.
1694 A frame-local binding is actually a frame parameter value.
1695 If a frame F has a value for the frame parameter named VARIABLE,
1696 that also acts as a frame-local binding for VARIABLE in F--
1697 provided this function has been called to enable VARIABLE
1698 to have frame-local bindings at all.
1700 The only way to create a frame-local binding for VARIABLE in a frame
1701 is to set the VARIABLE frame parameter of that frame. See
1702 `modify-frame-parameters' for how to set frame parameters.
1704 Buffer-local bindings take precedence over frame-local bindings. */)
1706 register Lisp_Object variable
;
1708 register Lisp_Object tem
, valcontents
, newval
;
1710 CHECK_SYMBOL (variable
);
1711 variable
= indirect_variable (variable
);
1713 valcontents
= SYMBOL_VALUE (variable
);
1714 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
)
1715 || BUFFER_OBJFWDP (valcontents
))
1716 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1718 if (BUFFER_LOCAL_VALUEP (valcontents
)
1719 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1721 XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
= 1;
1725 if (EQ (valcontents
, Qunbound
))
1726 SET_SYMBOL_VALUE (variable
, Qnil
);
1727 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1729 newval
= allocate_misc ();
1730 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1731 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= SYMBOL_VALUE (variable
);
1732 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1733 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1734 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1735 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1736 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1737 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1738 SET_SYMBOL_VALUE (variable
, newval
);
1742 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1744 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1745 BUFFER defaults to the current buffer. */)
1747 register Lisp_Object variable
, buffer
;
1749 Lisp_Object valcontents
;
1750 register struct buffer
*buf
;
1753 buf
= current_buffer
;
1756 CHECK_BUFFER (buffer
);
1757 buf
= XBUFFER (buffer
);
1760 CHECK_SYMBOL (variable
);
1761 variable
= indirect_variable (variable
);
1763 valcontents
= SYMBOL_VALUE (variable
);
1764 if (BUFFER_LOCAL_VALUEP (valcontents
)
1765 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1767 Lisp_Object tail
, elt
;
1769 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1772 if (EQ (variable
, XCAR (elt
)))
1776 if (BUFFER_OBJFWDP (valcontents
))
1778 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1779 int idx
= PER_BUFFER_IDX (offset
);
1780 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1786 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1788 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1789 More precisely, this means that setting the variable \(with `set' or`setq'),
1790 while it does not have a `let'-style binding that was made in BUFFER,
1791 will produce a buffer local binding. See Info node
1792 `(elisp)Creating Buffer-Local'.
1793 BUFFER defaults to the current buffer. */)
1795 register Lisp_Object variable
, buffer
;
1797 Lisp_Object valcontents
;
1798 register struct buffer
*buf
;
1801 buf
= current_buffer
;
1804 CHECK_BUFFER (buffer
);
1805 buf
= XBUFFER (buffer
);
1808 CHECK_SYMBOL (variable
);
1809 variable
= indirect_variable (variable
);
1811 valcontents
= SYMBOL_VALUE (variable
);
1813 /* This means that make-variable-buffer-local was done. */
1814 if (BUFFER_LOCAL_VALUEP (valcontents
))
1816 /* All these slots become local if they are set. */
1817 if (BUFFER_OBJFWDP (valcontents
))
1819 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1821 Lisp_Object tail
, elt
;
1822 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1825 if (EQ (variable
, XCAR (elt
)))
1832 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1834 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1835 If the current binding is buffer-local, the value is the current buffer.
1836 If the current binding is frame-local, the value is the selected frame.
1837 If the current binding is global (the default), the value is nil. */)
1839 register Lisp_Object variable
;
1841 Lisp_Object valcontents
;
1843 CHECK_SYMBOL (variable
);
1844 variable
= indirect_variable (variable
);
1846 /* Make sure the current binding is actually swapped in. */
1847 find_symbol_value (variable
);
1849 valcontents
= XSYMBOL (variable
)->value
;
1851 if (BUFFER_LOCAL_VALUEP (valcontents
)
1852 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
1853 || BUFFER_OBJFWDP (valcontents
))
1855 /* For a local variable, record both the symbol and which
1856 buffer's or frame's value we are saving. */
1857 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1858 return Fcurrent_buffer ();
1859 else if (!BUFFER_OBJFWDP (valcontents
)
1860 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1861 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1867 /* Find the function at the end of a chain of symbol function indirections. */
1869 /* If OBJECT is a symbol, find the end of its function chain and
1870 return the value found there. If OBJECT is not a symbol, just
1871 return it. If there is a cycle in the function chain, signal a
1872 cyclic-function-indirection error.
1874 This is like Findirect_function, except that it doesn't signal an
1875 error if the chain ends up unbound. */
1877 indirect_function (object
)
1878 register Lisp_Object object
;
1880 Lisp_Object tortoise
, hare
;
1882 hare
= tortoise
= object
;
1886 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1888 hare
= XSYMBOL (hare
)->function
;
1889 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1891 hare
= XSYMBOL (hare
)->function
;
1893 tortoise
= XSYMBOL (tortoise
)->function
;
1895 if (EQ (hare
, tortoise
))
1896 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1902 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1903 doc
: /* Return the function at the end of OBJECT's function chain.
1904 If OBJECT is not a symbol, just return it. Otherwise, follow all
1905 function indirections to find the final function binding and return it.
1906 If the final symbol in the chain is unbound, signal a void-function error.
1907 Optional arg NOERROR non-nil means to return nil instead of signalling.
1908 Signal a cyclic-function-indirection error if there is a loop in the
1909 function chain of symbols. */)
1911 register Lisp_Object object
;
1912 Lisp_Object noerror
;
1916 /* Optimize for no indirection. */
1918 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1919 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1920 result
= indirect_function (result
);
1921 if (!EQ (result
, Qunbound
))
1925 Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1930 /* Extract and set vector and string elements */
1932 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1933 doc
: /* Return the element of ARRAY at index IDX.
1934 ARRAY may be a vector, a string, a char-table, a bool-vector,
1935 or a byte-code object. IDX starts at 0. */)
1937 register Lisp_Object array
;
1940 register int idxval
;
1943 idxval
= XINT (idx
);
1944 if (STRINGP (array
))
1948 if (idxval
< 0 || idxval
>= SCHARS (array
))
1949 args_out_of_range (array
, idx
);
1950 if (! STRING_MULTIBYTE (array
))
1951 return make_number ((unsigned char) SREF (array
, idxval
));
1952 idxval_byte
= string_char_to_byte (array
, idxval
);
1954 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1955 SBYTES (array
) - idxval_byte
);
1956 return make_number (c
);
1958 else if (BOOL_VECTOR_P (array
))
1962 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1963 args_out_of_range (array
, idx
);
1965 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
1966 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
1968 else if (CHAR_TABLE_P (array
))
1975 args_out_of_range (array
, idx
);
1976 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
1978 if (! SINGLE_BYTE_CHAR_P (idxval
))
1979 args_out_of_range (array
, idx
);
1980 /* For ASCII and 8-bit European characters, the element is
1981 stored in the top table. */
1982 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1986 = (idxval
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
1987 : idxval
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
1988 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
1989 val
= XCHAR_TABLE (array
)->contents
[default_slot
];
1992 val
= XCHAR_TABLE (array
)->defalt
;
1993 while (NILP (val
)) /* Follow parents until we find some value. */
1995 array
= XCHAR_TABLE (array
)->parent
;
1998 val
= XCHAR_TABLE (array
)->contents
[idxval
];
2000 val
= XCHAR_TABLE (array
)->defalt
;
2007 Lisp_Object sub_table
;
2008 Lisp_Object current_default
;
2010 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2011 if (code
[1] < 32) code
[1] = -1;
2012 else if (code
[2] < 32) code
[2] = -1;
2014 /* Here, the possible range of CODE[0] (== charset ID) is
2015 128..MAX_CHARSET. Since the top level char table contains
2016 data for multibyte characters after 256th element, we must
2017 increment CODE[0] by 128 to get a correct index. */
2019 code
[3] = -1; /* anchor */
2021 try_parent_char_table
:
2022 current_default
= XCHAR_TABLE (array
)->defalt
;
2024 for (i
= 0; code
[i
] >= 0; i
++)
2026 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
2027 if (SUB_CHAR_TABLE_P (val
))
2030 if (! NILP (XCHAR_TABLE (sub_table
)->defalt
))
2031 current_default
= XCHAR_TABLE (sub_table
)->defalt
;
2036 val
= current_default
;
2039 array
= XCHAR_TABLE (array
)->parent
;
2041 goto try_parent_char_table
;
2046 /* Reaching here means IDXVAL is a generic character in
2047 which each character or a group has independent value.
2048 Essentially it's nonsense to get a value for such a
2049 generic character, but for backward compatibility, we try
2050 the default value and parent. */
2051 val
= current_default
;
2054 array
= XCHAR_TABLE (array
)->parent
;
2056 goto try_parent_char_table
;
2064 if (VECTORP (array
))
2065 size
= XVECTOR (array
)->size
;
2066 else if (COMPILEDP (array
))
2067 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2069 wrong_type_argument (Qarrayp
, array
);
2071 if (idxval
< 0 || idxval
>= size
)
2072 args_out_of_range (array
, idx
);
2073 return XVECTOR (array
)->contents
[idxval
];
2077 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2078 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2079 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2080 bool-vector. IDX starts at 0. */)
2081 (array
, idx
, newelt
)
2082 register Lisp_Object array
;
2083 Lisp_Object idx
, newelt
;
2085 register int idxval
;
2088 idxval
= XINT (idx
);
2089 CHECK_ARRAY (array
, Qarrayp
);
2090 CHECK_IMPURE (array
);
2092 if (VECTORP (array
))
2094 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2095 args_out_of_range (array
, idx
);
2096 XVECTOR (array
)->contents
[idxval
] = newelt
;
2098 else if (BOOL_VECTOR_P (array
))
2102 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2103 args_out_of_range (array
, idx
);
2105 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2107 if (! NILP (newelt
))
2108 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2110 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2111 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2113 else if (CHAR_TABLE_P (array
))
2116 args_out_of_range (array
, idx
);
2117 if (idxval
< CHAR_TABLE_ORDINARY_SLOTS
)
2119 if (! SINGLE_BYTE_CHAR_P (idxval
))
2120 args_out_of_range (array
, idx
);
2121 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
2128 SPLIT_CHAR (idxval
, code
[0], code
[1], code
[2]);
2129 if (code
[1] < 32) code
[1] = -1;
2130 else if (code
[2] < 32) code
[2] = -1;
2132 /* See the comment of the corresponding part in Faref. */
2134 code
[3] = -1; /* anchor */
2135 for (i
= 0; code
[i
+ 1] >= 0; i
++)
2137 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
2138 if (SUB_CHAR_TABLE_P (val
))
2144 /* VAL is a leaf. Create a sub char table with the
2145 initial value VAL and look into it. */
2147 temp
= make_sub_char_table (val
);
2148 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
2152 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
2155 else if (STRING_MULTIBYTE (array
))
2157 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2158 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2160 if (idxval
< 0 || idxval
>= SCHARS (array
))
2161 args_out_of_range (array
, idx
);
2162 CHECK_NUMBER (newelt
);
2164 nbytes
= SBYTES (array
);
2166 idxval_byte
= string_char_to_byte (array
, idxval
);
2167 p1
= SDATA (array
) + idxval_byte
;
2168 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2169 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2170 if (prev_bytes
!= new_bytes
)
2172 /* We must relocate the string data. */
2173 int nchars
= SCHARS (array
);
2177 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2178 bcopy (SDATA (array
), str
, nbytes
);
2179 allocate_string_data (XSTRING (array
), nchars
,
2180 nbytes
+ new_bytes
- prev_bytes
);
2181 bcopy (str
, SDATA (array
), idxval_byte
);
2182 p1
= SDATA (array
) + idxval_byte
;
2183 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2184 nbytes
- (idxval_byte
+ prev_bytes
));
2186 clear_string_char_byte_cache ();
2193 if (idxval
< 0 || idxval
>= SCHARS (array
))
2194 args_out_of_range (array
, idx
);
2195 CHECK_NUMBER (newelt
);
2197 if (XINT (newelt
) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2198 SSET (array
, idxval
, XINT (newelt
));
2201 /* We must relocate the string data while converting it to
2203 int idxval_byte
, prev_bytes
, new_bytes
;
2204 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2205 unsigned char *origstr
= SDATA (array
), *str
;
2209 nchars
= SCHARS (array
);
2210 nbytes
= idxval_byte
= count_size_as_multibyte (origstr
, idxval
);
2211 nbytes
+= count_size_as_multibyte (origstr
+ idxval
,
2213 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2214 copy_text (SDATA (array
), str
, nchars
, 0, 1);
2215 PARSE_MULTIBYTE_SEQ (str
+ idxval_byte
, nbytes
- idxval_byte
,
2217 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2218 allocate_string_data (XSTRING (array
), nchars
,
2219 nbytes
+ new_bytes
- prev_bytes
);
2220 bcopy (str
, SDATA (array
), idxval_byte
);
2221 p1
= SDATA (array
) + idxval_byte
;
2224 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
,
2225 nbytes
- (idxval_byte
+ prev_bytes
));
2227 clear_string_char_byte_cache ();
2234 /* Arithmetic functions */
2236 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2239 arithcompare (num1
, num2
, comparison
)
2240 Lisp_Object num1
, num2
;
2241 enum comparison comparison
;
2243 double f1
= 0, f2
= 0;
2246 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2247 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2249 if (FLOATP (num1
) || FLOATP (num2
))
2252 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2253 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2259 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2264 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2269 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2274 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2279 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2284 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2293 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2294 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2296 register Lisp_Object num1
, num2
;
2298 return arithcompare (num1
, num2
, equal
);
2301 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2302 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2304 register Lisp_Object num1
, num2
;
2306 return arithcompare (num1
, num2
, less
);
2309 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2310 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2312 register Lisp_Object num1
, num2
;
2314 return arithcompare (num1
, num2
, grtr
);
2317 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2318 doc
: /* Return t if first arg is less than or equal to second arg.
2319 Both must be numbers or markers. */)
2321 register Lisp_Object num1
, num2
;
2323 return arithcompare (num1
, num2
, less_or_equal
);
2326 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2327 doc
: /* Return t if first arg is greater than or equal to second arg.
2328 Both must be numbers or markers. */)
2330 register Lisp_Object num1
, num2
;
2332 return arithcompare (num1
, num2
, grtr_or_equal
);
2335 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2336 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2338 register Lisp_Object num1
, num2
;
2340 return arithcompare (num1
, num2
, notequal
);
2343 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2344 doc
: /* Return t if NUMBER is zero. */)
2346 register Lisp_Object number
;
2348 CHECK_NUMBER_OR_FLOAT (number
);
2350 if (FLOATP (number
))
2352 if (XFLOAT_DATA (number
) == 0.0)
2362 /* Convert between long values and pairs of Lisp integers. */
2368 unsigned long top
= i
>> 16;
2369 unsigned int bot
= i
& 0xFFFF;
2371 return make_number (bot
);
2372 if (top
== (unsigned long)-1 >> 16)
2373 return Fcons (make_number (-1), make_number (bot
));
2374 return Fcons (make_number (top
), make_number (bot
));
2381 Lisp_Object top
, bot
;
2388 return ((XINT (top
) << 16) | XINT (bot
));
2391 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2392 doc
: /* Return the decimal representation of NUMBER as a string.
2393 Uses a minus sign if negative.
2394 NUMBER may be an integer or a floating point number. */)
2398 char buffer
[VALBITS
];
2400 CHECK_NUMBER_OR_FLOAT (number
);
2402 if (FLOATP (number
))
2404 char pigbuf
[350]; /* see comments in float_to_string */
2406 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2407 return build_string (pigbuf
);
2410 if (sizeof (int) == sizeof (EMACS_INT
))
2411 sprintf (buffer
, "%d", XINT (number
));
2412 else if (sizeof (long) == sizeof (EMACS_INT
))
2413 sprintf (buffer
, "%ld", (long) XINT (number
));
2416 return build_string (buffer
);
2420 digit_to_number (character
, base
)
2421 int character
, base
;
2425 if (character
>= '0' && character
<= '9')
2426 digit
= character
- '0';
2427 else if (character
>= 'a' && character
<= 'z')
2428 digit
= character
- 'a' + 10;
2429 else if (character
>= 'A' && character
<= 'Z')
2430 digit
= character
- 'A' + 10;
2440 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2441 doc
: /* Parse STRING as a decimal number and return the number.
2442 This parses both integers and floating point numbers.
2443 It ignores leading spaces and tabs.
2445 If BASE, interpret STRING as a number in that base. If BASE isn't
2446 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2447 If the base used is not 10, floating point is not recognized. */)
2449 register Lisp_Object string
, base
;
2451 register unsigned char *p
;
2456 CHECK_STRING (string
);
2462 CHECK_NUMBER (base
);
2464 if (b
< 2 || b
> 16)
2465 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2468 /* Skip any whitespace at the front of the number. Some versions of
2469 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2471 while (*p
== ' ' || *p
== '\t')
2482 if (isfloat_string (p
) && b
== 10)
2483 val
= make_float (sign
* atof (p
));
2490 int digit
= digit_to_number (*p
++, b
);
2496 val
= make_fixnum_or_float (sign
* v
);
2516 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2517 int, Lisp_Object
*));
2518 extern Lisp_Object
fmod_float ();
2521 arith_driver (code
, nargs
, args
)
2524 register Lisp_Object
*args
;
2526 register Lisp_Object val
;
2527 register int argnum
;
2528 register EMACS_INT accum
= 0;
2529 register EMACS_INT next
;
2531 switch (SWITCH_ENUM_CAST (code
))
2549 for (argnum
= 0; argnum
< nargs
; argnum
++)
2551 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2553 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2556 return float_arith_driver ((double) accum
, argnum
, code
,
2559 next
= XINT (args
[argnum
]);
2560 switch (SWITCH_ENUM_CAST (code
))
2566 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2577 Fsignal (Qarith_error
, Qnil
);
2591 if (!argnum
|| next
> accum
)
2595 if (!argnum
|| next
< accum
)
2601 XSETINT (val
, accum
);
2606 #define isnan(x) ((x) != (x))
2609 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2611 register int argnum
;
2614 register Lisp_Object
*args
;
2616 register Lisp_Object val
;
2619 for (; argnum
< nargs
; argnum
++)
2621 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2622 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2626 next
= XFLOAT_DATA (val
);
2630 args
[argnum
] = val
; /* runs into a compiler bug. */
2631 next
= XINT (args
[argnum
]);
2633 switch (SWITCH_ENUM_CAST (code
))
2639 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2649 if (! IEEE_FLOATING_POINT
&& next
== 0)
2650 Fsignal (Qarith_error
, Qnil
);
2657 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2659 if (!argnum
|| isnan (next
) || next
> accum
)
2663 if (!argnum
|| isnan (next
) || next
< accum
)
2669 return make_float (accum
);
2673 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2674 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2675 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2680 return arith_driver (Aadd
, nargs
, args
);
2683 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2684 doc
: /* Negate number or subtract numbers or markers and return the result.
2685 With one arg, negates it. With more than one arg,
2686 subtracts all but the first from the first.
2687 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2692 return arith_driver (Asub
, nargs
, args
);
2695 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2696 doc
: /* Return product of any number of arguments, which are numbers or markers.
2697 usage: (* &rest NUMBERS-OR-MARKERS) */)
2702 return arith_driver (Amult
, nargs
, args
);
2705 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2706 doc
: /* Return first argument divided by all the remaining arguments.
2707 The arguments must be numbers or markers.
2708 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2714 for (argnum
= 2; argnum
< nargs
; argnum
++)
2715 if (FLOATP (args
[argnum
]))
2716 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2717 return arith_driver (Adiv
, nargs
, args
);
2720 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2721 doc
: /* Return remainder of X divided by Y.
2722 Both must be integers or markers. */)
2724 register Lisp_Object x
, y
;
2728 CHECK_NUMBER_COERCE_MARKER (x
);
2729 CHECK_NUMBER_COERCE_MARKER (y
);
2731 if (XFASTINT (y
) == 0)
2732 Fsignal (Qarith_error
, Qnil
);
2734 XSETINT (val
, XINT (x
) % XINT (y
));
2748 /* If the magnitude of the result exceeds that of the divisor, or
2749 the sign of the result does not agree with that of the dividend,
2750 iterate with the reduced value. This does not yield a
2751 particularly accurate result, but at least it will be in the
2752 range promised by fmod. */
2754 r
-= f2
* floor (r
/ f2
);
2755 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2759 #endif /* ! HAVE_FMOD */
2761 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2762 doc
: /* Return X modulo Y.
2763 The result falls between zero (inclusive) and Y (exclusive).
2764 Both X and Y must be numbers or markers. */)
2766 register Lisp_Object x
, y
;
2771 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2772 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2774 if (FLOATP (x
) || FLOATP (y
))
2775 return fmod_float (x
, y
);
2781 Fsignal (Qarith_error
, Qnil
);
2785 /* If the "remainder" comes out with the wrong sign, fix it. */
2786 if (i2
< 0 ? i1
> 0 : i1
< 0)
2793 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2794 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2795 The value is always a number; markers are converted to numbers.
2796 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2801 return arith_driver (Amax
, nargs
, args
);
2804 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2805 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2806 The value is always a number; markers are converted to numbers.
2807 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2812 return arith_driver (Amin
, nargs
, args
);
2815 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2816 doc
: /* Return bitwise-and of all the arguments.
2817 Arguments may be integers, or markers converted to integers.
2818 usage: (logand &rest INTS-OR-MARKERS) */)
2823 return arith_driver (Alogand
, nargs
, args
);
2826 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2827 doc
: /* Return bitwise-or of all the arguments.
2828 Arguments may be integers, or markers converted to integers.
2829 usage: (logior &rest INTS-OR-MARKERS) */)
2834 return arith_driver (Alogior
, nargs
, args
);
2837 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2838 doc
: /* Return bitwise-exclusive-or of all the arguments.
2839 Arguments may be integers, or markers converted to integers.
2840 usage: (logxor &rest INTS-OR-MARKERS) */)
2845 return arith_driver (Alogxor
, nargs
, args
);
2848 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2849 doc
: /* Return VALUE with its bits shifted left by COUNT.
2850 If COUNT is negative, shifting is actually to the right.
2851 In this case, the sign bit is duplicated. */)
2853 register Lisp_Object value
, count
;
2855 register Lisp_Object val
;
2857 CHECK_NUMBER (value
);
2858 CHECK_NUMBER (count
);
2860 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2862 else if (XINT (count
) > 0)
2863 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2864 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2865 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2867 XSETINT (val
, XINT (value
) >> -XINT (count
));
2871 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2872 doc
: /* Return VALUE with its bits shifted left by COUNT.
2873 If COUNT is negative, shifting is actually to the right.
2874 In this case, zeros are shifted in on the left. */)
2876 register Lisp_Object value
, count
;
2878 register Lisp_Object val
;
2880 CHECK_NUMBER (value
);
2881 CHECK_NUMBER (count
);
2883 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2885 else if (XINT (count
) > 0)
2886 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2887 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2890 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2894 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2895 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2896 Markers are converted to integers. */)
2898 register Lisp_Object number
;
2900 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2902 if (FLOATP (number
))
2903 return (make_float (1.0 + XFLOAT_DATA (number
)));
2905 XSETINT (number
, XINT (number
) + 1);
2909 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2910 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2911 Markers are converted to integers. */)
2913 register Lisp_Object number
;
2915 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2917 if (FLOATP (number
))
2918 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2920 XSETINT (number
, XINT (number
) - 1);
2924 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2925 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2927 register Lisp_Object number
;
2929 CHECK_NUMBER (number
);
2930 XSETINT (number
, ~XINT (number
));
2934 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2935 doc
: /* Return the byteorder for the machine.
2936 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2937 lowercase l) for small endian machines. */)
2940 unsigned i
= 0x04030201;
2941 int order
= *(char *)&i
== 1 ? 108 : 66;
2943 return make_number (order
);
2951 Lisp_Object error_tail
, arith_tail
;
2953 Qquote
= intern ("quote");
2954 Qlambda
= intern ("lambda");
2955 Qsubr
= intern ("subr");
2956 Qerror_conditions
= intern ("error-conditions");
2957 Qerror_message
= intern ("error-message");
2958 Qtop_level
= intern ("top-level");
2960 Qerror
= intern ("error");
2961 Qquit
= intern ("quit");
2962 Qwrong_type_argument
= intern ("wrong-type-argument");
2963 Qargs_out_of_range
= intern ("args-out-of-range");
2964 Qvoid_function
= intern ("void-function");
2965 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2966 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2967 Qvoid_variable
= intern ("void-variable");
2968 Qsetting_constant
= intern ("setting-constant");
2969 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2971 Qinvalid_function
= intern ("invalid-function");
2972 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2973 Qno_catch
= intern ("no-catch");
2974 Qend_of_file
= intern ("end-of-file");
2975 Qarith_error
= intern ("arith-error");
2976 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2977 Qend_of_buffer
= intern ("end-of-buffer");
2978 Qbuffer_read_only
= intern ("buffer-read-only");
2979 Qtext_read_only
= intern ("text-read-only");
2980 Qmark_inactive
= intern ("mark-inactive");
2982 Qlistp
= intern ("listp");
2983 Qconsp
= intern ("consp");
2984 Qsymbolp
= intern ("symbolp");
2985 Qkeywordp
= intern ("keywordp");
2986 Qintegerp
= intern ("integerp");
2987 Qnatnump
= intern ("natnump");
2988 Qwholenump
= intern ("wholenump");
2989 Qstringp
= intern ("stringp");
2990 Qarrayp
= intern ("arrayp");
2991 Qsequencep
= intern ("sequencep");
2992 Qbufferp
= intern ("bufferp");
2993 Qvectorp
= intern ("vectorp");
2994 Qchar_or_string_p
= intern ("char-or-string-p");
2995 Qmarkerp
= intern ("markerp");
2996 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2997 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2998 Qboundp
= intern ("boundp");
2999 Qfboundp
= intern ("fboundp");
3001 Qfloatp
= intern ("floatp");
3002 Qnumberp
= intern ("numberp");
3003 Qnumber_or_marker_p
= intern ("number-or-marker-p");
3005 Qchar_table_p
= intern ("char-table-p");
3006 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
3008 Qsubrp
= intern ("subrp");
3009 Qunevalled
= intern ("unevalled");
3010 Qmany
= intern ("many");
3012 Qcdr
= intern ("cdr");
3014 /* Handle automatic advice activation */
3015 Qad_advice_info
= intern ("ad-advice-info");
3016 Qad_activate_internal
= intern ("ad-activate-internal");
3018 error_tail
= Fcons (Qerror
, Qnil
);
3020 /* ERROR is used as a signaler for random errors for which nothing else is right */
3022 Fput (Qerror
, Qerror_conditions
,
3024 Fput (Qerror
, Qerror_message
,
3025 build_string ("error"));
3027 Fput (Qquit
, Qerror_conditions
,
3028 Fcons (Qquit
, Qnil
));
3029 Fput (Qquit
, Qerror_message
,
3030 build_string ("Quit"));
3032 Fput (Qwrong_type_argument
, Qerror_conditions
,
3033 Fcons (Qwrong_type_argument
, error_tail
));
3034 Fput (Qwrong_type_argument
, Qerror_message
,
3035 build_string ("Wrong type argument"));
3037 Fput (Qargs_out_of_range
, Qerror_conditions
,
3038 Fcons (Qargs_out_of_range
, error_tail
));
3039 Fput (Qargs_out_of_range
, Qerror_message
,
3040 build_string ("Args out of range"));
3042 Fput (Qvoid_function
, Qerror_conditions
,
3043 Fcons (Qvoid_function
, error_tail
));
3044 Fput (Qvoid_function
, Qerror_message
,
3045 build_string ("Symbol's function definition is void"));
3047 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3048 Fcons (Qcyclic_function_indirection
, error_tail
));
3049 Fput (Qcyclic_function_indirection
, Qerror_message
,
3050 build_string ("Symbol's chain of function indirections contains a loop"));
3052 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3053 Fcons (Qcyclic_variable_indirection
, error_tail
));
3054 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3055 build_string ("Symbol's chain of variable indirections contains a loop"));
3057 Qcircular_list
= intern ("circular-list");
3058 staticpro (&Qcircular_list
);
3059 Fput (Qcircular_list
, Qerror_conditions
,
3060 Fcons (Qcircular_list
, error_tail
));
3061 Fput (Qcircular_list
, Qerror_message
,
3062 build_string ("List contains a loop"));
3064 Fput (Qvoid_variable
, Qerror_conditions
,
3065 Fcons (Qvoid_variable
, error_tail
));
3066 Fput (Qvoid_variable
, Qerror_message
,
3067 build_string ("Symbol's value as variable is void"));
3069 Fput (Qsetting_constant
, Qerror_conditions
,
3070 Fcons (Qsetting_constant
, error_tail
));
3071 Fput (Qsetting_constant
, Qerror_message
,
3072 build_string ("Attempt to set a constant symbol"));
3074 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3075 Fcons (Qinvalid_read_syntax
, error_tail
));
3076 Fput (Qinvalid_read_syntax
, Qerror_message
,
3077 build_string ("Invalid read syntax"));
3079 Fput (Qinvalid_function
, Qerror_conditions
,
3080 Fcons (Qinvalid_function
, error_tail
));
3081 Fput (Qinvalid_function
, Qerror_message
,
3082 build_string ("Invalid function"));
3084 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3085 Fcons (Qwrong_number_of_arguments
, error_tail
));
3086 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3087 build_string ("Wrong number of arguments"));
3089 Fput (Qno_catch
, Qerror_conditions
,
3090 Fcons (Qno_catch
, error_tail
));
3091 Fput (Qno_catch
, Qerror_message
,
3092 build_string ("No catch for tag"));
3094 Fput (Qend_of_file
, Qerror_conditions
,
3095 Fcons (Qend_of_file
, error_tail
));
3096 Fput (Qend_of_file
, Qerror_message
,
3097 build_string ("End of file during parsing"));
3099 arith_tail
= Fcons (Qarith_error
, error_tail
);
3100 Fput (Qarith_error
, Qerror_conditions
,
3102 Fput (Qarith_error
, Qerror_message
,
3103 build_string ("Arithmetic error"));
3105 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3106 Fcons (Qbeginning_of_buffer
, error_tail
));
3107 Fput (Qbeginning_of_buffer
, Qerror_message
,
3108 build_string ("Beginning of buffer"));
3110 Fput (Qend_of_buffer
, Qerror_conditions
,
3111 Fcons (Qend_of_buffer
, error_tail
));
3112 Fput (Qend_of_buffer
, Qerror_message
,
3113 build_string ("End of buffer"));
3115 Fput (Qbuffer_read_only
, Qerror_conditions
,
3116 Fcons (Qbuffer_read_only
, error_tail
));
3117 Fput (Qbuffer_read_only
, Qerror_message
,
3118 build_string ("Buffer is read-only"));
3120 Fput (Qtext_read_only
, Qerror_conditions
,
3121 Fcons (Qtext_read_only
, error_tail
));
3122 Fput (Qtext_read_only
, Qerror_message
,
3123 build_string ("Text is read-only"));
3125 Qrange_error
= intern ("range-error");
3126 Qdomain_error
= intern ("domain-error");
3127 Qsingularity_error
= intern ("singularity-error");
3128 Qoverflow_error
= intern ("overflow-error");
3129 Qunderflow_error
= intern ("underflow-error");
3131 Fput (Qdomain_error
, Qerror_conditions
,
3132 Fcons (Qdomain_error
, arith_tail
));
3133 Fput (Qdomain_error
, Qerror_message
,
3134 build_string ("Arithmetic domain error"));
3136 Fput (Qrange_error
, Qerror_conditions
,
3137 Fcons (Qrange_error
, arith_tail
));
3138 Fput (Qrange_error
, Qerror_message
,
3139 build_string ("Arithmetic range error"));
3141 Fput (Qsingularity_error
, Qerror_conditions
,
3142 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3143 Fput (Qsingularity_error
, Qerror_message
,
3144 build_string ("Arithmetic singularity error"));
3146 Fput (Qoverflow_error
, Qerror_conditions
,
3147 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3148 Fput (Qoverflow_error
, Qerror_message
,
3149 build_string ("Arithmetic overflow error"));
3151 Fput (Qunderflow_error
, Qerror_conditions
,
3152 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3153 Fput (Qunderflow_error
, Qerror_message
,
3154 build_string ("Arithmetic underflow error"));
3156 staticpro (&Qrange_error
);
3157 staticpro (&Qdomain_error
);
3158 staticpro (&Qsingularity_error
);
3159 staticpro (&Qoverflow_error
);
3160 staticpro (&Qunderflow_error
);
3164 staticpro (&Qquote
);
3165 staticpro (&Qlambda
);
3167 staticpro (&Qunbound
);
3168 staticpro (&Qerror_conditions
);
3169 staticpro (&Qerror_message
);
3170 staticpro (&Qtop_level
);
3172 staticpro (&Qerror
);
3174 staticpro (&Qwrong_type_argument
);
3175 staticpro (&Qargs_out_of_range
);
3176 staticpro (&Qvoid_function
);
3177 staticpro (&Qcyclic_function_indirection
);
3178 staticpro (&Qcyclic_variable_indirection
);
3179 staticpro (&Qvoid_variable
);
3180 staticpro (&Qsetting_constant
);
3181 staticpro (&Qinvalid_read_syntax
);
3182 staticpro (&Qwrong_number_of_arguments
);
3183 staticpro (&Qinvalid_function
);
3184 staticpro (&Qno_catch
);
3185 staticpro (&Qend_of_file
);
3186 staticpro (&Qarith_error
);
3187 staticpro (&Qbeginning_of_buffer
);
3188 staticpro (&Qend_of_buffer
);
3189 staticpro (&Qbuffer_read_only
);
3190 staticpro (&Qtext_read_only
);
3191 staticpro (&Qmark_inactive
);
3193 staticpro (&Qlistp
);
3194 staticpro (&Qconsp
);
3195 staticpro (&Qsymbolp
);
3196 staticpro (&Qkeywordp
);
3197 staticpro (&Qintegerp
);
3198 staticpro (&Qnatnump
);
3199 staticpro (&Qwholenump
);
3200 staticpro (&Qstringp
);
3201 staticpro (&Qarrayp
);
3202 staticpro (&Qsequencep
);
3203 staticpro (&Qbufferp
);
3204 staticpro (&Qvectorp
);
3205 staticpro (&Qchar_or_string_p
);
3206 staticpro (&Qmarkerp
);
3207 staticpro (&Qbuffer_or_string_p
);
3208 staticpro (&Qinteger_or_marker_p
);
3209 staticpro (&Qfloatp
);
3210 staticpro (&Qnumberp
);
3211 staticpro (&Qnumber_or_marker_p
);
3212 staticpro (&Qchar_table_p
);
3213 staticpro (&Qvector_or_char_table_p
);
3214 staticpro (&Qsubrp
);
3216 staticpro (&Qunevalled
);
3218 staticpro (&Qboundp
);
3219 staticpro (&Qfboundp
);
3221 staticpro (&Qad_advice_info
);
3222 staticpro (&Qad_activate_internal
);
3224 /* Types that type-of returns. */
3225 Qinteger
= intern ("integer");
3226 Qsymbol
= intern ("symbol");
3227 Qstring
= intern ("string");
3228 Qcons
= intern ("cons");
3229 Qmarker
= intern ("marker");
3230 Qoverlay
= intern ("overlay");
3231 Qfloat
= intern ("float");
3232 Qwindow_configuration
= intern ("window-configuration");
3233 Qprocess
= intern ("process");
3234 Qwindow
= intern ("window");
3235 /* Qsubr = intern ("subr"); */
3236 Qcompiled_function
= intern ("compiled-function");
3237 Qbuffer
= intern ("buffer");
3238 Qframe
= intern ("frame");
3239 Qvector
= intern ("vector");
3240 Qchar_table
= intern ("char-table");
3241 Qbool_vector
= intern ("bool-vector");
3242 Qhash_table
= intern ("hash-table");
3244 staticpro (&Qinteger
);
3245 staticpro (&Qsymbol
);
3246 staticpro (&Qstring
);
3248 staticpro (&Qmarker
);
3249 staticpro (&Qoverlay
);
3250 staticpro (&Qfloat
);
3251 staticpro (&Qwindow_configuration
);
3252 staticpro (&Qprocess
);
3253 staticpro (&Qwindow
);
3254 /* staticpro (&Qsubr); */
3255 staticpro (&Qcompiled_function
);
3256 staticpro (&Qbuffer
);
3257 staticpro (&Qframe
);
3258 staticpro (&Qvector
);
3259 staticpro (&Qchar_table
);
3260 staticpro (&Qbool_vector
);
3261 staticpro (&Qhash_table
);
3263 defsubr (&Sindirect_variable
);
3264 defsubr (&Sinteractive_form
);
3267 defsubr (&Stype_of
);
3272 defsubr (&Sintegerp
);
3273 defsubr (&Sinteger_or_marker_p
);
3274 defsubr (&Snumberp
);
3275 defsubr (&Snumber_or_marker_p
);
3277 defsubr (&Snatnump
);
3278 defsubr (&Ssymbolp
);
3279 defsubr (&Skeywordp
);
3280 defsubr (&Sstringp
);
3281 defsubr (&Smultibyte_string_p
);
3282 defsubr (&Svectorp
);
3283 defsubr (&Schar_table_p
);
3284 defsubr (&Svector_or_char_table_p
);
3285 defsubr (&Sbool_vector_p
);
3287 defsubr (&Ssequencep
);
3288 defsubr (&Sbufferp
);
3289 defsubr (&Smarkerp
);
3291 defsubr (&Sbyte_code_function_p
);
3292 defsubr (&Schar_or_string_p
);
3295 defsubr (&Scar_safe
);
3296 defsubr (&Scdr_safe
);
3299 defsubr (&Ssymbol_function
);
3300 defsubr (&Sindirect_function
);
3301 defsubr (&Ssymbol_plist
);
3302 defsubr (&Ssymbol_name
);
3303 defsubr (&Smakunbound
);
3304 defsubr (&Sfmakunbound
);
3306 defsubr (&Sfboundp
);
3308 defsubr (&Sdefalias
);
3309 defsubr (&Ssetplist
);
3310 defsubr (&Ssymbol_value
);
3312 defsubr (&Sdefault_boundp
);
3313 defsubr (&Sdefault_value
);
3314 defsubr (&Sset_default
);
3315 defsubr (&Ssetq_default
);
3316 defsubr (&Smake_variable_buffer_local
);
3317 defsubr (&Smake_local_variable
);
3318 defsubr (&Skill_local_variable
);
3319 defsubr (&Smake_variable_frame_local
);
3320 defsubr (&Slocal_variable_p
);
3321 defsubr (&Slocal_variable_if_set_p
);
3322 defsubr (&Svariable_binding_locus
);
3325 defsubr (&Snumber_to_string
);
3326 defsubr (&Sstring_to_number
);
3327 defsubr (&Seqlsign
);
3350 defsubr (&Sbyteorder
);
3351 defsubr (&Ssubr_arity
);
3352 defsubr (&Ssubr_name
);
3354 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3356 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3357 doc
: /* The largest value that is representable in a Lisp integer. */);
3358 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3360 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3361 doc
: /* The smallest value that is representable in a Lisp integer. */);
3362 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3369 #if defined(USG) && !defined(POSIX_SIGNALS)
3370 /* USG systems forget handlers when they are used;
3371 must reestablish each time */
3372 signal (signo
, arith_error
);
3375 /* VMS systems are like USG. */
3376 signal (signo
, arith_error
);
3380 #else /* not BSD4_1 */
3381 sigsetmask (SIGEMPTYMASK
);
3382 #endif /* not BSD4_1 */
3384 SIGNAL_THREAD_CHECK (signo
);
3385 Fsignal (Qarith_error
, Qnil
);
3391 /* Don't do this if just dumping out.
3392 We don't want to call `signal' in this case
3393 so that we don't have trouble with dumping
3394 signal-delivering routines in an inconsistent state. */
3398 #endif /* CANNOT_DUMP */
3399 signal (SIGFPE
, arith_error
);
3402 signal (SIGEMT
, arith_error
);
3406 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3407 (do not change this comment) */