1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
53 extern double atof (const char *);
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
86 static Lisp_Object Qfloat
, Qwindow_configuration
;
88 static Lisp_Object Qcompiled_function
, Qfunction_vector
, Qbuffer
, Qframe
, Qvector
;
89 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
90 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
91 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
93 Lisp_Object Qinteractive_form
;
95 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
97 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
101 circular_list_error (Lisp_Object list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
110 /* If VALUE is not even a valid Lisp object, we'd want to abort here
111 where we can get a backtrace showing where it came from. We used
112 to try and do that by checking the tagbits, but nowadays all
113 tagbits are potentially valid. */
114 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
117 xsignal2 (Qwrong_type_argument
, predicate
, value
);
121 pure_write_error (void)
123 error ("Attempt to modify read-only object");
127 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
129 xsignal2 (Qargs_out_of_range
, a1
, a2
);
133 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
135 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
138 /* On some machines, XINT needs a temporary location.
139 Here it is, in case it is needed. */
141 int sign_extend_temp
;
143 /* On a few machines, XINT can only be done by calling this. */
146 sign_extend_lisp_int (EMACS_INT num
)
148 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
149 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
151 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
154 /* Data type predicates */
156 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
157 doc
: /* Return t if the two args are the same Lisp object. */)
158 (Lisp_Object obj1
, Lisp_Object obj2
)
165 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
166 doc
: /* Return t if OBJECT is nil. */)
174 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
175 doc
: /* Return a symbol representing the type of OBJECT.
176 The symbol returned names the object's basic type;
177 for example, (type-of 1) returns `integer'. */)
180 switch (XTYPE (object
))
195 switch (XMISCTYPE (object
))
197 case Lisp_Misc_Marker
:
199 case Lisp_Misc_Overlay
:
201 case Lisp_Misc_Float
:
206 case Lisp_Vectorlike
:
207 if (WINDOW_CONFIGURATIONP (object
))
208 return Qwindow_configuration
;
209 if (PROCESSP (object
))
211 if (WINDOWP (object
))
215 if (FUNVECP (object
))
216 if (FUNVEC_COMPILED_P (object
))
217 return Qcompiled_function
;
219 return Qfunction_vector
;
220 if (BUFFERP (object
))
222 if (CHAR_TABLE_P (object
))
224 if (BOOL_VECTOR_P (object
))
228 if (HASH_TABLE_P (object
))
230 if (FONT_SPEC_P (object
))
232 if (FONT_ENTITY_P (object
))
234 if (FONT_OBJECT_P (object
))
246 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
247 doc
: /* Return t if OBJECT is a cons cell. */)
255 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
256 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
264 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
265 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
266 Otherwise, return nil. */)
269 if (CONSP (object
) || NILP (object
))
274 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
275 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
278 if (CONSP (object
) || NILP (object
))
283 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
284 doc
: /* Return t if OBJECT is a symbol. */)
287 if (SYMBOLP (object
))
292 /* Define this in C to avoid unnecessarily consing up the symbol
294 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
295 doc
: /* Return t if OBJECT is a keyword.
296 This means that it is a symbol with a print name beginning with `:'
297 interned in the initial obarray. */)
301 && SREF (SYMBOL_NAME (object
), 0) == ':'
302 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
307 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
308 doc
: /* Return t if OBJECT is a vector. */)
311 if (VECTORP (object
))
316 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
317 doc
: /* Return t if OBJECT is a string. */)
320 if (STRINGP (object
))
325 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
327 doc
: /* Return t if OBJECT is a multibyte string. */)
330 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
335 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
336 doc
: /* Return t if OBJECT is a char-table. */)
339 if (CHAR_TABLE_P (object
))
344 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
345 Svector_or_char_table_p
, 1, 1, 0,
346 doc
: /* Return t if OBJECT is a char-table or vector. */)
349 if (VECTORP (object
) || CHAR_TABLE_P (object
))
354 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
355 doc
: /* Return t if OBJECT is a bool-vector. */)
358 if (BOOL_VECTOR_P (object
))
363 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
364 doc
: /* Return t if OBJECT is an array (string or vector). */)
372 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
373 doc
: /* Return t if OBJECT is a sequence (list or array). */)
374 (register Lisp_Object object
)
376 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
381 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
382 doc
: /* Return t if OBJECT is an editor buffer. */)
385 if (BUFFERP (object
))
390 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
391 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
394 if (MARKERP (object
))
399 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
400 doc
: /* Return t if OBJECT is a built-in function. */)
408 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
410 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
413 if (COMPILEDP (object
))
418 DEFUN ("funvecp", Ffunvecp
, Sfunvecp
, 1, 1, 0,
419 doc
: /* Return t if OBJECT is a `function vector' object. */)
422 return FUNVECP (object
) ? Qt
: Qnil
;
425 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
426 doc
: /* Return t if OBJECT is a character or a string. */)
427 (register Lisp_Object object
)
429 if (CHARACTERP (object
) || STRINGP (object
))
434 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
435 doc
: /* Return t if OBJECT is an integer. */)
438 if (INTEGERP (object
))
443 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
444 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
445 (register Lisp_Object object
)
447 if (MARKERP (object
) || INTEGERP (object
))
452 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
453 doc
: /* Return t if OBJECT is a nonnegative integer. */)
456 if (NATNUMP (object
))
461 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
462 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
465 if (NUMBERP (object
))
471 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
472 Snumber_or_marker_p
, 1, 1, 0,
473 doc
: /* Return t if OBJECT is a number or a marker. */)
476 if (NUMBERP (object
) || MARKERP (object
))
481 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
482 doc
: /* Return t if OBJECT is a floating point number. */)
491 /* Extract and set components of lists */
493 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
494 doc
: /* Return the car of LIST. If arg is nil, return nil.
495 Error if arg is not nil and not a cons cell. See also `car-safe'.
497 See Info node `(elisp)Cons Cells' for a discussion of related basic
498 Lisp concepts such as car, cdr, cons cell and list. */)
499 (register Lisp_Object list
)
504 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
505 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
508 return CAR_SAFE (object
);
511 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
512 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
513 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
515 See Info node `(elisp)Cons Cells' for a discussion of related basic
516 Lisp concepts such as cdr, car, cons cell and list. */)
517 (register Lisp_Object list
)
522 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
523 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
526 return CDR_SAFE (object
);
529 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
530 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
531 (register Lisp_Object cell
, Lisp_Object newcar
)
535 XSETCAR (cell
, newcar
);
539 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
540 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
541 (register Lisp_Object cell
, Lisp_Object newcdr
)
545 XSETCDR (cell
, newcdr
);
549 /* Extract and set components of symbols */
551 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
552 doc
: /* Return t if SYMBOL's value is not void. */)
553 (register Lisp_Object symbol
)
555 Lisp_Object valcontents
;
556 struct Lisp_Symbol
*sym
;
557 CHECK_SYMBOL (symbol
);
558 sym
= XSYMBOL (symbol
);
561 switch (sym
->redirect
)
563 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
564 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
565 case SYMBOL_LOCALIZED
:
567 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
569 /* In set_internal, we un-forward vars when their value is
574 swap_in_symval_forwarding (sym
, blv
);
575 valcontents
= BLV_VALUE (blv
);
579 case SYMBOL_FORWARDED
:
580 /* In set_internal, we un-forward vars when their value is
586 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
589 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
590 doc
: /* Return t if SYMBOL's function definition is not void. */)
591 (register Lisp_Object symbol
)
593 CHECK_SYMBOL (symbol
);
594 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
597 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
598 doc
: /* Make SYMBOL's value be void.
600 (register Lisp_Object symbol
)
602 CHECK_SYMBOL (symbol
);
603 if (SYMBOL_CONSTANT_P (symbol
))
604 xsignal1 (Qsetting_constant
, symbol
);
605 Fset (symbol
, Qunbound
);
609 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
610 doc
: /* Make SYMBOL's function definition be void.
612 (register Lisp_Object symbol
)
614 CHECK_SYMBOL (symbol
);
615 if (NILP (symbol
) || EQ (symbol
, Qt
))
616 xsignal1 (Qsetting_constant
, symbol
);
617 XSYMBOL (symbol
)->function
= Qunbound
;
621 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
622 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
623 (register Lisp_Object symbol
)
625 CHECK_SYMBOL (symbol
);
626 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
627 return XSYMBOL (symbol
)->function
;
628 xsignal1 (Qvoid_function
, symbol
);
631 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
632 doc
: /* Return SYMBOL's property list. */)
633 (register Lisp_Object symbol
)
635 CHECK_SYMBOL (symbol
);
636 return XSYMBOL (symbol
)->plist
;
639 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
640 doc
: /* Return SYMBOL's name, a string. */)
641 (register Lisp_Object symbol
)
643 register Lisp_Object name
;
645 CHECK_SYMBOL (symbol
);
646 name
= SYMBOL_NAME (symbol
);
650 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
651 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
652 (register Lisp_Object symbol
, Lisp_Object definition
)
654 register Lisp_Object function
;
656 CHECK_SYMBOL (symbol
);
657 if (NILP (symbol
) || EQ (symbol
, Qt
))
658 xsignal1 (Qsetting_constant
, symbol
);
660 function
= XSYMBOL (symbol
)->function
;
662 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
663 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
665 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
666 Fput (symbol
, Qautoload
, XCDR (function
));
668 XSYMBOL (symbol
)->function
= definition
;
669 /* Handle automatic advice activation */
670 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
672 call2 (Qad_activate_internal
, symbol
, Qnil
);
673 definition
= XSYMBOL (symbol
)->function
;
678 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
679 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
680 Associates the function with the current load file, if any.
681 The optional third argument DOCSTRING specifies the documentation string
682 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
683 determined by DEFINITION. */)
684 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
686 CHECK_SYMBOL (symbol
);
687 if (CONSP (XSYMBOL (symbol
)->function
)
688 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
689 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
690 definition
= Ffset (symbol
, definition
);
691 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
692 if (!NILP (docstring
))
693 Fput (symbol
, Qfunction_documentation
, docstring
);
697 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
698 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
699 (register Lisp_Object symbol
, Lisp_Object newplist
)
701 CHECK_SYMBOL (symbol
);
702 XSYMBOL (symbol
)->plist
= newplist
;
706 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
707 doc
: /* Return minimum and maximum number of args allowed for SUBR.
708 SUBR must be a built-in function.
709 The returned value is a pair (MIN . MAX). MIN is the minimum number
710 of args. MAX is the maximum number or the symbol `many', for a
711 function with `&rest' args, or `unevalled' for a special form. */)
714 short minargs
, maxargs
;
716 minargs
= XSUBR (subr
)->min_args
;
717 maxargs
= XSUBR (subr
)->max_args
;
719 return Fcons (make_number (minargs
), Qmany
);
720 else if (maxargs
== UNEVALLED
)
721 return Fcons (make_number (minargs
), Qunevalled
);
723 return Fcons (make_number (minargs
), make_number (maxargs
));
726 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
727 doc
: /* Return name of subroutine SUBR.
728 SUBR must be a built-in function. */)
733 name
= XSUBR (subr
)->symbol_name
;
734 return make_string (name
, strlen (name
));
737 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
738 doc
: /* Return the interactive form of CMD or nil if none.
739 If CMD is not a command, the return value is nil.
740 Value, if non-nil, is a list \(interactive SPEC). */)
743 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
745 if (NILP (fun
) || EQ (fun
, Qunbound
))
748 /* Use an `interactive-form' property if present, analogous to the
749 function-documentation property. */
751 while (SYMBOLP (fun
))
753 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
757 fun
= Fsymbol_function (fun
);
762 const char *spec
= XSUBR (fun
)->intspec
;
764 return list2 (Qinteractive
,
765 (*spec
!= '(') ? build_string (spec
) :
766 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
768 else if (COMPILEDP (fun
))
770 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
771 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
773 else if (CONSP (fun
))
775 Lisp_Object funcar
= XCAR (fun
);
776 if (EQ (funcar
, Qlambda
))
777 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
778 else if (EQ (funcar
, Qautoload
))
782 do_autoload (fun
, cmd
);
784 return Finteractive_form (cmd
);
791 /***********************************************************************
792 Getting and Setting Values of Symbols
793 ***********************************************************************/
795 /* Return the symbol holding SYMBOL's value. Signal
796 `cyclic-variable-indirection' if SYMBOL's chain of variable
797 indirections contains a loop. */
800 indirect_variable (struct Lisp_Symbol
*symbol
)
802 struct Lisp_Symbol
*tortoise
, *hare
;
804 hare
= tortoise
= symbol
;
806 while (hare
->redirect
== SYMBOL_VARALIAS
)
808 hare
= SYMBOL_ALIAS (hare
);
809 if (hare
->redirect
!= SYMBOL_VARALIAS
)
812 hare
= SYMBOL_ALIAS (hare
);
813 tortoise
= SYMBOL_ALIAS (tortoise
);
815 if (hare
== tortoise
)
818 XSETSYMBOL (tem
, symbol
);
819 xsignal1 (Qcyclic_variable_indirection
, tem
);
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. */)
835 if (SYMBOLP (object
))
836 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
841 /* Given the raw contents of a symbol value cell,
842 return the Lisp value of the symbol.
843 This does not handle buffer-local variables; use
844 swap_in_symval_forwarding for that. */
846 #define do_blv_forwarding(blv) \
847 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
850 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
852 register Lisp_Object val
;
853 switch (XFWDTYPE (valcontents
))
856 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
860 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
863 return *XOBJFWD (valcontents
)->objvar
;
865 case Lisp_Fwd_Buffer_Obj
:
866 return PER_BUFFER_VALUE (current_buffer
,
867 XBUFFER_OBJFWD (valcontents
)->offset
);
869 case Lisp_Fwd_Kboard_Obj
:
870 /* We used to simply use current_kboard here, but from Lisp
871 code, it's value is often unexpected. It seems nicer to
872 allow constructions like this to work as intuitively expected:
874 (with-selected-frame frame
875 (define-key local-function-map "\eOP" [f1]))
877 On the other hand, this affects the semantics of
878 last-command and real-last-command, and people may rely on
879 that. I took a quick look at the Lisp codebase, and I
880 don't think anything will break. --lorentey */
881 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
882 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
887 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
888 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
889 buffer-independent contents of the value cell: forwarded just one
890 step past the buffer-localness.
892 BUF non-zero means set the value in buffer BUF instead of the
893 current buffer. This only plays a role for per-buffer variables. */
895 #define store_blv_forwarding(blv, newval, buf) \
897 if ((blv)->forwarded) \
898 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
900 SET_BLV_VALUE (blv, newval); \
904 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
906 switch (XFWDTYPE (valcontents
))
909 CHECK_NUMBER (newval
);
910 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
914 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
918 *XOBJFWD (valcontents
)->objvar
= newval
;
920 /* If this variable is a default for something stored
921 in the buffer itself, such as default-fill-column,
922 find the buffers that don't have local values for it
924 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
925 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
927 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
928 - (char *) &buffer_defaults
);
929 int idx
= PER_BUFFER_IDX (offset
);
936 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
941 buf
= Fcdr (XCAR (tail
));
942 if (!BUFFERP (buf
)) continue;
945 if (! PER_BUFFER_VALUE_P (b
, idx
))
946 PER_BUFFER_VALUE (b
, offset
) = newval
;
951 case Lisp_Fwd_Buffer_Obj
:
953 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
954 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
956 if (!(NILP (type
) || NILP (newval
)
957 || (XINT (type
) == LISP_INT_TAG
959 : XTYPE (newval
) == XINT (type
))))
960 buffer_slot_type_mismatch (newval
, XINT (type
));
963 buf
= current_buffer
;
964 PER_BUFFER_VALUE (buf
, offset
) = newval
;
968 case Lisp_Fwd_Kboard_Obj
:
970 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
971 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
972 *(Lisp_Object
*) p
= newval
;
977 abort (); /* goto def; */
981 /* Set up SYMBOL to refer to its global binding.
982 This makes it safe to alter the status of other bindings. */
985 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
987 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
989 /* Unload the previously loaded binding. */
991 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
993 /* Select the global binding in the symbol. */
994 blv
->valcell
= blv
->defcell
;
996 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
998 /* Indicate that the global binding is set up now. */
1000 SET_BLV_FOUND (blv
, 0);
1003 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1004 VALCONTENTS is the contents of its value cell,
1005 which points to a struct Lisp_Buffer_Local_Value.
1007 Return the value forwarded one step past the buffer-local stage.
1008 This could be another forwarding pointer. */
1011 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1013 register Lisp_Object tem1
;
1015 eassert (blv
== SYMBOL_BLV (symbol
));
1020 || (blv
->frame_local
1021 ? !EQ (selected_frame
, tem1
)
1022 : current_buffer
!= XBUFFER (tem1
)))
1025 /* Unload the previously loaded binding. */
1026 tem1
= blv
->valcell
;
1028 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1029 /* Choose the new binding. */
1032 XSETSYMBOL (var
, symbol
);
1033 if (blv
->frame_local
)
1035 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1036 blv
->where
= selected_frame
;
1040 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1041 XSETBUFFER (blv
->where
, current_buffer
);
1044 if (!(blv
->found
= !NILP (tem1
)))
1045 tem1
= blv
->defcell
;
1047 /* Load the new binding. */
1048 blv
->valcell
= tem1
;
1050 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1054 /* Find the value of a symbol, returning Qunbound if it's not bound.
1055 This is helpful for code which just wants to get a variable's value
1056 if it has one, without signaling an error.
1057 Note that it must not be possible to quit
1058 within this function. Great care is required for this. */
1061 find_symbol_value (Lisp_Object symbol
)
1063 struct Lisp_Symbol
*sym
;
1065 CHECK_SYMBOL (symbol
);
1066 sym
= XSYMBOL (symbol
);
1069 switch (sym
->redirect
)
1071 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1072 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1073 case SYMBOL_LOCALIZED
:
1075 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1076 swap_in_symval_forwarding (sym
, blv
);
1077 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1080 case SYMBOL_FORWARDED
:
1081 return do_symval_forwarding (SYMBOL_FWD (sym
));
1086 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1087 doc
: /* Return SYMBOL's value. Error if that is void. */)
1088 (Lisp_Object symbol
)
1092 val
= find_symbol_value (symbol
);
1093 if (!EQ (val
, Qunbound
))
1096 xsignal1 (Qvoid_variable
, symbol
);
1099 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1100 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1101 (register Lisp_Object symbol
, Lisp_Object newval
)
1103 set_internal (symbol
, newval
, Qnil
, 0);
1107 /* Return 1 if SYMBOL currently has a let-binding
1108 which was made in the buffer that is now current. */
1111 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1113 struct specbinding
*p
;
1115 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1117 && CONSP (p
->symbol
))
1119 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1120 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1121 if (symbol
== let_bound_symbol
1122 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1126 return p
>= specpdl
;
1130 let_shadows_global_binding_p (Lisp_Object symbol
)
1132 struct specbinding
*p
;
1134 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1135 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1138 return p
>= specpdl
;
1141 /* Store the value NEWVAL into SYMBOL.
1142 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1143 (nil stands for the current buffer/frame).
1145 If BINDFLAG is zero, then if this symbol is supposed to become
1146 local in every buffer where it is set, then we make it local.
1147 If BINDFLAG is nonzero, we don't do that. */
1150 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1152 int voide
= EQ (newval
, Qunbound
);
1153 struct Lisp_Symbol
*sym
;
1156 /* If restoring in a dead buffer, do nothing. */
1157 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1160 CHECK_SYMBOL (symbol
);
1161 if (SYMBOL_CONSTANT_P (symbol
))
1163 if (NILP (Fkeywordp (symbol
))
1164 || !EQ (newval
, Fsymbol_value (symbol
)))
1165 xsignal1 (Qsetting_constant
, symbol
);
1167 /* Allow setting keywords to their own value. */
1171 sym
= XSYMBOL (symbol
);
1174 switch (sym
->redirect
)
1176 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1177 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1178 case SYMBOL_LOCALIZED
:
1180 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1183 if (blv
->frame_local
)
1184 where
= selected_frame
;
1186 XSETBUFFER (where
, current_buffer
);
1188 /* If the current buffer is not the buffer whose binding is
1189 loaded, or if there may be frame-local bindings and the frame
1190 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1191 the default binding is loaded, the loaded binding may be the
1193 if (!EQ (blv
->where
, where
)
1194 /* Also unload a global binding (if the var is local_if_set). */
1195 || (EQ (blv
->valcell
, blv
->defcell
)))
1197 /* The currently loaded binding is not necessarily valid.
1198 We need to unload it, and choose a new binding. */
1200 /* Write out `realvalue' to the old loaded binding. */
1202 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1204 /* Find the new binding. */
1205 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1206 tem1
= Fassq (symbol
,
1208 ? XFRAME (where
)->param_alist
1209 : XBUFFER (where
)->local_var_alist
));
1215 /* This buffer still sees the default value. */
1217 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1218 or if this is `let' rather than `set',
1219 make CURRENT-ALIST-ELEMENT point to itself,
1220 indicating that we're seeing the default value.
1221 Likewise if the variable has been let-bound
1222 in the current buffer. */
1223 if (bindflag
|| !blv
->local_if_set
1224 || let_shadows_buffer_binding_p (sym
))
1227 tem1
= blv
->defcell
;
1229 /* If it's a local_if_set, being set not bound,
1230 and we're not within a let that was made for this buffer,
1231 create a new buffer-local binding for the variable.
1232 That means, give this buffer a new assoc for a local value
1233 and load that binding. */
1236 /* local_if_set is only supported for buffer-local
1237 bindings, not for frame-local bindings. */
1238 eassert (!blv
->frame_local
);
1239 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1240 XBUFFER (where
)->local_var_alist
1241 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1245 /* Record which binding is now loaded. */
1246 blv
->valcell
= tem1
;
1249 /* Store the new value in the cons cell. */
1250 SET_BLV_VALUE (blv
, newval
);
1255 /* If storing void (making the symbol void), forward only through
1256 buffer-local indicator, not through Lisp_Objfwd, etc. */
1259 store_symval_forwarding (blv
->fwd
, newval
,
1261 ? XBUFFER (where
) : current_buffer
);
1265 case SYMBOL_FORWARDED
:
1268 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1269 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1270 if (BUFFER_OBJFWDP (innercontents
))
1272 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1273 int idx
= PER_BUFFER_IDX (offset
);
1276 && !let_shadows_buffer_binding_p (sym
))
1277 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1281 { /* If storing void (making the symbol void), forward only through
1282 buffer-local indicator, not through Lisp_Objfwd, etc. */
1283 sym
->redirect
= SYMBOL_PLAINVAL
;
1284 SET_SYMBOL_VAL (sym
, newval
);
1287 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1295 /* Access or set a buffer-local symbol's default value. */
1297 /* Return the default value of SYMBOL, but don't check for voidness.
1298 Return Qunbound if it is void. */
1301 default_value (Lisp_Object symbol
)
1303 struct Lisp_Symbol
*sym
;
1305 CHECK_SYMBOL (symbol
);
1306 sym
= XSYMBOL (symbol
);
1309 switch (sym
->redirect
)
1311 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1312 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1313 case SYMBOL_LOCALIZED
:
1315 /* If var is set up for a buffer that lacks a local value for it,
1316 the current value is nominally the default value.
1317 But the `realvalue' slot may be more up to date, since
1318 ordinary setq stores just that slot. So use that. */
1319 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1320 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1321 return do_symval_forwarding (blv
->fwd
);
1323 return XCDR (blv
->defcell
);
1325 case SYMBOL_FORWARDED
:
1327 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1329 /* For a built-in buffer-local variable, get the default value
1330 rather than letting do_symval_forwarding get the current value. */
1331 if (BUFFER_OBJFWDP (valcontents
))
1333 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1334 if (PER_BUFFER_IDX (offset
) != 0)
1335 return PER_BUFFER_DEFAULT (offset
);
1338 /* For other variables, get the current value. */
1339 return do_symval_forwarding (valcontents
);
1345 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1346 doc
: /* Return t if SYMBOL has a non-void default value.
1347 This is the value that is seen in buffers that do not have their own values
1348 for this variable. */)
1349 (Lisp_Object symbol
)
1351 register Lisp_Object value
;
1353 value
= default_value (symbol
);
1354 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1357 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1358 doc
: /* Return SYMBOL's default value.
1359 This is the value that is seen in buffers that do not have their own values
1360 for this variable. The default value is meaningful for variables with
1361 local bindings in certain buffers. */)
1362 (Lisp_Object symbol
)
1364 register Lisp_Object value
;
1366 value
= default_value (symbol
);
1367 if (!EQ (value
, Qunbound
))
1370 xsignal1 (Qvoid_variable
, symbol
);
1373 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1374 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1375 The default value is seen in buffers that do not have their own values
1376 for this variable. */)
1377 (Lisp_Object symbol
, Lisp_Object value
)
1379 struct Lisp_Symbol
*sym
;
1381 CHECK_SYMBOL (symbol
);
1382 if (SYMBOL_CONSTANT_P (symbol
))
1384 if (NILP (Fkeywordp (symbol
))
1385 || !EQ (value
, Fdefault_value (symbol
)))
1386 xsignal1 (Qsetting_constant
, symbol
);
1388 /* Allow setting keywords to their own value. */
1391 sym
= XSYMBOL (symbol
);
1394 switch (sym
->redirect
)
1396 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1397 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1398 case SYMBOL_LOCALIZED
:
1400 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1402 /* Store new value into the DEFAULT-VALUE slot. */
1403 XSETCDR (blv
->defcell
, value
);
1405 /* If the default binding is now loaded, set the REALVALUE slot too. */
1406 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1407 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1410 case SYMBOL_FORWARDED
:
1412 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1414 /* Handle variables like case-fold-search that have special slots
1416 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1417 if (BUFFER_OBJFWDP (valcontents
))
1419 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1420 int idx
= PER_BUFFER_IDX (offset
);
1422 PER_BUFFER_DEFAULT (offset
) = value
;
1424 /* If this variable is not always local in all buffers,
1425 set it in the buffers that don't nominally have a local value. */
1430 for (b
= all_buffers
; b
; b
= b
->next
)
1431 if (!PER_BUFFER_VALUE_P (b
, idx
))
1432 PER_BUFFER_VALUE (b
, offset
) = value
;
1437 return Fset (symbol
, value
);
1443 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1444 doc
: /* Set the default value of variable VAR to VALUE.
1445 VAR, the variable name, is literal (not evaluated);
1446 VALUE is an expression: it is evaluated and its value returned.
1447 The default value of a variable is seen in buffers
1448 that do not have their own values for the variable.
1450 More generally, you can use multiple variables and values, as in
1451 (setq-default VAR VALUE VAR VALUE...)
1452 This sets each VAR's default value to the corresponding VALUE.
1453 The VALUE for the Nth VAR can refer to the new default values
1455 usage: (setq-default [VAR VALUE]...) */)
1458 register Lisp_Object args_left
;
1459 register Lisp_Object val
, symbol
;
1460 struct gcpro gcpro1
;
1470 val
= Feval (Fcar (Fcdr (args_left
)));
1471 symbol
= XCAR (args_left
);
1472 Fset_default (symbol
, val
);
1473 args_left
= Fcdr (XCDR (args_left
));
1475 while (!NILP (args_left
));
1481 /* Lisp functions for creating and removing buffer-local variables. */
1486 union Lisp_Fwd
*fwd
;
1489 static struct Lisp_Buffer_Local_Value
*
1490 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1492 struct Lisp_Buffer_Local_Value
*blv
1493 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1497 XSETSYMBOL (symbol
, sym
);
1498 tem
= Fcons (symbol
, (forwarded
1499 ? do_symval_forwarding (valcontents
.fwd
)
1500 : valcontents
.value
));
1502 /* Buffer_Local_Values cannot have as realval a buffer-local
1503 or keyboard-local forwarding. */
1504 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1505 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1506 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1508 blv
->frame_local
= 0;
1509 blv
->local_if_set
= 0;
1512 SET_BLV_FOUND (blv
, 0);
1516 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1517 1, 1, "vMake Variable Buffer Local: ",
1518 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1519 At any time, the value for the current buffer is in effect,
1520 unless the variable has never been set in this buffer,
1521 in which case the default value is in effect.
1522 Note that binding the variable with `let', or setting it while
1523 a `let'-style binding made in this buffer is in effect,
1524 does not make the variable buffer-local. Return VARIABLE.
1526 In most cases it is better to use `make-local-variable',
1527 which makes a variable local in just one buffer.
1529 The function `default-value' gets the default value and `set-default' sets it. */)
1530 (register Lisp_Object variable
)
1532 struct Lisp_Symbol
*sym
;
1533 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1534 union Lisp_Val_Fwd valcontents
;
1537 CHECK_SYMBOL (variable
);
1538 sym
= XSYMBOL (variable
);
1541 switch (sym
->redirect
)
1543 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1544 case SYMBOL_PLAINVAL
:
1545 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1546 if (EQ (valcontents
.value
, Qunbound
))
1547 valcontents
.value
= Qnil
;
1549 case SYMBOL_LOCALIZED
:
1550 blv
= SYMBOL_BLV (sym
);
1551 if (blv
->frame_local
)
1552 error ("Symbol %s may not be buffer-local",
1553 SDATA (SYMBOL_NAME (variable
)));
1555 case SYMBOL_FORWARDED
:
1556 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1557 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1558 error ("Symbol %s may not be buffer-local",
1559 SDATA (SYMBOL_NAME (variable
)));
1560 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1567 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1571 blv
= make_blv (sym
, forwarded
, valcontents
);
1572 sym
->redirect
= SYMBOL_LOCALIZED
;
1573 SET_SYMBOL_BLV (sym
, blv
);
1576 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1577 if (let_shadows_global_binding_p (symbol
))
1578 message ("Making %s buffer-local while let-bound!",
1579 SDATA (SYMBOL_NAME (variable
)));
1583 blv
->local_if_set
= 1;
1587 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1588 1, 1, "vMake Local Variable: ",
1589 doc
: /* Make VARIABLE have a separate value in the current buffer.
1590 Other buffers will continue to share a common default value.
1591 \(The buffer-local value of VARIABLE starts out as the same value
1592 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1595 If the variable is already arranged to become local when set,
1596 this function causes a local value to exist for this buffer,
1597 just as setting the variable would do.
1599 This function returns VARIABLE, and therefore
1600 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1603 See also `make-variable-buffer-local'.
1605 Do not use `make-local-variable' to make a hook variable buffer-local.
1606 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1607 (register Lisp_Object variable
)
1609 register Lisp_Object tem
;
1611 union Lisp_Val_Fwd valcontents
;
1612 struct Lisp_Symbol
*sym
;
1613 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1615 CHECK_SYMBOL (variable
);
1616 sym
= XSYMBOL (variable
);
1619 switch (sym
->redirect
)
1621 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1622 case SYMBOL_PLAINVAL
:
1623 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1624 case SYMBOL_LOCALIZED
:
1625 blv
= SYMBOL_BLV (sym
);
1626 if (blv
->frame_local
)
1627 error ("Symbol %s may not be buffer-local",
1628 SDATA (SYMBOL_NAME (variable
)));
1630 case SYMBOL_FORWARDED
:
1631 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1632 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1633 error ("Symbol %s may not be buffer-local",
1634 SDATA (SYMBOL_NAME (variable
)));
1640 error ("Symbol %s may not be buffer-local",
1641 SDATA (SYMBOL_NAME (variable
)));
1643 if (blv
? blv
->local_if_set
1644 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1646 tem
= Fboundp (variable
);
1647 /* Make sure the symbol has a local value in this particular buffer,
1648 by setting it to the same value it already has. */
1649 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1654 blv
= make_blv (sym
, forwarded
, valcontents
);
1655 sym
->redirect
= SYMBOL_LOCALIZED
;
1656 SET_SYMBOL_BLV (sym
, blv
);
1659 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1660 if (let_shadows_global_binding_p (symbol
))
1661 message ("Making %s local to %s while let-bound!",
1662 SDATA (SYMBOL_NAME (variable
)),
1663 SDATA (current_buffer
->name
));
1667 /* Make sure this buffer has its own value of symbol. */
1668 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1669 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1672 if (let_shadows_buffer_binding_p (sym
))
1673 message ("Making %s buffer-local while locally let-bound!",
1674 SDATA (SYMBOL_NAME (variable
)));
1676 /* Swap out any local binding for some other buffer, and make
1677 sure the current value is permanently recorded, if it's the
1679 find_symbol_value (variable
);
1681 current_buffer
->local_var_alist
1682 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1683 current_buffer
->local_var_alist
);
1685 /* Make sure symbol does not think it is set up for this buffer;
1686 force it to look once again for this buffer's value. */
1687 if (current_buffer
== XBUFFER (blv
->where
))
1689 /* blv->valcell = blv->defcell;
1690 * SET_BLV_FOUND (blv, 0); */
1694 /* If the symbol forwards into a C variable, then load the binding
1695 for this buffer now. If C code modifies the variable before we
1696 load the binding in, then that new value will clobber the default
1697 binding the next time we unload it. */
1699 swap_in_symval_forwarding (sym
, blv
);
1704 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1705 1, 1, "vKill Local Variable: ",
1706 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1707 From now on the default value will apply in this buffer. Return VARIABLE. */)
1708 (register Lisp_Object variable
)
1710 register Lisp_Object tem
;
1711 struct Lisp_Buffer_Local_Value
*blv
;
1712 struct Lisp_Symbol
*sym
;
1714 CHECK_SYMBOL (variable
);
1715 sym
= XSYMBOL (variable
);
1718 switch (sym
->redirect
)
1720 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1721 case SYMBOL_PLAINVAL
: return variable
;
1722 case SYMBOL_FORWARDED
:
1724 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1725 if (BUFFER_OBJFWDP (valcontents
))
1727 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1728 int idx
= PER_BUFFER_IDX (offset
);
1732 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1733 PER_BUFFER_VALUE (current_buffer
, offset
)
1734 = PER_BUFFER_DEFAULT (offset
);
1739 case SYMBOL_LOCALIZED
:
1740 blv
= SYMBOL_BLV (sym
);
1741 if (blv
->frame_local
)
1747 /* Get rid of this buffer's alist element, if any. */
1748 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1749 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1751 current_buffer
->local_var_alist
1752 = Fdelq (tem
, current_buffer
->local_var_alist
);
1754 /* If the symbol is set up with the current buffer's binding
1755 loaded, recompute its value. We have to do it now, or else
1756 forwarded objects won't work right. */
1758 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1759 if (EQ (buf
, blv
->where
))
1762 /* blv->valcell = blv->defcell;
1763 * SET_BLV_FOUND (blv, 0); */
1765 find_symbol_value (variable
);
1772 /* Lisp functions for creating and removing buffer-local variables. */
1774 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1775 when/if this is removed. */
1777 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1778 1, 1, "vMake Variable Frame Local: ",
1779 doc
: /* Enable VARIABLE to have frame-local bindings.
1780 This does not create any frame-local bindings for VARIABLE,
1781 it just makes them possible.
1783 A frame-local binding is actually a frame parameter value.
1784 If a frame F has a value for the frame parameter named VARIABLE,
1785 that also acts as a frame-local binding for VARIABLE in F--
1786 provided this function has been called to enable VARIABLE
1787 to have frame-local bindings at all.
1789 The only way to create a frame-local binding for VARIABLE in a frame
1790 is to set the VARIABLE frame parameter of that frame. See
1791 `modify-frame-parameters' for how to set frame parameters.
1793 Note that since Emacs 23.1, variables cannot be both buffer-local and
1794 frame-local any more (buffer-local bindings used to take precedence over
1795 frame-local bindings). */)
1796 (register Lisp_Object variable
)
1799 union Lisp_Val_Fwd valcontents
;
1800 struct Lisp_Symbol
*sym
;
1801 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1803 CHECK_SYMBOL (variable
);
1804 sym
= XSYMBOL (variable
);
1807 switch (sym
->redirect
)
1809 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1810 case SYMBOL_PLAINVAL
:
1811 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1812 if (EQ (valcontents
.value
, Qunbound
))
1813 valcontents
.value
= Qnil
;
1815 case SYMBOL_LOCALIZED
:
1816 if (SYMBOL_BLV (sym
)->frame_local
)
1819 error ("Symbol %s may not be frame-local",
1820 SDATA (SYMBOL_NAME (variable
)));
1821 case SYMBOL_FORWARDED
:
1822 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1823 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1824 error ("Symbol %s may not be frame-local",
1825 SDATA (SYMBOL_NAME (variable
)));
1831 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1833 blv
= make_blv (sym
, forwarded
, valcontents
);
1834 blv
->frame_local
= 1;
1835 sym
->redirect
= SYMBOL_LOCALIZED
;
1836 SET_SYMBOL_BLV (sym
, blv
);
1839 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1840 if (let_shadows_global_binding_p (symbol
))
1841 message ("Making %s frame-local while let-bound!",
1842 SDATA (SYMBOL_NAME (variable
)));
1847 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1849 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1850 BUFFER defaults to the current buffer. */)
1851 (register Lisp_Object variable
, Lisp_Object buffer
)
1853 register struct buffer
*buf
;
1854 struct Lisp_Symbol
*sym
;
1857 buf
= current_buffer
;
1860 CHECK_BUFFER (buffer
);
1861 buf
= XBUFFER (buffer
);
1864 CHECK_SYMBOL (variable
);
1865 sym
= XSYMBOL (variable
);
1868 switch (sym
->redirect
)
1870 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1871 case SYMBOL_PLAINVAL
: return Qnil
;
1872 case SYMBOL_LOCALIZED
:
1874 Lisp_Object tail
, elt
, tmp
;
1875 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1876 XSETBUFFER (tmp
, buf
);
1877 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1879 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1882 if (EQ (variable
, XCAR (elt
)))
1884 eassert (!blv
->frame_local
);
1885 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1889 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1892 case SYMBOL_FORWARDED
:
1894 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1895 if (BUFFER_OBJFWDP (valcontents
))
1897 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1898 int idx
= PER_BUFFER_IDX (offset
);
1899 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1908 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1910 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1911 More precisely, this means that setting the variable \(with `set' or`setq'),
1912 while it does not have a `let'-style binding that was made in BUFFER,
1913 will produce a buffer local binding. See Info node
1914 `(elisp)Creating Buffer-Local'.
1915 BUFFER defaults to the current buffer. */)
1916 (register Lisp_Object variable
, Lisp_Object buffer
)
1918 struct Lisp_Symbol
*sym
;
1920 CHECK_SYMBOL (variable
);
1921 sym
= XSYMBOL (variable
);
1924 switch (sym
->redirect
)
1926 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1927 case SYMBOL_PLAINVAL
: return Qnil
;
1928 case SYMBOL_LOCALIZED
:
1930 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1931 if (blv
->local_if_set
)
1933 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1934 return Flocal_variable_p (variable
, buffer
);
1936 case SYMBOL_FORWARDED
:
1937 /* All BUFFER_OBJFWD slots become local if they are set. */
1938 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1943 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1945 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1946 If the current binding is buffer-local, the value is the current buffer.
1947 If the current binding is frame-local, the value is the selected frame.
1948 If the current binding is global (the default), the value is nil. */)
1949 (register Lisp_Object variable
)
1951 struct Lisp_Symbol
*sym
;
1953 CHECK_SYMBOL (variable
);
1954 sym
= XSYMBOL (variable
);
1956 /* Make sure the current binding is actually swapped in. */
1957 find_symbol_value (variable
);
1960 switch (sym
->redirect
)
1962 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1963 case SYMBOL_PLAINVAL
: return Qnil
;
1964 case SYMBOL_FORWARDED
:
1966 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1967 if (KBOARD_OBJFWDP (valcontents
))
1968 return Fframe_terminal (Fselected_frame ());
1969 else if (!BUFFER_OBJFWDP (valcontents
))
1973 case SYMBOL_LOCALIZED
:
1974 /* For a local variable, record both the symbol and which
1975 buffer's or frame's value we are saving. */
1976 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1977 return Fcurrent_buffer ();
1978 else if (sym
->redirect
== SYMBOL_LOCALIZED
1979 && BLV_FOUND (SYMBOL_BLV (sym
)))
1980 return SYMBOL_BLV (sym
)->where
;
1987 /* This code is disabled now that we use the selected frame to return
1988 keyboard-local-values. */
1990 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1992 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1993 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1994 If SYMBOL is not a terminal-local variable, then return its normal
1995 value, like `symbol-value'.
1997 TERMINAL may be a terminal object, a frame, or nil (meaning the
1998 selected frame's terminal device). */)
1999 (Lisp_Object symbol
, Lisp_Object terminal
)
2002 struct terminal
*t
= get_terminal (terminal
, 1);
2003 push_kboard (t
->kboard
);
2004 result
= Fsymbol_value (symbol
);
2009 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2010 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2011 If VARIABLE is not a terminal-local variable, then set its normal
2012 binding, like `set'.
2014 TERMINAL may be a terminal object, a frame, or nil (meaning the
2015 selected frame's terminal device). */)
2016 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2019 struct terminal
*t
= get_terminal (terminal
, 1);
2020 push_kboard (d
->kboard
);
2021 result
= Fset (symbol
, value
);
2027 /* Find the function at the end of a chain of symbol function indirections. */
2029 /* If OBJECT is a symbol, find the end of its function chain and
2030 return the value found there. If OBJECT is not a symbol, just
2031 return it. If there is a cycle in the function chain, signal a
2032 cyclic-function-indirection error.
2034 This is like Findirect_function, except that it doesn't signal an
2035 error if the chain ends up unbound. */
2037 indirect_function (register Lisp_Object object
)
2039 Lisp_Object tortoise
, hare
;
2041 hare
= tortoise
= object
;
2045 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2047 hare
= XSYMBOL (hare
)->function
;
2048 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2050 hare
= XSYMBOL (hare
)->function
;
2052 tortoise
= XSYMBOL (tortoise
)->function
;
2054 if (EQ (hare
, tortoise
))
2055 xsignal1 (Qcyclic_function_indirection
, object
);
2061 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2062 doc
: /* Return the function at the end of OBJECT's function chain.
2063 If OBJECT is not a symbol, just return it. Otherwise, follow all
2064 function indirections to find the final function binding and return it.
2065 If the final symbol in the chain is unbound, signal a void-function error.
2066 Optional arg NOERROR non-nil means to return nil instead of signalling.
2067 Signal a cyclic-function-indirection error if there is a loop in the
2068 function chain of symbols. */)
2069 (register Lisp_Object object
, Lisp_Object noerror
)
2073 /* Optimize for no indirection. */
2075 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2076 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2077 result
= indirect_function (result
);
2078 if (!EQ (result
, Qunbound
))
2082 xsignal1 (Qvoid_function
, object
);
2087 /* Extract and set vector and string elements */
2089 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2090 doc
: /* Return the element of ARRAY at index IDX.
2091 ARRAY may be a vector, a string, a char-table, a bool-vector,
2092 or a byte-code object. IDX starts at 0. */)
2093 (register Lisp_Object array
, Lisp_Object idx
)
2095 register EMACS_INT idxval
;
2098 idxval
= XINT (idx
);
2099 if (STRINGP (array
))
2102 EMACS_INT idxval_byte
;
2104 if (idxval
< 0 || idxval
>= SCHARS (array
))
2105 args_out_of_range (array
, idx
);
2106 if (! STRING_MULTIBYTE (array
))
2107 return make_number ((unsigned char) SREF (array
, idxval
));
2108 idxval_byte
= string_char_to_byte (array
, idxval
);
2110 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2111 return make_number (c
);
2113 else if (BOOL_VECTOR_P (array
))
2117 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2118 args_out_of_range (array
, idx
);
2120 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2121 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2123 else if (CHAR_TABLE_P (array
))
2125 CHECK_CHARACTER (idx
);
2126 return CHAR_TABLE_REF (array
, idxval
);
2131 if (VECTORP (array
))
2132 size
= ASIZE (array
);
2133 else if (FUNVECP (array
))
2134 size
= FUNVEC_SIZE (array
);
2136 wrong_type_argument (Qarrayp
, array
);
2138 if (idxval
< 0 || idxval
>= size
)
2139 args_out_of_range (array
, idx
);
2140 return AREF (array
, idxval
);
2144 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2145 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2146 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2147 bool-vector. IDX starts at 0. */)
2148 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2150 register EMACS_INT idxval
;
2153 idxval
= XINT (idx
);
2154 CHECK_ARRAY (array
, Qarrayp
);
2155 CHECK_IMPURE (array
);
2157 if (VECTORP (array
))
2159 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2160 args_out_of_range (array
, idx
);
2161 XVECTOR (array
)->contents
[idxval
] = newelt
;
2163 else if (BOOL_VECTOR_P (array
))
2167 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2168 args_out_of_range (array
, idx
);
2170 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2172 if (! NILP (newelt
))
2173 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2175 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2176 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2178 else if (CHAR_TABLE_P (array
))
2180 CHECK_CHARACTER (idx
);
2181 CHAR_TABLE_SET (array
, idxval
, newelt
);
2183 else if (STRING_MULTIBYTE (array
))
2185 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2186 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2188 if (idxval
< 0 || idxval
>= SCHARS (array
))
2189 args_out_of_range (array
, idx
);
2190 CHECK_CHARACTER (newelt
);
2192 nbytes
= SBYTES (array
);
2194 idxval_byte
= string_char_to_byte (array
, idxval
);
2195 p1
= SDATA (array
) + idxval_byte
;
2196 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2197 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2198 if (prev_bytes
!= new_bytes
)
2200 /* We must relocate the string data. */
2201 EMACS_INT nchars
= SCHARS (array
);
2205 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2206 memcpy (str
, SDATA (array
), nbytes
);
2207 allocate_string_data (XSTRING (array
), nchars
,
2208 nbytes
+ new_bytes
- prev_bytes
);
2209 memcpy (SDATA (array
), str
, idxval_byte
);
2210 p1
= SDATA (array
) + idxval_byte
;
2211 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2212 nbytes
- (idxval_byte
+ prev_bytes
));
2214 clear_string_char_byte_cache ();
2221 if (idxval
< 0 || idxval
>= SCHARS (array
))
2222 args_out_of_range (array
, idx
);
2223 CHECK_NUMBER (newelt
);
2225 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2229 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2230 if (SREF (array
, i
) >= 0x80)
2231 args_out_of_range (array
, newelt
);
2232 /* ARRAY is an ASCII string. Convert it to a multibyte
2233 string, and try `aset' again. */
2234 STRING_SET_MULTIBYTE (array
);
2235 return Faset (array
, idx
, newelt
);
2237 SSET (array
, idxval
, XINT (newelt
));
2243 /* Arithmetic functions */
2245 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2248 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2250 double f1
= 0, f2
= 0;
2253 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2254 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2256 if (FLOATP (num1
) || FLOATP (num2
))
2259 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2260 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2266 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2271 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2276 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2281 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2286 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2291 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2300 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2301 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2302 (register Lisp_Object num1
, Lisp_Object num2
)
2304 return arithcompare (num1
, num2
, equal
);
2307 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2308 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2309 (register Lisp_Object num1
, Lisp_Object num2
)
2311 return arithcompare (num1
, num2
, less
);
2314 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2315 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2316 (register Lisp_Object num1
, Lisp_Object num2
)
2318 return arithcompare (num1
, num2
, grtr
);
2321 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2322 doc
: /* Return t if first arg is less than or equal to second arg.
2323 Both must be numbers or markers. */)
2324 (register Lisp_Object num1
, Lisp_Object num2
)
2326 return arithcompare (num1
, num2
, less_or_equal
);
2329 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2330 doc
: /* Return t if first arg is greater than or equal to second arg.
2331 Both must be numbers or markers. */)
2332 (register Lisp_Object num1
, Lisp_Object num2
)
2334 return arithcompare (num1
, num2
, grtr_or_equal
);
2337 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2338 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2339 (register Lisp_Object num1
, Lisp_Object num2
)
2341 return arithcompare (num1
, num2
, notequal
);
2344 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2345 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.
2363 Note that long_to_cons returns a single Lisp integer
2364 when the value fits in one. */
2367 long_to_cons (long unsigned int i
)
2369 unsigned long top
= i
>> 16;
2370 unsigned int bot
= i
& 0xFFFF;
2372 return make_number (bot
);
2373 if (top
== (unsigned long)-1 >> 16)
2374 return Fcons (make_number (-1), make_number (bot
));
2375 return Fcons (make_number (top
), make_number (bot
));
2379 cons_to_long (Lisp_Object c
)
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. */)
2395 (Lisp_Object number
)
2397 char buffer
[VALBITS
];
2399 CHECK_NUMBER_OR_FLOAT (number
);
2401 if (FLOATP (number
))
2403 char pigbuf
[350]; /* see comments in float_to_string */
2405 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2406 return build_string (pigbuf
);
2409 if (sizeof (int) == sizeof (EMACS_INT
))
2410 sprintf (buffer
, "%d", (int) XINT (number
));
2411 else if (sizeof (long) == sizeof (EMACS_INT
))
2412 sprintf (buffer
, "%ld", (long) XINT (number
));
2415 return build_string (buffer
);
2419 digit_to_number (int character
, int base
)
2423 if (character
>= '0' && character
<= '9')
2424 digit
= character
- '0';
2425 else if (character
>= 'a' && character
<= 'z')
2426 digit
= character
- 'a' + 10;
2427 else if (character
>= 'A' && character
<= 'Z')
2428 digit
= character
- 'A' + 10;
2438 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2439 doc
: /* Parse STRING as a decimal number and return the number.
2440 This parses both integers and floating point numbers.
2441 It ignores leading spaces and tabs, and all trailing chars.
2443 If BASE, interpret STRING as a number in that base. If BASE isn't
2444 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2445 If the base used is not 10, STRING is always parsed as integer. */)
2446 (register Lisp_Object string
, Lisp_Object base
)
2448 register unsigned char *p
;
2453 CHECK_STRING (string
);
2459 CHECK_NUMBER (base
);
2461 if (b
< 2 || b
> 16)
2462 xsignal1 (Qargs_out_of_range
, base
);
2465 /* Skip any whitespace at the front of the number. Some versions of
2466 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2468 while (*p
== ' ' || *p
== '\t')
2479 if (isfloat_string (p
, 1) && b
== 10)
2480 val
= make_float (sign
* atof (p
));
2487 int digit
= digit_to_number (*p
++, b
);
2493 val
= make_fixnum_or_float (sign
* v
);
2513 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2514 int, Lisp_Object
*);
2516 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2518 register Lisp_Object val
;
2519 register int argnum
;
2520 register EMACS_INT accum
= 0;
2521 register EMACS_INT next
;
2523 switch (SWITCH_ENUM_CAST (code
))
2541 for (argnum
= 0; argnum
< nargs
; argnum
++)
2543 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2545 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2548 return float_arith_driver ((double) accum
, argnum
, code
,
2551 next
= XINT (args
[argnum
]);
2552 switch (SWITCH_ENUM_CAST (code
))
2558 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2569 xsignal0 (Qarith_error
);
2583 if (!argnum
|| next
> accum
)
2587 if (!argnum
|| next
< accum
)
2593 XSETINT (val
, accum
);
2598 #define isnan(x) ((x) != (x))
2601 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2603 register Lisp_Object val
;
2606 for (; argnum
< nargs
; argnum
++)
2608 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2609 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2613 next
= XFLOAT_DATA (val
);
2617 args
[argnum
] = val
; /* runs into a compiler bug. */
2618 next
= XINT (args
[argnum
]);
2620 switch (SWITCH_ENUM_CAST (code
))
2626 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2636 if (! IEEE_FLOATING_POINT
&& next
== 0)
2637 xsignal0 (Qarith_error
);
2644 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2646 if (!argnum
|| isnan (next
) || next
> accum
)
2650 if (!argnum
|| isnan (next
) || next
< accum
)
2656 return make_float (accum
);
2660 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2661 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2662 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2663 (int nargs
, Lisp_Object
*args
)
2665 return arith_driver (Aadd
, nargs
, args
);
2668 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2669 doc
: /* Negate number or subtract numbers or markers and return the result.
2670 With one arg, negates it. With more than one arg,
2671 subtracts all but the first from the first.
2672 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2673 (int nargs
, Lisp_Object
*args
)
2675 return arith_driver (Asub
, nargs
, args
);
2678 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2679 doc
: /* Return product of any number of arguments, which are numbers or markers.
2680 usage: (* &rest NUMBERS-OR-MARKERS) */)
2681 (int nargs
, Lisp_Object
*args
)
2683 return arith_driver (Amult
, nargs
, args
);
2686 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2687 doc
: /* Return first argument divided by all the remaining arguments.
2688 The arguments must be numbers or markers.
2689 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2690 (int nargs
, Lisp_Object
*args
)
2693 for (argnum
= 2; argnum
< nargs
; argnum
++)
2694 if (FLOATP (args
[argnum
]))
2695 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2696 return arith_driver (Adiv
, nargs
, args
);
2699 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2700 doc
: /* Return remainder of X divided by Y.
2701 Both must be integers or markers. */)
2702 (register Lisp_Object x
, Lisp_Object y
)
2706 CHECK_NUMBER_COERCE_MARKER (x
);
2707 CHECK_NUMBER_COERCE_MARKER (y
);
2709 if (XFASTINT (y
) == 0)
2710 xsignal0 (Qarith_error
);
2712 XSETINT (val
, XINT (x
) % XINT (y
));
2726 /* If the magnitude of the result exceeds that of the divisor, or
2727 the sign of the result does not agree with that of the dividend,
2728 iterate with the reduced value. This does not yield a
2729 particularly accurate result, but at least it will be in the
2730 range promised by fmod. */
2732 r
-= f2
* floor (r
/ f2
);
2733 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2737 #endif /* ! HAVE_FMOD */
2739 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2740 doc
: /* Return X modulo Y.
2741 The result falls between zero (inclusive) and Y (exclusive).
2742 Both X and Y must be numbers or markers. */)
2743 (register Lisp_Object x
, Lisp_Object y
)
2748 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2749 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2751 if (FLOATP (x
) || FLOATP (y
))
2752 return fmod_float (x
, y
);
2758 xsignal0 (Qarith_error
);
2762 /* If the "remainder" comes out with the wrong sign, fix it. */
2763 if (i2
< 0 ? i1
> 0 : i1
< 0)
2770 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2771 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2772 The value is always a number; markers are converted to numbers.
2773 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2774 (int nargs
, Lisp_Object
*args
)
2776 return arith_driver (Amax
, nargs
, args
);
2779 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2780 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2781 The value is always a number; markers are converted to numbers.
2782 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2783 (int nargs
, Lisp_Object
*args
)
2785 return arith_driver (Amin
, nargs
, args
);
2788 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2789 doc
: /* Return bitwise-and of all the arguments.
2790 Arguments may be integers, or markers converted to integers.
2791 usage: (logand &rest INTS-OR-MARKERS) */)
2792 (int nargs
, Lisp_Object
*args
)
2794 return arith_driver (Alogand
, nargs
, args
);
2797 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2798 doc
: /* Return bitwise-or of all the arguments.
2799 Arguments may be integers, or markers converted to integers.
2800 usage: (logior &rest INTS-OR-MARKERS) */)
2801 (int nargs
, Lisp_Object
*args
)
2803 return arith_driver (Alogior
, nargs
, args
);
2806 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2807 doc
: /* Return bitwise-exclusive-or of all the arguments.
2808 Arguments may be integers, or markers converted to integers.
2809 usage: (logxor &rest INTS-OR-MARKERS) */)
2810 (int nargs
, Lisp_Object
*args
)
2812 return arith_driver (Alogxor
, nargs
, args
);
2815 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2816 doc
: /* Return VALUE with its bits shifted left by COUNT.
2817 If COUNT is negative, shifting is actually to the right.
2818 In this case, the sign bit is duplicated. */)
2819 (register Lisp_Object value
, Lisp_Object count
)
2821 register Lisp_Object val
;
2823 CHECK_NUMBER (value
);
2824 CHECK_NUMBER (count
);
2826 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2828 else if (XINT (count
) > 0)
2829 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2830 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2831 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2833 XSETINT (val
, XINT (value
) >> -XINT (count
));
2837 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2838 doc
: /* Return VALUE with its bits shifted left by COUNT.
2839 If COUNT is negative, shifting is actually to the right.
2840 In this case, zeros are shifted in on the left. */)
2841 (register Lisp_Object value
, Lisp_Object count
)
2843 register Lisp_Object val
;
2845 CHECK_NUMBER (value
);
2846 CHECK_NUMBER (count
);
2848 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2850 else if (XINT (count
) > 0)
2851 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2852 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2855 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2859 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2860 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2861 Markers are converted to integers. */)
2862 (register Lisp_Object number
)
2864 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2866 if (FLOATP (number
))
2867 return (make_float (1.0 + XFLOAT_DATA (number
)));
2869 XSETINT (number
, XINT (number
) + 1);
2873 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2874 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2875 Markers are converted to integers. */)
2876 (register Lisp_Object number
)
2878 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2880 if (FLOATP (number
))
2881 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2883 XSETINT (number
, XINT (number
) - 1);
2887 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2888 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2889 (register Lisp_Object number
)
2891 CHECK_NUMBER (number
);
2892 XSETINT (number
, ~XINT (number
));
2896 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2897 doc
: /* Return the byteorder for the machine.
2898 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2899 lowercase l) for small endian machines. */)
2902 unsigned i
= 0x04030201;
2903 int order
= *(char *)&i
== 1 ? 108 : 66;
2905 return make_number (order
);
2913 Lisp_Object error_tail
, arith_tail
;
2915 Qquote
= intern_c_string ("quote");
2916 Qlambda
= intern_c_string ("lambda");
2917 Qsubr
= intern_c_string ("subr");
2918 Qerror_conditions
= intern_c_string ("error-conditions");
2919 Qerror_message
= intern_c_string ("error-message");
2920 Qtop_level
= intern_c_string ("top-level");
2922 Qerror
= intern_c_string ("error");
2923 Qquit
= intern_c_string ("quit");
2924 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2925 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2926 Qvoid_function
= intern_c_string ("void-function");
2927 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2928 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2929 Qvoid_variable
= intern_c_string ("void-variable");
2930 Qsetting_constant
= intern_c_string ("setting-constant");
2931 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2933 Qinvalid_function
= intern_c_string ("invalid-function");
2934 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2935 Qno_catch
= intern_c_string ("no-catch");
2936 Qend_of_file
= intern_c_string ("end-of-file");
2937 Qarith_error
= intern_c_string ("arith-error");
2938 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2939 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2940 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2941 Qtext_read_only
= intern_c_string ("text-read-only");
2942 Qmark_inactive
= intern_c_string ("mark-inactive");
2944 Qlistp
= intern_c_string ("listp");
2945 Qconsp
= intern_c_string ("consp");
2946 Qsymbolp
= intern_c_string ("symbolp");
2947 Qkeywordp
= intern_c_string ("keywordp");
2948 Qintegerp
= intern_c_string ("integerp");
2949 Qnatnump
= intern_c_string ("natnump");
2950 Qwholenump
= intern_c_string ("wholenump");
2951 Qstringp
= intern_c_string ("stringp");
2952 Qarrayp
= intern_c_string ("arrayp");
2953 Qsequencep
= intern_c_string ("sequencep");
2954 Qbufferp
= intern_c_string ("bufferp");
2955 Qvectorp
= intern_c_string ("vectorp");
2956 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2957 Qmarkerp
= intern_c_string ("markerp");
2958 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2959 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2960 Qboundp
= intern_c_string ("boundp");
2961 Qfboundp
= intern_c_string ("fboundp");
2963 Qfloatp
= intern_c_string ("floatp");
2964 Qnumberp
= intern_c_string ("numberp");
2965 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2967 Qchar_table_p
= intern_c_string ("char-table-p");
2968 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2970 Qsubrp
= intern_c_string ("subrp");
2971 Qunevalled
= intern_c_string ("unevalled");
2972 Qmany
= intern_c_string ("many");
2974 Qcdr
= intern_c_string ("cdr");
2976 /* Handle automatic advice activation */
2977 Qad_advice_info
= intern_c_string ("ad-advice-info");
2978 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2980 error_tail
= pure_cons (Qerror
, Qnil
);
2982 /* ERROR is used as a signaler for random errors for which nothing else is right */
2984 Fput (Qerror
, Qerror_conditions
,
2986 Fput (Qerror
, Qerror_message
,
2987 make_pure_c_string ("error"));
2989 Fput (Qquit
, Qerror_conditions
,
2990 pure_cons (Qquit
, Qnil
));
2991 Fput (Qquit
, Qerror_message
,
2992 make_pure_c_string ("Quit"));
2994 Fput (Qwrong_type_argument
, Qerror_conditions
,
2995 pure_cons (Qwrong_type_argument
, error_tail
));
2996 Fput (Qwrong_type_argument
, Qerror_message
,
2997 make_pure_c_string ("Wrong type argument"));
2999 Fput (Qargs_out_of_range
, Qerror_conditions
,
3000 pure_cons (Qargs_out_of_range
, error_tail
));
3001 Fput (Qargs_out_of_range
, Qerror_message
,
3002 make_pure_c_string ("Args out of range"));
3004 Fput (Qvoid_function
, Qerror_conditions
,
3005 pure_cons (Qvoid_function
, error_tail
));
3006 Fput (Qvoid_function
, Qerror_message
,
3007 make_pure_c_string ("Symbol's function definition is void"));
3009 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3010 pure_cons (Qcyclic_function_indirection
, error_tail
));
3011 Fput (Qcyclic_function_indirection
, Qerror_message
,
3012 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3014 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3015 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3016 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3017 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3019 Qcircular_list
= intern_c_string ("circular-list");
3020 staticpro (&Qcircular_list
);
3021 Fput (Qcircular_list
, Qerror_conditions
,
3022 pure_cons (Qcircular_list
, error_tail
));
3023 Fput (Qcircular_list
, Qerror_message
,
3024 make_pure_c_string ("List contains a loop"));
3026 Fput (Qvoid_variable
, Qerror_conditions
,
3027 pure_cons (Qvoid_variable
, error_tail
));
3028 Fput (Qvoid_variable
, Qerror_message
,
3029 make_pure_c_string ("Symbol's value as variable is void"));
3031 Fput (Qsetting_constant
, Qerror_conditions
,
3032 pure_cons (Qsetting_constant
, error_tail
));
3033 Fput (Qsetting_constant
, Qerror_message
,
3034 make_pure_c_string ("Attempt to set a constant symbol"));
3036 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3037 pure_cons (Qinvalid_read_syntax
, error_tail
));
3038 Fput (Qinvalid_read_syntax
, Qerror_message
,
3039 make_pure_c_string ("Invalid read syntax"));
3041 Fput (Qinvalid_function
, Qerror_conditions
,
3042 pure_cons (Qinvalid_function
, error_tail
));
3043 Fput (Qinvalid_function
, Qerror_message
,
3044 make_pure_c_string ("Invalid function"));
3046 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3047 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3048 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3049 make_pure_c_string ("Wrong number of arguments"));
3051 Fput (Qno_catch
, Qerror_conditions
,
3052 pure_cons (Qno_catch
, error_tail
));
3053 Fput (Qno_catch
, Qerror_message
,
3054 make_pure_c_string ("No catch for tag"));
3056 Fput (Qend_of_file
, Qerror_conditions
,
3057 pure_cons (Qend_of_file
, error_tail
));
3058 Fput (Qend_of_file
, Qerror_message
,
3059 make_pure_c_string ("End of file during parsing"));
3061 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3062 Fput (Qarith_error
, Qerror_conditions
,
3064 Fput (Qarith_error
, Qerror_message
,
3065 make_pure_c_string ("Arithmetic error"));
3067 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3068 pure_cons (Qbeginning_of_buffer
, error_tail
));
3069 Fput (Qbeginning_of_buffer
, Qerror_message
,
3070 make_pure_c_string ("Beginning of buffer"));
3072 Fput (Qend_of_buffer
, Qerror_conditions
,
3073 pure_cons (Qend_of_buffer
, error_tail
));
3074 Fput (Qend_of_buffer
, Qerror_message
,
3075 make_pure_c_string ("End of buffer"));
3077 Fput (Qbuffer_read_only
, Qerror_conditions
,
3078 pure_cons (Qbuffer_read_only
, error_tail
));
3079 Fput (Qbuffer_read_only
, Qerror_message
,
3080 make_pure_c_string ("Buffer is read-only"));
3082 Fput (Qtext_read_only
, Qerror_conditions
,
3083 pure_cons (Qtext_read_only
, error_tail
));
3084 Fput (Qtext_read_only
, Qerror_message
,
3085 make_pure_c_string ("Text is read-only"));
3087 Qrange_error
= intern_c_string ("range-error");
3088 Qdomain_error
= intern_c_string ("domain-error");
3089 Qsingularity_error
= intern_c_string ("singularity-error");
3090 Qoverflow_error
= intern_c_string ("overflow-error");
3091 Qunderflow_error
= intern_c_string ("underflow-error");
3093 Fput (Qdomain_error
, Qerror_conditions
,
3094 pure_cons (Qdomain_error
, arith_tail
));
3095 Fput (Qdomain_error
, Qerror_message
,
3096 make_pure_c_string ("Arithmetic domain error"));
3098 Fput (Qrange_error
, Qerror_conditions
,
3099 pure_cons (Qrange_error
, arith_tail
));
3100 Fput (Qrange_error
, Qerror_message
,
3101 make_pure_c_string ("Arithmetic range error"));
3103 Fput (Qsingularity_error
, Qerror_conditions
,
3104 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3105 Fput (Qsingularity_error
, Qerror_message
,
3106 make_pure_c_string ("Arithmetic singularity error"));
3108 Fput (Qoverflow_error
, Qerror_conditions
,
3109 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3110 Fput (Qoverflow_error
, Qerror_message
,
3111 make_pure_c_string ("Arithmetic overflow error"));
3113 Fput (Qunderflow_error
, Qerror_conditions
,
3114 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3115 Fput (Qunderflow_error
, Qerror_message
,
3116 make_pure_c_string ("Arithmetic underflow error"));
3118 staticpro (&Qrange_error
);
3119 staticpro (&Qdomain_error
);
3120 staticpro (&Qsingularity_error
);
3121 staticpro (&Qoverflow_error
);
3122 staticpro (&Qunderflow_error
);
3126 staticpro (&Qquote
);
3127 staticpro (&Qlambda
);
3129 staticpro (&Qunbound
);
3130 staticpro (&Qerror_conditions
);
3131 staticpro (&Qerror_message
);
3132 staticpro (&Qtop_level
);
3134 staticpro (&Qerror
);
3136 staticpro (&Qwrong_type_argument
);
3137 staticpro (&Qargs_out_of_range
);
3138 staticpro (&Qvoid_function
);
3139 staticpro (&Qcyclic_function_indirection
);
3140 staticpro (&Qcyclic_variable_indirection
);
3141 staticpro (&Qvoid_variable
);
3142 staticpro (&Qsetting_constant
);
3143 staticpro (&Qinvalid_read_syntax
);
3144 staticpro (&Qwrong_number_of_arguments
);
3145 staticpro (&Qinvalid_function
);
3146 staticpro (&Qno_catch
);
3147 staticpro (&Qend_of_file
);
3148 staticpro (&Qarith_error
);
3149 staticpro (&Qbeginning_of_buffer
);
3150 staticpro (&Qend_of_buffer
);
3151 staticpro (&Qbuffer_read_only
);
3152 staticpro (&Qtext_read_only
);
3153 staticpro (&Qmark_inactive
);
3155 staticpro (&Qlistp
);
3156 staticpro (&Qconsp
);
3157 staticpro (&Qsymbolp
);
3158 staticpro (&Qkeywordp
);
3159 staticpro (&Qintegerp
);
3160 staticpro (&Qnatnump
);
3161 staticpro (&Qwholenump
);
3162 staticpro (&Qstringp
);
3163 staticpro (&Qarrayp
);
3164 staticpro (&Qsequencep
);
3165 staticpro (&Qbufferp
);
3166 staticpro (&Qvectorp
);
3167 staticpro (&Qchar_or_string_p
);
3168 staticpro (&Qmarkerp
);
3169 staticpro (&Qbuffer_or_string_p
);
3170 staticpro (&Qinteger_or_marker_p
);
3171 staticpro (&Qfloatp
);
3172 staticpro (&Qnumberp
);
3173 staticpro (&Qnumber_or_marker_p
);
3174 staticpro (&Qchar_table_p
);
3175 staticpro (&Qvector_or_char_table_p
);
3176 staticpro (&Qsubrp
);
3178 staticpro (&Qunevalled
);
3180 staticpro (&Qboundp
);
3181 staticpro (&Qfboundp
);
3183 staticpro (&Qad_advice_info
);
3184 staticpro (&Qad_activate_internal
);
3186 /* Types that type-of returns. */
3187 Qinteger
= intern_c_string ("integer");
3188 Qsymbol
= intern_c_string ("symbol");
3189 Qstring
= intern_c_string ("string");
3190 Qcons
= intern_c_string ("cons");
3191 Qmarker
= intern_c_string ("marker");
3192 Qoverlay
= intern_c_string ("overlay");
3193 Qfloat
= intern_c_string ("float");
3194 Qwindow_configuration
= intern_c_string ("window-configuration");
3195 Qprocess
= intern_c_string ("process");
3196 Qwindow
= intern_c_string ("window");
3197 /* Qsubr = intern_c_string ("subr"); */
3198 Qcompiled_function
= intern_c_string ("compiled-function");
3199 Qfunction_vector
= intern_c_string ("function-vector");
3200 Qbuffer
= intern_c_string ("buffer");
3201 Qframe
= intern_c_string ("frame");
3202 Qvector
= intern_c_string ("vector");
3203 Qchar_table
= intern_c_string ("char-table");
3204 Qbool_vector
= intern_c_string ("bool-vector");
3205 Qhash_table
= intern_c_string ("hash-table");
3207 DEFSYM (Qfont_spec
, "font-spec");
3208 DEFSYM (Qfont_entity
, "font-entity");
3209 DEFSYM (Qfont_object
, "font-object");
3211 DEFSYM (Qinteractive_form
, "interactive-form");
3213 staticpro (&Qinteger
);
3214 staticpro (&Qsymbol
);
3215 staticpro (&Qstring
);
3217 staticpro (&Qmarker
);
3218 staticpro (&Qoverlay
);
3219 staticpro (&Qfloat
);
3220 staticpro (&Qwindow_configuration
);
3221 staticpro (&Qprocess
);
3222 staticpro (&Qwindow
);
3223 /* staticpro (&Qsubr); */
3224 staticpro (&Qcompiled_function
);
3225 staticpro (&Qfunction_vector
);
3226 staticpro (&Qbuffer
);
3227 staticpro (&Qframe
);
3228 staticpro (&Qvector
);
3229 staticpro (&Qchar_table
);
3230 staticpro (&Qbool_vector
);
3231 staticpro (&Qhash_table
);
3233 defsubr (&Sindirect_variable
);
3234 defsubr (&Sinteractive_form
);
3237 defsubr (&Stype_of
);
3242 defsubr (&Sintegerp
);
3243 defsubr (&Sinteger_or_marker_p
);
3244 defsubr (&Snumberp
);
3245 defsubr (&Snumber_or_marker_p
);
3247 defsubr (&Snatnump
);
3248 defsubr (&Ssymbolp
);
3249 defsubr (&Skeywordp
);
3250 defsubr (&Sstringp
);
3251 defsubr (&Smultibyte_string_p
);
3252 defsubr (&Svectorp
);
3253 defsubr (&Schar_table_p
);
3254 defsubr (&Svector_or_char_table_p
);
3255 defsubr (&Sbool_vector_p
);
3257 defsubr (&Ssequencep
);
3258 defsubr (&Sbufferp
);
3259 defsubr (&Smarkerp
);
3261 defsubr (&Sbyte_code_function_p
);
3262 defsubr (&Sfunvecp
);
3263 defsubr (&Schar_or_string_p
);
3266 defsubr (&Scar_safe
);
3267 defsubr (&Scdr_safe
);
3270 defsubr (&Ssymbol_function
);
3271 defsubr (&Sindirect_function
);
3272 defsubr (&Ssymbol_plist
);
3273 defsubr (&Ssymbol_name
);
3274 defsubr (&Smakunbound
);
3275 defsubr (&Sfmakunbound
);
3277 defsubr (&Sfboundp
);
3279 defsubr (&Sdefalias
);
3280 defsubr (&Ssetplist
);
3281 defsubr (&Ssymbol_value
);
3283 defsubr (&Sdefault_boundp
);
3284 defsubr (&Sdefault_value
);
3285 defsubr (&Sset_default
);
3286 defsubr (&Ssetq_default
);
3287 defsubr (&Smake_variable_buffer_local
);
3288 defsubr (&Smake_local_variable
);
3289 defsubr (&Skill_local_variable
);
3290 defsubr (&Smake_variable_frame_local
);
3291 defsubr (&Slocal_variable_p
);
3292 defsubr (&Slocal_variable_if_set_p
);
3293 defsubr (&Svariable_binding_locus
);
3294 #if 0 /* XXX Remove this. --lorentey */
3295 defsubr (&Sterminal_local_value
);
3296 defsubr (&Sset_terminal_local_value
);
3300 defsubr (&Snumber_to_string
);
3301 defsubr (&Sstring_to_number
);
3302 defsubr (&Seqlsign
);
3325 defsubr (&Sbyteorder
);
3326 defsubr (&Ssubr_arity
);
3327 defsubr (&Ssubr_name
);
3329 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3331 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3332 doc
: /* The largest value that is representable in a Lisp integer. */);
3333 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3334 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3336 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3337 doc
: /* The smallest value that is representable in a Lisp integer. */);
3338 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3339 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3343 arith_error (int signo
)
3345 sigsetmask (SIGEMPTYMASK
);
3347 SIGNAL_THREAD_CHECK (signo
);
3348 xsignal0 (Qarith_error
);
3354 /* Don't do this if just dumping out.
3355 We don't want to call `signal' in this case
3356 so that we don't have trouble with dumping
3357 signal-delivering routines in an inconsistent state. */
3361 #endif /* CANNOT_DUMP */
3362 signal (SIGFPE
, arith_error
);
3365 signal (SIGEMT
, arith_error
);
3369 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3370 (do not change this comment) */