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 int idxval
;
2098 idxval
= XINT (idx
);
2099 if (STRINGP (array
))
2103 if (idxval
< 0 || idxval
>= SCHARS (array
))
2104 args_out_of_range (array
, idx
);
2105 if (! STRING_MULTIBYTE (array
))
2106 return make_number ((unsigned char) SREF (array
, idxval
));
2107 idxval_byte
= string_char_to_byte (array
, idxval
);
2109 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2110 return make_number (c
);
2112 else if (BOOL_VECTOR_P (array
))
2116 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2117 args_out_of_range (array
, idx
);
2119 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2120 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2122 else if (CHAR_TABLE_P (array
))
2124 CHECK_CHARACTER (idx
);
2125 return CHAR_TABLE_REF (array
, idxval
);
2130 if (VECTORP (array
))
2131 size
= ASIZE (array
);
2132 else if (FUNVECP (array
))
2133 size
= FUNVEC_SIZE (array
);
2135 wrong_type_argument (Qarrayp
, array
);
2137 if (idxval
< 0 || idxval
>= size
)
2138 args_out_of_range (array
, idx
);
2139 return AREF (array
, idxval
);
2143 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2144 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2145 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2146 bool-vector. IDX starts at 0. */)
2147 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2149 register int idxval
;
2152 idxval
= XINT (idx
);
2153 CHECK_ARRAY (array
, Qarrayp
);
2154 CHECK_IMPURE (array
);
2156 if (VECTORP (array
))
2158 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2159 args_out_of_range (array
, idx
);
2160 XVECTOR (array
)->contents
[idxval
] = newelt
;
2162 else if (BOOL_VECTOR_P (array
))
2166 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2167 args_out_of_range (array
, idx
);
2169 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2171 if (! NILP (newelt
))
2172 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2174 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2175 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2177 else if (CHAR_TABLE_P (array
))
2179 CHECK_CHARACTER (idx
);
2180 CHAR_TABLE_SET (array
, idxval
, newelt
);
2182 else if (STRING_MULTIBYTE (array
))
2184 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2185 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2187 if (idxval
< 0 || idxval
>= SCHARS (array
))
2188 args_out_of_range (array
, idx
);
2189 CHECK_CHARACTER (newelt
);
2191 nbytes
= SBYTES (array
);
2193 idxval_byte
= string_char_to_byte (array
, idxval
);
2194 p1
= SDATA (array
) + idxval_byte
;
2195 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2196 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2197 if (prev_bytes
!= new_bytes
)
2199 /* We must relocate the string data. */
2200 int nchars
= SCHARS (array
);
2204 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2205 memcpy (str
, SDATA (array
), nbytes
);
2206 allocate_string_data (XSTRING (array
), nchars
,
2207 nbytes
+ new_bytes
- prev_bytes
);
2208 memcpy (SDATA (array
), str
, idxval_byte
);
2209 p1
= SDATA (array
) + idxval_byte
;
2210 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2211 nbytes
- (idxval_byte
+ prev_bytes
));
2213 clear_string_char_byte_cache ();
2220 if (idxval
< 0 || idxval
>= SCHARS (array
))
2221 args_out_of_range (array
, idx
);
2222 CHECK_NUMBER (newelt
);
2224 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2228 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2229 if (SREF (array
, i
) >= 0x80)
2230 args_out_of_range (array
, newelt
);
2231 /* ARRAY is an ASCII string. Convert it to a multibyte
2232 string, and try `aset' again. */
2233 STRING_SET_MULTIBYTE (array
);
2234 return Faset (array
, idx
, newelt
);
2236 SSET (array
, idxval
, XINT (newelt
));
2242 /* Arithmetic functions */
2244 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2247 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2249 double f1
= 0, f2
= 0;
2252 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2253 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2255 if (FLOATP (num1
) || FLOATP (num2
))
2258 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2259 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2265 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2270 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2275 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2280 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2285 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2290 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2299 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2300 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2301 (register Lisp_Object num1
, Lisp_Object num2
)
2303 return arithcompare (num1
, num2
, equal
);
2306 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2307 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2308 (register Lisp_Object num1
, Lisp_Object num2
)
2310 return arithcompare (num1
, num2
, less
);
2313 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2314 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2315 (register Lisp_Object num1
, Lisp_Object num2
)
2317 return arithcompare (num1
, num2
, grtr
);
2320 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2321 doc
: /* Return t if first arg is less than or equal to second arg.
2322 Both must be numbers or markers. */)
2323 (register Lisp_Object num1
, Lisp_Object num2
)
2325 return arithcompare (num1
, num2
, less_or_equal
);
2328 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2329 doc
: /* Return t if first arg is greater than or equal to second arg.
2330 Both must be numbers or markers. */)
2331 (register Lisp_Object num1
, Lisp_Object num2
)
2333 return arithcompare (num1
, num2
, grtr_or_equal
);
2336 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2337 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2338 (register Lisp_Object num1
, Lisp_Object num2
)
2340 return arithcompare (num1
, num2
, notequal
);
2343 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2344 doc
: /* Return t if NUMBER is zero. */)
2345 (register Lisp_Object number
)
2347 CHECK_NUMBER_OR_FLOAT (number
);
2349 if (FLOATP (number
))
2351 if (XFLOAT_DATA (number
) == 0.0)
2361 /* Convert between long values and pairs of Lisp integers.
2362 Note that long_to_cons returns a single Lisp integer
2363 when the value fits in one. */
2366 long_to_cons (long unsigned int i
)
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
));
2378 cons_to_long (Lisp_Object c
)
2380 Lisp_Object top
, bot
;
2387 return ((XINT (top
) << 16) | XINT (bot
));
2390 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2391 doc
: /* Return the decimal representation of NUMBER as a string.
2392 Uses a minus sign if negative.
2393 NUMBER may be an integer or a floating point number. */)
2394 (Lisp_Object number
)
2396 char buffer
[VALBITS
];
2398 CHECK_NUMBER_OR_FLOAT (number
);
2400 if (FLOATP (number
))
2402 char pigbuf
[350]; /* see comments in float_to_string */
2404 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2405 return build_string (pigbuf
);
2408 if (sizeof (int) == sizeof (EMACS_INT
))
2409 sprintf (buffer
, "%d", (int) XINT (number
));
2410 else if (sizeof (long) == sizeof (EMACS_INT
))
2411 sprintf (buffer
, "%ld", (long) XINT (number
));
2414 return build_string (buffer
);
2418 digit_to_number (int character
, int base
)
2422 if (character
>= '0' && character
<= '9')
2423 digit
= character
- '0';
2424 else if (character
>= 'a' && character
<= 'z')
2425 digit
= character
- 'a' + 10;
2426 else if (character
>= 'A' && character
<= 'Z')
2427 digit
= character
- 'A' + 10;
2437 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2438 doc
: /* Parse STRING as a decimal number and return the number.
2439 This parses both integers and floating point numbers.
2440 It ignores leading spaces and tabs, and all trailing chars.
2442 If BASE, interpret STRING as a number in that base. If BASE isn't
2443 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2444 If the base used is not 10, STRING is always parsed as integer. */)
2445 (register Lisp_Object string
, Lisp_Object base
)
2447 register unsigned char *p
;
2452 CHECK_STRING (string
);
2458 CHECK_NUMBER (base
);
2460 if (b
< 2 || b
> 16)
2461 xsignal1 (Qargs_out_of_range
, base
);
2464 /* Skip any whitespace at the front of the number. Some versions of
2465 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2467 while (*p
== ' ' || *p
== '\t')
2478 if (isfloat_string (p
, 1) && b
== 10)
2479 val
= make_float (sign
* atof (p
));
2486 int digit
= digit_to_number (*p
++, b
);
2492 val
= make_fixnum_or_float (sign
* v
);
2512 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2513 int, Lisp_Object
*);
2515 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2517 register Lisp_Object val
;
2518 register int argnum
;
2519 register EMACS_INT accum
= 0;
2520 register EMACS_INT next
;
2522 switch (SWITCH_ENUM_CAST (code
))
2540 for (argnum
= 0; argnum
< nargs
; argnum
++)
2542 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2544 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2547 return float_arith_driver ((double) accum
, argnum
, code
,
2550 next
= XINT (args
[argnum
]);
2551 switch (SWITCH_ENUM_CAST (code
))
2557 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2568 xsignal0 (Qarith_error
);
2582 if (!argnum
|| next
> accum
)
2586 if (!argnum
|| next
< accum
)
2592 XSETINT (val
, accum
);
2597 #define isnan(x) ((x) != (x))
2600 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2602 register Lisp_Object val
;
2605 for (; argnum
< nargs
; argnum
++)
2607 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2608 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2612 next
= XFLOAT_DATA (val
);
2616 args
[argnum
] = val
; /* runs into a compiler bug. */
2617 next
= XINT (args
[argnum
]);
2619 switch (SWITCH_ENUM_CAST (code
))
2625 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2635 if (! IEEE_FLOATING_POINT
&& next
== 0)
2636 xsignal0 (Qarith_error
);
2643 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2645 if (!argnum
|| isnan (next
) || next
> accum
)
2649 if (!argnum
|| isnan (next
) || next
< accum
)
2655 return make_float (accum
);
2659 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2660 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2661 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2662 (int nargs
, Lisp_Object
*args
)
2664 return arith_driver (Aadd
, nargs
, args
);
2667 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2668 doc
: /* Negate number or subtract numbers or markers and return the result.
2669 With one arg, negates it. With more than one arg,
2670 subtracts all but the first from the first.
2671 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2672 (int nargs
, Lisp_Object
*args
)
2674 return arith_driver (Asub
, nargs
, args
);
2677 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2678 doc
: /* Return product of any number of arguments, which are numbers or markers.
2679 usage: (* &rest NUMBERS-OR-MARKERS) */)
2680 (int nargs
, Lisp_Object
*args
)
2682 return arith_driver (Amult
, nargs
, args
);
2685 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2686 doc
: /* Return first argument divided by all the remaining arguments.
2687 The arguments must be numbers or markers.
2688 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2689 (int nargs
, Lisp_Object
*args
)
2692 for (argnum
= 2; argnum
< nargs
; argnum
++)
2693 if (FLOATP (args
[argnum
]))
2694 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2695 return arith_driver (Adiv
, nargs
, args
);
2698 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2699 doc
: /* Return remainder of X divided by Y.
2700 Both must be integers or markers. */)
2701 (register Lisp_Object x
, Lisp_Object y
)
2705 CHECK_NUMBER_COERCE_MARKER (x
);
2706 CHECK_NUMBER_COERCE_MARKER (y
);
2708 if (XFASTINT (y
) == 0)
2709 xsignal0 (Qarith_error
);
2711 XSETINT (val
, XINT (x
) % XINT (y
));
2725 /* If the magnitude of the result exceeds that of the divisor, or
2726 the sign of the result does not agree with that of the dividend,
2727 iterate with the reduced value. This does not yield a
2728 particularly accurate result, but at least it will be in the
2729 range promised by fmod. */
2731 r
-= f2
* floor (r
/ f2
);
2732 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2736 #endif /* ! HAVE_FMOD */
2738 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2739 doc
: /* Return X modulo Y.
2740 The result falls between zero (inclusive) and Y (exclusive).
2741 Both X and Y must be numbers or markers. */)
2742 (register Lisp_Object x
, Lisp_Object y
)
2747 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2748 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2750 if (FLOATP (x
) || FLOATP (y
))
2751 return fmod_float (x
, y
);
2757 xsignal0 (Qarith_error
);
2761 /* If the "remainder" comes out with the wrong sign, fix it. */
2762 if (i2
< 0 ? i1
> 0 : i1
< 0)
2769 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2770 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2771 The value is always a number; markers are converted to numbers.
2772 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2773 (int nargs
, Lisp_Object
*args
)
2775 return arith_driver (Amax
, nargs
, args
);
2778 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2779 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2780 The value is always a number; markers are converted to numbers.
2781 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2782 (int nargs
, Lisp_Object
*args
)
2784 return arith_driver (Amin
, nargs
, args
);
2787 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2788 doc
: /* Return bitwise-and of all the arguments.
2789 Arguments may be integers, or markers converted to integers.
2790 usage: (logand &rest INTS-OR-MARKERS) */)
2791 (int nargs
, Lisp_Object
*args
)
2793 return arith_driver (Alogand
, nargs
, args
);
2796 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2797 doc
: /* Return bitwise-or of all the arguments.
2798 Arguments may be integers, or markers converted to integers.
2799 usage: (logior &rest INTS-OR-MARKERS) */)
2800 (int nargs
, Lisp_Object
*args
)
2802 return arith_driver (Alogior
, nargs
, args
);
2805 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2806 doc
: /* Return bitwise-exclusive-or of all the arguments.
2807 Arguments may be integers, or markers converted to integers.
2808 usage: (logxor &rest INTS-OR-MARKERS) */)
2809 (int nargs
, Lisp_Object
*args
)
2811 return arith_driver (Alogxor
, nargs
, args
);
2814 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2815 doc
: /* Return VALUE with its bits shifted left by COUNT.
2816 If COUNT is negative, shifting is actually to the right.
2817 In this case, the sign bit is duplicated. */)
2818 (register Lisp_Object value
, Lisp_Object count
)
2820 register Lisp_Object val
;
2822 CHECK_NUMBER (value
);
2823 CHECK_NUMBER (count
);
2825 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2827 else if (XINT (count
) > 0)
2828 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2829 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2830 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2832 XSETINT (val
, XINT (value
) >> -XINT (count
));
2836 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2837 doc
: /* Return VALUE with its bits shifted left by COUNT.
2838 If COUNT is negative, shifting is actually to the right.
2839 In this case, zeros are shifted in on the left. */)
2840 (register Lisp_Object value
, Lisp_Object count
)
2842 register Lisp_Object val
;
2844 CHECK_NUMBER (value
);
2845 CHECK_NUMBER (count
);
2847 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2849 else if (XINT (count
) > 0)
2850 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2851 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2854 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2858 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2859 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2860 Markers are converted to integers. */)
2861 (register Lisp_Object number
)
2863 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2865 if (FLOATP (number
))
2866 return (make_float (1.0 + XFLOAT_DATA (number
)));
2868 XSETINT (number
, XINT (number
) + 1);
2872 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2873 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2874 Markers are converted to integers. */)
2875 (register Lisp_Object number
)
2877 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2879 if (FLOATP (number
))
2880 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2882 XSETINT (number
, XINT (number
) - 1);
2886 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2887 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2888 (register Lisp_Object number
)
2890 CHECK_NUMBER (number
);
2891 XSETINT (number
, ~XINT (number
));
2895 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2896 doc
: /* Return the byteorder for the machine.
2897 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2898 lowercase l) for small endian machines. */)
2901 unsigned i
= 0x04030201;
2902 int order
= *(char *)&i
== 1 ? 108 : 66;
2904 return make_number (order
);
2912 Lisp_Object error_tail
, arith_tail
;
2914 Qquote
= intern_c_string ("quote");
2915 Qlambda
= intern_c_string ("lambda");
2916 Qsubr
= intern_c_string ("subr");
2917 Qerror_conditions
= intern_c_string ("error-conditions");
2918 Qerror_message
= intern_c_string ("error-message");
2919 Qtop_level
= intern_c_string ("top-level");
2921 Qerror
= intern_c_string ("error");
2922 Qquit
= intern_c_string ("quit");
2923 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2924 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2925 Qvoid_function
= intern_c_string ("void-function");
2926 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2927 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2928 Qvoid_variable
= intern_c_string ("void-variable");
2929 Qsetting_constant
= intern_c_string ("setting-constant");
2930 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2932 Qinvalid_function
= intern_c_string ("invalid-function");
2933 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2934 Qno_catch
= intern_c_string ("no-catch");
2935 Qend_of_file
= intern_c_string ("end-of-file");
2936 Qarith_error
= intern_c_string ("arith-error");
2937 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2938 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2939 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2940 Qtext_read_only
= intern_c_string ("text-read-only");
2941 Qmark_inactive
= intern_c_string ("mark-inactive");
2943 Qlistp
= intern_c_string ("listp");
2944 Qconsp
= intern_c_string ("consp");
2945 Qsymbolp
= intern_c_string ("symbolp");
2946 Qkeywordp
= intern_c_string ("keywordp");
2947 Qintegerp
= intern_c_string ("integerp");
2948 Qnatnump
= intern_c_string ("natnump");
2949 Qwholenump
= intern_c_string ("wholenump");
2950 Qstringp
= intern_c_string ("stringp");
2951 Qarrayp
= intern_c_string ("arrayp");
2952 Qsequencep
= intern_c_string ("sequencep");
2953 Qbufferp
= intern_c_string ("bufferp");
2954 Qvectorp
= intern_c_string ("vectorp");
2955 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2956 Qmarkerp
= intern_c_string ("markerp");
2957 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2958 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2959 Qboundp
= intern_c_string ("boundp");
2960 Qfboundp
= intern_c_string ("fboundp");
2962 Qfloatp
= intern_c_string ("floatp");
2963 Qnumberp
= intern_c_string ("numberp");
2964 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2966 Qchar_table_p
= intern_c_string ("char-table-p");
2967 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2969 Qsubrp
= intern_c_string ("subrp");
2970 Qunevalled
= intern_c_string ("unevalled");
2971 Qmany
= intern_c_string ("many");
2973 Qcdr
= intern_c_string ("cdr");
2975 /* Handle automatic advice activation */
2976 Qad_advice_info
= intern_c_string ("ad-advice-info");
2977 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2979 error_tail
= pure_cons (Qerror
, Qnil
);
2981 /* ERROR is used as a signaler for random errors for which nothing else is right */
2983 Fput (Qerror
, Qerror_conditions
,
2985 Fput (Qerror
, Qerror_message
,
2986 make_pure_c_string ("error"));
2988 Fput (Qquit
, Qerror_conditions
,
2989 pure_cons (Qquit
, Qnil
));
2990 Fput (Qquit
, Qerror_message
,
2991 make_pure_c_string ("Quit"));
2993 Fput (Qwrong_type_argument
, Qerror_conditions
,
2994 pure_cons (Qwrong_type_argument
, error_tail
));
2995 Fput (Qwrong_type_argument
, Qerror_message
,
2996 make_pure_c_string ("Wrong type argument"));
2998 Fput (Qargs_out_of_range
, Qerror_conditions
,
2999 pure_cons (Qargs_out_of_range
, error_tail
));
3000 Fput (Qargs_out_of_range
, Qerror_message
,
3001 make_pure_c_string ("Args out of range"));
3003 Fput (Qvoid_function
, Qerror_conditions
,
3004 pure_cons (Qvoid_function
, error_tail
));
3005 Fput (Qvoid_function
, Qerror_message
,
3006 make_pure_c_string ("Symbol's function definition is void"));
3008 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3009 pure_cons (Qcyclic_function_indirection
, error_tail
));
3010 Fput (Qcyclic_function_indirection
, Qerror_message
,
3011 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3013 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3014 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3015 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3016 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3018 Qcircular_list
= intern_c_string ("circular-list");
3019 staticpro (&Qcircular_list
);
3020 Fput (Qcircular_list
, Qerror_conditions
,
3021 pure_cons (Qcircular_list
, error_tail
));
3022 Fput (Qcircular_list
, Qerror_message
,
3023 make_pure_c_string ("List contains a loop"));
3025 Fput (Qvoid_variable
, Qerror_conditions
,
3026 pure_cons (Qvoid_variable
, error_tail
));
3027 Fput (Qvoid_variable
, Qerror_message
,
3028 make_pure_c_string ("Symbol's value as variable is void"));
3030 Fput (Qsetting_constant
, Qerror_conditions
,
3031 pure_cons (Qsetting_constant
, error_tail
));
3032 Fput (Qsetting_constant
, Qerror_message
,
3033 make_pure_c_string ("Attempt to set a constant symbol"));
3035 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3036 pure_cons (Qinvalid_read_syntax
, error_tail
));
3037 Fput (Qinvalid_read_syntax
, Qerror_message
,
3038 make_pure_c_string ("Invalid read syntax"));
3040 Fput (Qinvalid_function
, Qerror_conditions
,
3041 pure_cons (Qinvalid_function
, error_tail
));
3042 Fput (Qinvalid_function
, Qerror_message
,
3043 make_pure_c_string ("Invalid function"));
3045 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3046 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3047 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3048 make_pure_c_string ("Wrong number of arguments"));
3050 Fput (Qno_catch
, Qerror_conditions
,
3051 pure_cons (Qno_catch
, error_tail
));
3052 Fput (Qno_catch
, Qerror_message
,
3053 make_pure_c_string ("No catch for tag"));
3055 Fput (Qend_of_file
, Qerror_conditions
,
3056 pure_cons (Qend_of_file
, error_tail
));
3057 Fput (Qend_of_file
, Qerror_message
,
3058 make_pure_c_string ("End of file during parsing"));
3060 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3061 Fput (Qarith_error
, Qerror_conditions
,
3063 Fput (Qarith_error
, Qerror_message
,
3064 make_pure_c_string ("Arithmetic error"));
3066 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3067 pure_cons (Qbeginning_of_buffer
, error_tail
));
3068 Fput (Qbeginning_of_buffer
, Qerror_message
,
3069 make_pure_c_string ("Beginning of buffer"));
3071 Fput (Qend_of_buffer
, Qerror_conditions
,
3072 pure_cons (Qend_of_buffer
, error_tail
));
3073 Fput (Qend_of_buffer
, Qerror_message
,
3074 make_pure_c_string ("End of buffer"));
3076 Fput (Qbuffer_read_only
, Qerror_conditions
,
3077 pure_cons (Qbuffer_read_only
, error_tail
));
3078 Fput (Qbuffer_read_only
, Qerror_message
,
3079 make_pure_c_string ("Buffer is read-only"));
3081 Fput (Qtext_read_only
, Qerror_conditions
,
3082 pure_cons (Qtext_read_only
, error_tail
));
3083 Fput (Qtext_read_only
, Qerror_message
,
3084 make_pure_c_string ("Text is read-only"));
3086 Qrange_error
= intern_c_string ("range-error");
3087 Qdomain_error
= intern_c_string ("domain-error");
3088 Qsingularity_error
= intern_c_string ("singularity-error");
3089 Qoverflow_error
= intern_c_string ("overflow-error");
3090 Qunderflow_error
= intern_c_string ("underflow-error");
3092 Fput (Qdomain_error
, Qerror_conditions
,
3093 pure_cons (Qdomain_error
, arith_tail
));
3094 Fput (Qdomain_error
, Qerror_message
,
3095 make_pure_c_string ("Arithmetic domain error"));
3097 Fput (Qrange_error
, Qerror_conditions
,
3098 pure_cons (Qrange_error
, arith_tail
));
3099 Fput (Qrange_error
, Qerror_message
,
3100 make_pure_c_string ("Arithmetic range error"));
3102 Fput (Qsingularity_error
, Qerror_conditions
,
3103 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3104 Fput (Qsingularity_error
, Qerror_message
,
3105 make_pure_c_string ("Arithmetic singularity error"));
3107 Fput (Qoverflow_error
, Qerror_conditions
,
3108 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3109 Fput (Qoverflow_error
, Qerror_message
,
3110 make_pure_c_string ("Arithmetic overflow error"));
3112 Fput (Qunderflow_error
, Qerror_conditions
,
3113 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3114 Fput (Qunderflow_error
, Qerror_message
,
3115 make_pure_c_string ("Arithmetic underflow error"));
3117 staticpro (&Qrange_error
);
3118 staticpro (&Qdomain_error
);
3119 staticpro (&Qsingularity_error
);
3120 staticpro (&Qoverflow_error
);
3121 staticpro (&Qunderflow_error
);
3125 staticpro (&Qquote
);
3126 staticpro (&Qlambda
);
3128 staticpro (&Qunbound
);
3129 staticpro (&Qerror_conditions
);
3130 staticpro (&Qerror_message
);
3131 staticpro (&Qtop_level
);
3133 staticpro (&Qerror
);
3135 staticpro (&Qwrong_type_argument
);
3136 staticpro (&Qargs_out_of_range
);
3137 staticpro (&Qvoid_function
);
3138 staticpro (&Qcyclic_function_indirection
);
3139 staticpro (&Qcyclic_variable_indirection
);
3140 staticpro (&Qvoid_variable
);
3141 staticpro (&Qsetting_constant
);
3142 staticpro (&Qinvalid_read_syntax
);
3143 staticpro (&Qwrong_number_of_arguments
);
3144 staticpro (&Qinvalid_function
);
3145 staticpro (&Qno_catch
);
3146 staticpro (&Qend_of_file
);
3147 staticpro (&Qarith_error
);
3148 staticpro (&Qbeginning_of_buffer
);
3149 staticpro (&Qend_of_buffer
);
3150 staticpro (&Qbuffer_read_only
);
3151 staticpro (&Qtext_read_only
);
3152 staticpro (&Qmark_inactive
);
3154 staticpro (&Qlistp
);
3155 staticpro (&Qconsp
);
3156 staticpro (&Qsymbolp
);
3157 staticpro (&Qkeywordp
);
3158 staticpro (&Qintegerp
);
3159 staticpro (&Qnatnump
);
3160 staticpro (&Qwholenump
);
3161 staticpro (&Qstringp
);
3162 staticpro (&Qarrayp
);
3163 staticpro (&Qsequencep
);
3164 staticpro (&Qbufferp
);
3165 staticpro (&Qvectorp
);
3166 staticpro (&Qchar_or_string_p
);
3167 staticpro (&Qmarkerp
);
3168 staticpro (&Qbuffer_or_string_p
);
3169 staticpro (&Qinteger_or_marker_p
);
3170 staticpro (&Qfloatp
);
3171 staticpro (&Qnumberp
);
3172 staticpro (&Qnumber_or_marker_p
);
3173 staticpro (&Qchar_table_p
);
3174 staticpro (&Qvector_or_char_table_p
);
3175 staticpro (&Qsubrp
);
3177 staticpro (&Qunevalled
);
3179 staticpro (&Qboundp
);
3180 staticpro (&Qfboundp
);
3182 staticpro (&Qad_advice_info
);
3183 staticpro (&Qad_activate_internal
);
3185 /* Types that type-of returns. */
3186 Qinteger
= intern_c_string ("integer");
3187 Qsymbol
= intern_c_string ("symbol");
3188 Qstring
= intern_c_string ("string");
3189 Qcons
= intern_c_string ("cons");
3190 Qmarker
= intern_c_string ("marker");
3191 Qoverlay
= intern_c_string ("overlay");
3192 Qfloat
= intern_c_string ("float");
3193 Qwindow_configuration
= intern_c_string ("window-configuration");
3194 Qprocess
= intern_c_string ("process");
3195 Qwindow
= intern_c_string ("window");
3196 /* Qsubr = intern_c_string ("subr"); */
3197 Qcompiled_function
= intern_c_string ("compiled-function");
3198 Qfunction_vector
= intern_c_string ("function-vector");
3199 Qbuffer
= intern_c_string ("buffer");
3200 Qframe
= intern_c_string ("frame");
3201 Qvector
= intern_c_string ("vector");
3202 Qchar_table
= intern_c_string ("char-table");
3203 Qbool_vector
= intern_c_string ("bool-vector");
3204 Qhash_table
= intern_c_string ("hash-table");
3206 DEFSYM (Qfont_spec
, "font-spec");
3207 DEFSYM (Qfont_entity
, "font-entity");
3208 DEFSYM (Qfont_object
, "font-object");
3210 DEFSYM (Qinteractive_form
, "interactive-form");
3212 staticpro (&Qinteger
);
3213 staticpro (&Qsymbol
);
3214 staticpro (&Qstring
);
3216 staticpro (&Qmarker
);
3217 staticpro (&Qoverlay
);
3218 staticpro (&Qfloat
);
3219 staticpro (&Qwindow_configuration
);
3220 staticpro (&Qprocess
);
3221 staticpro (&Qwindow
);
3222 /* staticpro (&Qsubr); */
3223 staticpro (&Qcompiled_function
);
3224 staticpro (&Qfunction_vector
);
3225 staticpro (&Qbuffer
);
3226 staticpro (&Qframe
);
3227 staticpro (&Qvector
);
3228 staticpro (&Qchar_table
);
3229 staticpro (&Qbool_vector
);
3230 staticpro (&Qhash_table
);
3232 defsubr (&Sindirect_variable
);
3233 defsubr (&Sinteractive_form
);
3236 defsubr (&Stype_of
);
3241 defsubr (&Sintegerp
);
3242 defsubr (&Sinteger_or_marker_p
);
3243 defsubr (&Snumberp
);
3244 defsubr (&Snumber_or_marker_p
);
3246 defsubr (&Snatnump
);
3247 defsubr (&Ssymbolp
);
3248 defsubr (&Skeywordp
);
3249 defsubr (&Sstringp
);
3250 defsubr (&Smultibyte_string_p
);
3251 defsubr (&Svectorp
);
3252 defsubr (&Schar_table_p
);
3253 defsubr (&Svector_or_char_table_p
);
3254 defsubr (&Sbool_vector_p
);
3256 defsubr (&Ssequencep
);
3257 defsubr (&Sbufferp
);
3258 defsubr (&Smarkerp
);
3260 defsubr (&Sbyte_code_function_p
);
3261 defsubr (&Sfunvecp
);
3262 defsubr (&Schar_or_string_p
);
3265 defsubr (&Scar_safe
);
3266 defsubr (&Scdr_safe
);
3269 defsubr (&Ssymbol_function
);
3270 defsubr (&Sindirect_function
);
3271 defsubr (&Ssymbol_plist
);
3272 defsubr (&Ssymbol_name
);
3273 defsubr (&Smakunbound
);
3274 defsubr (&Sfmakunbound
);
3276 defsubr (&Sfboundp
);
3278 defsubr (&Sdefalias
);
3279 defsubr (&Ssetplist
);
3280 defsubr (&Ssymbol_value
);
3282 defsubr (&Sdefault_boundp
);
3283 defsubr (&Sdefault_value
);
3284 defsubr (&Sset_default
);
3285 defsubr (&Ssetq_default
);
3286 defsubr (&Smake_variable_buffer_local
);
3287 defsubr (&Smake_local_variable
);
3288 defsubr (&Skill_local_variable
);
3289 defsubr (&Smake_variable_frame_local
);
3290 defsubr (&Slocal_variable_p
);
3291 defsubr (&Slocal_variable_if_set_p
);
3292 defsubr (&Svariable_binding_locus
);
3293 #if 0 /* XXX Remove this. --lorentey */
3294 defsubr (&Sterminal_local_value
);
3295 defsubr (&Sset_terminal_local_value
);
3299 defsubr (&Snumber_to_string
);
3300 defsubr (&Sstring_to_number
);
3301 defsubr (&Seqlsign
);
3324 defsubr (&Sbyteorder
);
3325 defsubr (&Ssubr_arity
);
3326 defsubr (&Ssubr_name
);
3328 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3330 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3331 doc
: /* The largest value that is representable in a Lisp integer. */);
3332 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3333 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3335 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3336 doc
: /* The smallest value that is representable in a Lisp integer. */);
3337 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3338 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3342 arith_error (int signo
)
3344 sigsetmask (SIGEMPTYMASK
);
3346 SIGNAL_THREAD_CHECK (signo
);
3347 xsignal0 (Qarith_error
);
3353 /* Don't do this if just dumping out.
3354 We don't want to call `signal' in this case
3355 so that we don't have trouble with dumping
3356 signal-delivering routines in an inconsistent state. */
3360 #endif /* CANNOT_DUMP */
3361 signal (SIGFPE
, arith_error
);
3364 signal (SIGEMT
, arith_error
);
3368 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3369 (do not change this comment) */