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 ();
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
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
87 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
96 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
100 circular_list_error (list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (predicate
, value
)
109 register Lisp_Object predicate
, value
;
111 /* If VALUE is not even a valid Lisp object, we'd want to abort here
112 where we can get a backtrace showing where it came from. We used
113 to try and do that by checking the tagbits, but nowadays all
114 tagbits are potentially valid. */
115 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
118 xsignal2 (Qwrong_type_argument
, predicate
, value
);
124 error ("Attempt to modify read-only object");
128 args_out_of_range (a1
, a2
)
131 xsignal2 (Qargs_out_of_range
, a1
, a2
);
135 args_out_of_range_3 (a1
, a2
, a3
)
136 Lisp_Object a1
, a2
, a3
;
138 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
141 /* On some machines, XINT needs a temporary location.
142 Here it is, in case it is needed. */
144 int sign_extend_temp
;
146 /* On a few machines, XINT can only be done by calling this. */
149 sign_extend_lisp_int (num
)
152 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
153 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
155 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
158 /* Data type predicates */
160 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
161 doc
: /* Return t if the two args are the same Lisp object. */)
163 Lisp_Object obj1
, obj2
;
170 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
171 doc
: /* Return t if OBJECT is nil. */)
180 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
181 doc
: /* Return a symbol representing the type of OBJECT.
182 The symbol returned names the object's basic type;
183 for example, (type-of 1) returns `integer'. */)
187 switch (XTYPE (object
))
202 switch (XMISCTYPE (object
))
204 case Lisp_Misc_Marker
:
206 case Lisp_Misc_Overlay
:
208 case Lisp_Misc_Float
:
213 case Lisp_Vectorlike
:
214 if (WINDOW_CONFIGURATIONP (object
))
215 return Qwindow_configuration
;
216 if (PROCESSP (object
))
218 if (WINDOWP (object
))
222 if (COMPILEDP (object
))
223 return Qcompiled_function
;
224 if (BUFFERP (object
))
226 if (CHAR_TABLE_P (object
))
228 if (BOOL_VECTOR_P (object
))
232 if (HASH_TABLE_P (object
))
234 if (FONT_SPEC_P (object
))
236 if (FONT_ENTITY_P (object
))
238 if (FONT_OBJECT_P (object
))
250 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
251 doc
: /* Return t if OBJECT is a cons cell. */)
260 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
261 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
270 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
271 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
272 Otherwise, return nil. */)
276 if (CONSP (object
) || NILP (object
))
281 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
282 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
286 if (CONSP (object
) || NILP (object
))
291 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
292 doc
: /* Return t if OBJECT is a symbol. */)
296 if (SYMBOLP (object
))
301 /* Define this in C to avoid unnecessarily consing up the symbol
303 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
304 doc
: /* Return t if OBJECT is a keyword.
305 This means that it is a symbol with a print name beginning with `:'
306 interned in the initial obarray. */)
311 && SREF (SYMBOL_NAME (object
), 0) == ':'
312 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
317 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
318 doc
: /* Return t if OBJECT is a vector. */)
322 if (VECTORP (object
))
327 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
328 doc
: /* Return t if OBJECT is a string. */)
332 if (STRINGP (object
))
337 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
339 doc
: /* Return t if OBJECT is a multibyte string. */)
343 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
348 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
349 doc
: /* Return t if OBJECT is a char-table. */)
353 if (CHAR_TABLE_P (object
))
358 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
359 Svector_or_char_table_p
, 1, 1, 0,
360 doc
: /* Return t if OBJECT is a char-table or vector. */)
364 if (VECTORP (object
) || CHAR_TABLE_P (object
))
369 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a bool-vector. */)
374 if (BOOL_VECTOR_P (object
))
379 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
380 doc
: /* Return t if OBJECT is an array (string or vector). */)
389 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
390 doc
: /* Return t if OBJECT is a sequence (list or array). */)
392 register Lisp_Object object
;
394 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
399 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
400 doc
: /* Return t if OBJECT is an editor buffer. */)
404 if (BUFFERP (object
))
409 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
410 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
414 if (MARKERP (object
))
419 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
420 doc
: /* Return t if OBJECT is a built-in function. */)
429 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
431 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
435 if (COMPILEDP (object
))
440 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
441 doc
: /* Return t if OBJECT is a character or a string. */)
443 register Lisp_Object object
;
445 if (CHARACTERP (object
) || STRINGP (object
))
450 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
451 doc
: /* Return t if OBJECT is an integer. */)
455 if (INTEGERP (object
))
460 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
461 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
463 register Lisp_Object object
;
465 if (MARKERP (object
) || INTEGERP (object
))
470 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
471 doc
: /* Return t if OBJECT is a nonnegative integer. */)
475 if (NATNUMP (object
))
480 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
481 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
485 if (NUMBERP (object
))
491 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
492 Snumber_or_marker_p
, 1, 1, 0,
493 doc
: /* Return t if OBJECT is a number or a marker. */)
497 if (NUMBERP (object
) || MARKERP (object
))
502 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
503 doc
: /* Return t if OBJECT is a floating point number. */)
513 /* Extract and set components of lists */
515 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
516 doc
: /* Return the car of LIST. If arg is nil, return nil.
517 Error if arg is not nil and not a cons cell. See also `car-safe'.
519 See Info node `(elisp)Cons Cells' for a discussion of related basic
520 Lisp concepts such as car, cdr, cons cell and list. */)
522 register Lisp_Object list
;
527 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
528 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
532 return CAR_SAFE (object
);
535 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
536 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
537 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
539 See Info node `(elisp)Cons Cells' for a discussion of related basic
540 Lisp concepts such as cdr, car, cons cell and list. */)
542 register Lisp_Object list
;
547 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
548 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
552 return CDR_SAFE (object
);
555 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
556 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
558 register Lisp_Object cell
, newcar
;
562 XSETCAR (cell
, newcar
);
566 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
567 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
569 register Lisp_Object cell
, newcdr
;
573 XSETCDR (cell
, newcdr
);
577 /* Extract and set components of symbols */
579 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
580 doc
: /* Return t if SYMBOL's value is not void. */)
582 register Lisp_Object symbol
;
584 Lisp_Object valcontents
;
585 struct Lisp_Symbol
*sym
;
586 CHECK_SYMBOL (symbol
);
587 sym
= XSYMBOL (symbol
);
590 switch (sym
->redirect
)
592 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
593 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
594 case SYMBOL_LOCALIZED
:
596 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
598 /* In set_internal, we un-forward vars when their value is
603 swap_in_symval_forwarding (sym
, blv
);
604 valcontents
= BLV_VALUE (blv
);
608 case SYMBOL_FORWARDED
:
609 /* In set_internal, we un-forward vars when their value is
615 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
618 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
619 doc
: /* Return t if SYMBOL's function definition is not void. */)
621 register Lisp_Object symbol
;
623 CHECK_SYMBOL (symbol
);
624 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
627 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
628 doc
: /* Make SYMBOL's value be void.
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
);
634 if (SYMBOL_CONSTANT_P (symbol
))
635 xsignal1 (Qsetting_constant
, symbol
);
636 Fset (symbol
, Qunbound
);
640 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
641 doc
: /* Make SYMBOL's function definition be void.
644 register Lisp_Object symbol
;
646 CHECK_SYMBOL (symbol
);
647 if (NILP (symbol
) || EQ (symbol
, Qt
))
648 xsignal1 (Qsetting_constant
, symbol
);
649 XSYMBOL (symbol
)->function
= Qunbound
;
653 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
654 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
656 register Lisp_Object symbol
;
658 CHECK_SYMBOL (symbol
);
659 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
660 return XSYMBOL (symbol
)->function
;
661 xsignal1 (Qvoid_function
, symbol
);
664 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
665 doc
: /* Return SYMBOL's property list. */)
667 register Lisp_Object symbol
;
669 CHECK_SYMBOL (symbol
);
670 return XSYMBOL (symbol
)->plist
;
673 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
674 doc
: /* Return SYMBOL's name, a string. */)
676 register Lisp_Object symbol
;
678 register Lisp_Object name
;
680 CHECK_SYMBOL (symbol
);
681 name
= SYMBOL_NAME (symbol
);
685 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
686 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
688 register Lisp_Object symbol
, definition
;
690 register Lisp_Object function
;
692 CHECK_SYMBOL (symbol
);
693 if (NILP (symbol
) || EQ (symbol
, Qt
))
694 xsignal1 (Qsetting_constant
, symbol
);
696 function
= XSYMBOL (symbol
)->function
;
698 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
699 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
701 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
702 Fput (symbol
, Qautoload
, XCDR (function
));
704 XSYMBOL (symbol
)->function
= definition
;
705 /* Handle automatic advice activation */
706 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
708 call2 (Qad_activate_internal
, symbol
, Qnil
);
709 definition
= XSYMBOL (symbol
)->function
;
714 extern Lisp_Object Qfunction_documentation
;
716 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
717 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
718 Associates the function with the current load file, if any.
719 The optional third argument DOCSTRING specifies the documentation string
720 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
721 determined by DEFINITION. */)
722 (symbol
, definition
, docstring
)
723 register Lisp_Object symbol
, definition
, docstring
;
725 CHECK_SYMBOL (symbol
);
726 if (CONSP (XSYMBOL (symbol
)->function
)
727 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
728 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
729 definition
= Ffset (symbol
, definition
);
730 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
731 if (!NILP (docstring
))
732 Fput (symbol
, Qfunction_documentation
, docstring
);
736 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
737 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
739 register Lisp_Object symbol
, newplist
;
741 CHECK_SYMBOL (symbol
);
742 XSYMBOL (symbol
)->plist
= newplist
;
746 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
747 doc
: /* Return minimum and maximum number of args allowed for SUBR.
748 SUBR must be a built-in function.
749 The returned value is a pair (MIN . MAX). MIN is the minimum number
750 of args. MAX is the maximum number or the symbol `many', for a
751 function with `&rest' args, or `unevalled' for a special form. */)
755 short minargs
, maxargs
;
757 minargs
= XSUBR (subr
)->min_args
;
758 maxargs
= XSUBR (subr
)->max_args
;
760 return Fcons (make_number (minargs
), Qmany
);
761 else if (maxargs
== UNEVALLED
)
762 return Fcons (make_number (minargs
), Qunevalled
);
764 return Fcons (make_number (minargs
), make_number (maxargs
));
767 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
768 doc
: /* Return name of subroutine SUBR.
769 SUBR must be a built-in function. */)
775 name
= XSUBR (subr
)->symbol_name
;
776 return make_string (name
, strlen (name
));
779 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
780 doc
: /* Return the interactive form of CMD or nil if none.
781 If CMD is not a command, the return value is nil.
782 Value, if non-nil, is a list \(interactive SPEC). */)
786 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
788 if (NILP (fun
) || EQ (fun
, Qunbound
))
791 /* Use an `interactive-form' property if present, analogous to the
792 function-documentation property. */
794 while (SYMBOLP (fun
))
796 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
800 fun
= Fsymbol_function (fun
);
805 char *spec
= XSUBR (fun
)->intspec
;
807 return list2 (Qinteractive
,
808 (*spec
!= '(') ? build_string (spec
) :
809 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
811 else if (COMPILEDP (fun
))
813 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
814 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
816 else if (CONSP (fun
))
818 Lisp_Object funcar
= XCAR (fun
);
819 if (EQ (funcar
, Qlambda
))
820 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
821 else if (EQ (funcar
, Qautoload
))
825 do_autoload (fun
, cmd
);
827 return Finteractive_form (cmd
);
834 /***********************************************************************
835 Getting and Setting Values of Symbols
836 ***********************************************************************/
838 /* Return the symbol holding SYMBOL's value. Signal
839 `cyclic-variable-indirection' if SYMBOL's chain of variable
840 indirections contains a loop. */
843 indirect_variable (symbol
)
844 struct Lisp_Symbol
*symbol
;
846 struct Lisp_Symbol
*tortoise
, *hare
;
848 hare
= tortoise
= symbol
;
850 while (hare
->redirect
== SYMBOL_VARALIAS
)
852 hare
= SYMBOL_ALIAS (hare
);
853 if (hare
->redirect
!= SYMBOL_VARALIAS
)
856 hare
= SYMBOL_ALIAS (hare
);
857 tortoise
= SYMBOL_ALIAS (tortoise
);
859 if (hare
== tortoise
)
862 XSETSYMBOL (tem
, symbol
);
863 xsignal1 (Qcyclic_variable_indirection
, tem
);
871 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
872 doc
: /* Return the variable at the end of OBJECT's variable chain.
873 If OBJECT is a symbol, follow all variable indirections and return the final
874 variable. If OBJECT is not a symbol, just return it.
875 Signal a cyclic-variable-indirection error if there is a loop in the
876 variable chain of symbols. */)
880 if (SYMBOLP (object
))
881 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
886 /* Given the raw contents of a symbol value cell,
887 return the Lisp value of the symbol.
888 This does not handle buffer-local variables; use
889 swap_in_symval_forwarding for that. */
891 #define do_blv_forwarding(blv) \
892 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
895 do_symval_forwarding (valcontents
)
896 register union Lisp_Fwd
*valcontents
;
898 register Lisp_Object val
;
899 switch (XFWDTYPE (valcontents
))
902 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
906 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
909 return *XOBJFWD (valcontents
)->objvar
;
911 case Lisp_Fwd_Buffer_Obj
:
912 return PER_BUFFER_VALUE (current_buffer
,
913 XBUFFER_OBJFWD (valcontents
)->offset
);
915 case Lisp_Fwd_Kboard_Obj
:
916 /* We used to simply use current_kboard here, but from Lisp
917 code, it's value is often unexpected. It seems nicer to
918 allow constructions like this to work as intuitively expected:
920 (with-selected-frame frame
921 (define-key local-function-map "\eOP" [f1]))
923 On the other hand, this affects the semantics of
924 last-command and real-last-command, and people may rely on
925 that. I took a quick look at the Lisp codebase, and I
926 don't think anything will break. --lorentey */
927 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
928 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
933 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
934 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
935 buffer-independent contents of the value cell: forwarded just one
936 step past the buffer-localness.
938 BUF non-zero means set the value in buffer BUF instead of the
939 current buffer. This only plays a role for per-buffer variables. */
941 #define store_blv_forwarding(blv, newval, buf) \
943 if ((blv)->forwarded) \
944 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
946 SET_BLV_VALUE (blv, newval); \
950 store_symval_forwarding (/* symbol, */ valcontents
, newval
, buf
)
951 /* struct Lisp_Symbol *symbol; */
952 union Lisp_Fwd
*valcontents
;
953 register Lisp_Object newval
;
956 switch (XFWDTYPE (valcontents
))
959 CHECK_NUMBER (newval
);
960 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
964 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
968 *XOBJFWD (valcontents
)->objvar
= newval
;
970 /* If this variable is a default for something stored
971 in the buffer itself, such as default-fill-column,
972 find the buffers that don't have local values for it
974 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
975 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
977 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
978 - (char *) &buffer_defaults
);
979 int idx
= PER_BUFFER_IDX (offset
);
986 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
991 buf
= Fcdr (XCAR (tail
));
992 if (!BUFFERP (buf
)) continue;
995 if (! PER_BUFFER_VALUE_P (b
, idx
))
996 PER_BUFFER_VALUE (b
, offset
) = newval
;
1001 case Lisp_Fwd_Buffer_Obj
:
1003 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1004 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1006 if (!(NILP (type
) || NILP (newval
)
1007 || (XINT (type
) == LISP_INT_TAG
1009 : XTYPE (newval
) == XINT (type
))))
1010 buffer_slot_type_mismatch (newval
, XINT (type
));
1013 buf
= current_buffer
;
1014 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1018 case Lisp_Fwd_Kboard_Obj
:
1020 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1021 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1022 *(Lisp_Object
*) p
= newval
;
1027 abort (); /* goto def; */
1031 /* Set up SYMBOL to refer to its global binding.
1032 This makes it safe to alter the status of other bindings. */
1035 swap_in_global_binding (symbol
)
1036 struct Lisp_Symbol
*symbol
;
1038 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1040 /* Unload the previously loaded binding. */
1042 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1044 /* Select the global binding in the symbol. */
1045 blv
->valcell
= blv
->defcell
;
1047 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1049 /* Indicate that the global binding is set up now. */
1051 SET_BLV_FOUND (blv
, 0);
1054 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1055 VALCONTENTS is the contents of its value cell,
1056 which points to a struct Lisp_Buffer_Local_Value.
1058 Return the value forwarded one step past the buffer-local stage.
1059 This could be another forwarding pointer. */
1062 swap_in_symval_forwarding (symbol
, blv
)
1063 struct Lisp_Symbol
*symbol
;
1064 struct Lisp_Buffer_Local_Value
*blv
;
1066 register Lisp_Object tem1
;
1068 eassert (blv
== SYMBOL_BLV (symbol
));
1073 || (blv
->frame_local
1074 ? !EQ (selected_frame
, tem1
)
1075 : current_buffer
!= XBUFFER (tem1
)))
1078 /* Unload the previously loaded binding. */
1079 tem1
= blv
->valcell
;
1081 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1082 /* Choose the new binding. */
1085 XSETSYMBOL (var
, symbol
);
1086 if (blv
->frame_local
)
1088 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1089 blv
->where
= selected_frame
;
1093 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1094 XSETBUFFER (blv
->where
, current_buffer
);
1097 if (!(blv
->found
= !NILP (tem1
)))
1098 tem1
= blv
->defcell
;
1100 /* Load the new binding. */
1101 blv
->valcell
= tem1
;
1103 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1107 /* Find the value of a symbol, returning Qunbound if it's not bound.
1108 This is helpful for code which just wants to get a variable's value
1109 if it has one, without signaling an error.
1110 Note that it must not be possible to quit
1111 within this function. Great care is required for this. */
1114 find_symbol_value (symbol
)
1117 struct Lisp_Symbol
*sym
;
1119 CHECK_SYMBOL (symbol
);
1120 sym
= XSYMBOL (symbol
);
1123 switch (sym
->redirect
)
1125 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1126 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1127 case SYMBOL_LOCALIZED
:
1129 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1130 swap_in_symval_forwarding (sym
, blv
);
1131 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1134 case SYMBOL_FORWARDED
:
1135 return do_symval_forwarding (SYMBOL_FWD (sym
));
1140 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1141 doc
: /* Return SYMBOL's value. Error if that is void. */)
1147 val
= find_symbol_value (symbol
);
1148 if (!EQ (val
, Qunbound
))
1151 xsignal1 (Qvoid_variable
, symbol
);
1154 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1155 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1157 register Lisp_Object symbol
, newval
;
1159 set_internal (symbol
, newval
, current_buffer
, 0);
1163 /* Return 1 if SYMBOL currently has a let-binding
1164 which was made in the buffer that is now current. */
1167 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1169 struct specbinding
*p
;
1171 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1173 && CONSP (p
->symbol
))
1175 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1176 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1177 if (symbol
== let_bound_symbol
1178 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1182 return p
>= specpdl
;
1186 let_shadows_global_binding_p (symbol
)
1189 struct specbinding
*p
;
1191 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1192 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1195 return p
>= specpdl
;
1198 /* Store the value NEWVAL into SYMBOL.
1199 If buffer-locality is an issue, BUF specifies which buffer to use.
1200 (0 stands for the current buffer.)
1202 If BINDFLAG is zero, then if this symbol is supposed to become
1203 local in every buffer where it is set, then we make it local.
1204 If BINDFLAG is nonzero, we don't do that. */
1207 set_internal (symbol
, newval
, buf
, bindflag
)
1208 register Lisp_Object symbol
, newval
;
1212 int voide
= EQ (newval
, Qunbound
);
1213 struct Lisp_Symbol
*sym
;
1217 buf
= current_buffer
;
1219 /* If restoring in a dead buffer, do nothing. */
1220 if (NILP (buf
->name
))
1223 CHECK_SYMBOL (symbol
);
1224 if (SYMBOL_CONSTANT_P (symbol
))
1226 if (NILP (Fkeywordp (symbol
))
1227 || !EQ (newval
, Fsymbol_value (symbol
)))
1228 xsignal1 (Qsetting_constant
, symbol
);
1230 /* Allow setting keywords to their own value. */
1234 sym
= XSYMBOL (symbol
);
1237 switch (sym
->redirect
)
1239 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1240 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1241 case SYMBOL_LOCALIZED
:
1243 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1244 Lisp_Object tmp
; XSETBUFFER (tmp
, buf
);
1246 /* If the current buffer is not the buffer whose binding is
1247 loaded, or if there may be frame-local bindings and the frame
1248 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1249 the default binding is loaded, the loaded binding may be the
1251 if (!EQ (blv
->where
,
1252 blv
->frame_local
? selected_frame
: tmp
)
1253 /* Also unload a global binding (if the var is local_if_set). */
1254 || (EQ (blv
->valcell
, blv
->defcell
)))
1256 /* The currently loaded binding is not necessarily valid.
1257 We need to unload it, and choose a new binding. */
1259 /* Write out `realvalue' to the old loaded binding. */
1261 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1263 /* Find the new binding. */
1265 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1266 if (blv
->frame_local
)
1268 tem1
= Fassq (symbol
, XFRAME (selected_frame
)->param_alist
);
1269 blv
->where
= selected_frame
;
1273 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1281 /* This buffer still sees the default value. */
1283 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1284 or if this is `let' rather than `set',
1285 make CURRENT-ALIST-ELEMENT point to itself,
1286 indicating that we're seeing the default value.
1287 Likewise if the variable has been let-bound
1288 in the current buffer. */
1289 if (bindflag
|| !blv
->local_if_set
1290 || let_shadows_buffer_binding_p (sym
))
1293 tem1
= blv
->defcell
;
1295 /* If it's a local_if_set, being set not bound,
1296 and we're not within a let that was made for this buffer,
1297 create a new buffer-local binding for the variable.
1298 That means, give this buffer a new assoc for a local value
1299 and load that binding. */
1302 /* local_if_set is only supported for buffer-local
1303 bindings, not for frame-local bindings. */
1304 eassert (!blv
->frame_local
);
1305 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1306 buf
->local_var_alist
1307 = Fcons (tem1
, buf
->local_var_alist
);
1311 /* Record which binding is now loaded. */
1312 blv
->valcell
= tem1
;
1315 /* Store the new value in the cons cell. */
1316 SET_BLV_VALUE (blv
, newval
);
1321 /* If storing void (making the symbol void), forward only through
1322 buffer-local indicator, not through Lisp_Objfwd, etc. */
1325 store_symval_forwarding (blv
->fwd
, newval
, buf
);
1329 case SYMBOL_FORWARDED
:
1331 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1332 if (BUFFER_OBJFWDP (innercontents
))
1334 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1335 int idx
= PER_BUFFER_IDX (offset
);
1338 && !let_shadows_buffer_binding_p (sym
))
1339 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1343 { /* If storing void (making the symbol void), forward only through
1344 buffer-local indicator, not through Lisp_Objfwd, etc. */
1345 sym
->redirect
= SYMBOL_PLAINVAL
;
1346 SET_SYMBOL_VAL (sym
, newval
);
1349 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1357 /* Access or set a buffer-local symbol's default value. */
1359 /* Return the default value of SYMBOL, but don't check for voidness.
1360 Return Qunbound if it is void. */
1363 default_value (symbol
)
1366 struct Lisp_Symbol
*sym
;
1368 CHECK_SYMBOL (symbol
);
1369 sym
= XSYMBOL (symbol
);
1372 switch (sym
->redirect
)
1374 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1375 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1376 case SYMBOL_LOCALIZED
:
1378 /* If var is set up for a buffer that lacks a local value for it,
1379 the current value is nominally the default value.
1380 But the `realvalue' slot may be more up to date, since
1381 ordinary setq stores just that slot. So use that. */
1382 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1383 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1384 return do_symval_forwarding (blv
->fwd
);
1386 return XCDR (blv
->defcell
);
1388 case SYMBOL_FORWARDED
:
1390 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1392 /* For a built-in buffer-local variable, get the default value
1393 rather than letting do_symval_forwarding get the current value. */
1394 if (BUFFER_OBJFWDP (valcontents
))
1396 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1397 if (PER_BUFFER_IDX (offset
) != 0)
1398 return PER_BUFFER_DEFAULT (offset
);
1401 /* For other variables, get the current value. */
1402 return do_symval_forwarding (valcontents
);
1408 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1409 doc
: /* Return t if SYMBOL has a non-void default value.
1410 This is the value that is seen in buffers that do not have their own values
1411 for this variable. */)
1415 register Lisp_Object value
;
1417 value
= default_value (symbol
);
1418 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1421 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1422 doc
: /* Return SYMBOL's default value.
1423 This is the value that is seen in buffers that do not have their own values
1424 for this variable. The default value is meaningful for variables with
1425 local bindings in certain buffers. */)
1429 register Lisp_Object value
;
1431 value
= default_value (symbol
);
1432 if (!EQ (value
, Qunbound
))
1435 xsignal1 (Qvoid_variable
, symbol
);
1438 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1439 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1440 The default value is seen in buffers that do not have their own values
1441 for this variable. */)
1443 Lisp_Object symbol
, value
;
1445 struct Lisp_Symbol
*sym
;
1447 CHECK_SYMBOL (symbol
);
1448 if (SYMBOL_CONSTANT_P (symbol
))
1450 if (NILP (Fkeywordp (symbol
))
1451 || !EQ (value
, Fdefault_value (symbol
)))
1452 xsignal1 (Qsetting_constant
, symbol
);
1454 /* Allow setting keywords to their own value. */
1457 sym
= XSYMBOL (symbol
);
1460 switch (sym
->redirect
)
1462 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1463 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1464 case SYMBOL_LOCALIZED
:
1466 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1468 /* Store new value into the DEFAULT-VALUE slot. */
1469 XSETCDR (blv
->defcell
, value
);
1471 /* If the default binding is now loaded, set the REALVALUE slot too. */
1472 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1473 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1476 case SYMBOL_FORWARDED
:
1478 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1480 /* Handle variables like case-fold-search that have special slots
1482 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1483 if (BUFFER_OBJFWDP (valcontents
))
1485 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1486 int idx
= PER_BUFFER_IDX (offset
);
1488 PER_BUFFER_DEFAULT (offset
) = value
;
1490 /* If this variable is not always local in all buffers,
1491 set it in the buffers that don't nominally have a local value. */
1496 for (b
= all_buffers
; b
; b
= b
->next
)
1497 if (!PER_BUFFER_VALUE_P (b
, idx
))
1498 PER_BUFFER_VALUE (b
, offset
) = value
;
1503 return Fset (symbol
, value
);
1509 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1510 doc
: /* Set the default value of variable VAR to VALUE.
1511 VAR, the variable name, is literal (not evaluated);
1512 VALUE is an expression: it is evaluated and its value returned.
1513 The default value of a variable is seen in buffers
1514 that do not have their own values for the variable.
1516 More generally, you can use multiple variables and values, as in
1517 (setq-default VAR VALUE VAR VALUE...)
1518 This sets each VAR's default value to the corresponding VALUE.
1519 The VALUE for the Nth VAR can refer to the new default values
1521 usage: (setq-default [VAR VALUE]...) */)
1525 register Lisp_Object args_left
;
1526 register Lisp_Object val
, symbol
;
1527 struct gcpro gcpro1
;
1537 val
= Feval (Fcar (Fcdr (args_left
)));
1538 symbol
= XCAR (args_left
);
1539 Fset_default (symbol
, val
);
1540 args_left
= Fcdr (XCDR (args_left
));
1542 while (!NILP (args_left
));
1548 /* Lisp functions for creating and removing buffer-local variables. */
1553 union Lisp_Fwd
*fwd
;
1556 static struct Lisp_Buffer_Local_Value
*
1557 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1559 struct Lisp_Buffer_Local_Value
*blv
1560 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1561 Lisp_Object symbol
; XSETSYMBOL (symbol
, sym
);
1562 Lisp_Object tem
= Fcons (symbol
, (forwarded
1563 ? do_symval_forwarding (valcontents
.fwd
)
1564 : valcontents
.value
));
1565 /* Buffer_Local_Values cannot have as realval a buffer-local
1566 or keyboard-local forwarding. */
1567 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1568 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1569 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1571 blv
->frame_local
= 0;
1572 blv
->local_if_set
= 0;
1575 SET_BLV_FOUND (blv
, 0);
1579 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1580 1, 1, "vMake Variable Buffer Local: ",
1581 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1582 At any time, the value for the current buffer is in effect,
1583 unless the variable has never been set in this buffer,
1584 in which case the default value is in effect.
1585 Note that binding the variable with `let', or setting it while
1586 a `let'-style binding made in this buffer is in effect,
1587 does not make the variable buffer-local. Return VARIABLE.
1589 In most cases it is better to use `make-local-variable',
1590 which makes a variable local in just one buffer.
1592 The function `default-value' gets the default value and `set-default' sets it. */)
1594 register Lisp_Object variable
;
1596 struct Lisp_Symbol
*sym
;
1597 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1598 union Lisp_Val_Fwd valcontents
;
1601 CHECK_SYMBOL (variable
);
1602 sym
= XSYMBOL (variable
);
1605 switch (sym
->redirect
)
1607 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1608 case SYMBOL_PLAINVAL
:
1609 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1610 if (EQ (valcontents
.value
, Qunbound
))
1611 valcontents
.value
= Qnil
;
1613 case SYMBOL_LOCALIZED
:
1614 blv
= SYMBOL_BLV (sym
);
1615 if (blv
->frame_local
)
1616 error ("Symbol %s may not be buffer-local",
1617 SDATA (SYMBOL_NAME (variable
)));
1619 case SYMBOL_FORWARDED
:
1620 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1621 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1622 error ("Symbol %s may not be buffer-local",
1623 SDATA (SYMBOL_NAME (variable
)));
1624 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1631 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1635 blv
= make_blv (sym
, forwarded
, valcontents
);
1636 sym
->redirect
= SYMBOL_LOCALIZED
;
1637 SET_SYMBOL_BLV (sym
, blv
);
1640 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1641 if (let_shadows_global_binding_p (symbol
))
1642 message ("Making %s buffer-local while let-bound!",
1643 SDATA (SYMBOL_NAME (variable
)));
1647 blv
->local_if_set
= 1;
1651 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1652 1, 1, "vMake Local Variable: ",
1653 doc
: /* Make VARIABLE have a separate value in the current buffer.
1654 Other buffers will continue to share a common default value.
1655 \(The buffer-local value of VARIABLE starts out as the same value
1656 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1659 If the variable is already arranged to become local when set,
1660 this function causes a local value to exist for this buffer,
1661 just as setting the variable would do.
1663 This function returns VARIABLE, and therefore
1664 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1667 See also `make-variable-buffer-local'.
1669 Do not use `make-local-variable' to make a hook variable buffer-local.
1670 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1672 register Lisp_Object variable
;
1674 register Lisp_Object tem
;
1676 union Lisp_Val_Fwd valcontents
;
1677 struct Lisp_Symbol
*sym
;
1678 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1680 CHECK_SYMBOL (variable
);
1681 sym
= XSYMBOL (variable
);
1684 switch (sym
->redirect
)
1686 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1687 case SYMBOL_PLAINVAL
:
1688 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1689 case SYMBOL_LOCALIZED
:
1690 blv
= SYMBOL_BLV (sym
);
1691 if (blv
->frame_local
)
1692 error ("Symbol %s may not be buffer-local",
1693 SDATA (SYMBOL_NAME (variable
)));
1695 case SYMBOL_FORWARDED
:
1696 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1697 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1698 error ("Symbol %s may not be buffer-local",
1699 SDATA (SYMBOL_NAME (variable
)));
1705 error ("Symbol %s may not be buffer-local",
1706 SDATA (SYMBOL_NAME (variable
)));
1708 if (blv
? blv
->local_if_set
1709 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1711 tem
= Fboundp (variable
);
1712 /* Make sure the symbol has a local value in this particular buffer,
1713 by setting it to the same value it already has. */
1714 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1719 blv
= make_blv (sym
, forwarded
, valcontents
);
1720 sym
->redirect
= SYMBOL_LOCALIZED
;
1721 SET_SYMBOL_BLV (sym
, blv
);
1724 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1725 if (let_shadows_global_binding_p (symbol
))
1726 message ("Making %s local to %s while let-bound!",
1727 SDATA (SYMBOL_NAME (variable
)),
1728 SDATA (current_buffer
->name
));
1732 /* Make sure this buffer has its own value of symbol. */
1733 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1734 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1737 if (let_shadows_buffer_binding_p (sym
))
1738 message ("Making %s buffer-local while locally let-bound!",
1739 SDATA (SYMBOL_NAME (variable
)));
1741 /* Swap out any local binding for some other buffer, and make
1742 sure the current value is permanently recorded, if it's the
1744 find_symbol_value (variable
);
1746 current_buffer
->local_var_alist
1747 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1748 current_buffer
->local_var_alist
);
1750 /* Make sure symbol does not think it is set up for this buffer;
1751 force it to look once again for this buffer's value. */
1752 if (current_buffer
== XBUFFER (blv
->where
))
1754 /* blv->valcell = blv->defcell;
1755 * SET_BLV_FOUND (blv, 0); */
1759 /* If the symbol forwards into a C variable, then load the binding
1760 for this buffer now. If C code modifies the variable before we
1761 load the binding in, then that new value will clobber the default
1762 binding the next time we unload it. */
1764 swap_in_symval_forwarding (sym
, blv
);
1769 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1770 1, 1, "vKill Local Variable: ",
1771 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1772 From now on the default value will apply in this buffer. Return VARIABLE. */)
1774 register Lisp_Object variable
;
1776 register Lisp_Object tem
;
1777 struct Lisp_Buffer_Local_Value
*blv
;
1778 struct Lisp_Symbol
*sym
;
1780 CHECK_SYMBOL (variable
);
1781 sym
= XSYMBOL (variable
);
1784 switch (sym
->redirect
)
1786 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1787 case SYMBOL_PLAINVAL
: return variable
;
1788 case SYMBOL_FORWARDED
:
1790 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1791 if (BUFFER_OBJFWDP (valcontents
))
1793 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1794 int idx
= PER_BUFFER_IDX (offset
);
1798 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1799 PER_BUFFER_VALUE (current_buffer
, offset
)
1800 = PER_BUFFER_DEFAULT (offset
);
1805 case SYMBOL_LOCALIZED
:
1806 blv
= SYMBOL_BLV (sym
);
1807 if (blv
->frame_local
)
1813 /* Get rid of this buffer's alist element, if any. */
1814 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1815 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1817 current_buffer
->local_var_alist
1818 = Fdelq (tem
, current_buffer
->local_var_alist
);
1820 /* If the symbol is set up with the current buffer's binding
1821 loaded, recompute its value. We have to do it now, or else
1822 forwarded objects won't work right. */
1824 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1825 if (EQ (buf
, blv
->where
))
1828 /* blv->valcell = blv->defcell;
1829 * SET_BLV_FOUND (blv, 0); */
1831 find_symbol_value (variable
);
1838 /* Lisp functions for creating and removing buffer-local variables. */
1840 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1841 when/if this is removed. */
1843 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1844 1, 1, "vMake Variable Frame Local: ",
1845 doc
: /* Enable VARIABLE to have frame-local bindings.
1846 This does not create any frame-local bindings for VARIABLE,
1847 it just makes them possible.
1849 A frame-local binding is actually a frame parameter value.
1850 If a frame F has a value for the frame parameter named VARIABLE,
1851 that also acts as a frame-local binding for VARIABLE in F--
1852 provided this function has been called to enable VARIABLE
1853 to have frame-local bindings at all.
1855 The only way to create a frame-local binding for VARIABLE in a frame
1856 is to set the VARIABLE frame parameter of that frame. See
1857 `modify-frame-parameters' for how to set frame parameters.
1859 Note that since Emacs 23.1, variables cannot be both buffer-local and
1860 frame-local any more (buffer-local bindings used to take precedence over
1861 frame-local bindings). */)
1863 register Lisp_Object variable
;
1866 union Lisp_Val_Fwd valcontents
;
1867 struct Lisp_Symbol
*sym
;
1868 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1870 CHECK_SYMBOL (variable
);
1871 sym
= XSYMBOL (variable
);
1874 switch (sym
->redirect
)
1876 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1877 case SYMBOL_PLAINVAL
:
1878 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1879 if (EQ (valcontents
.value
, Qunbound
))
1880 valcontents
.value
= Qnil
;
1882 case SYMBOL_LOCALIZED
:
1883 if (SYMBOL_BLV (sym
)->frame_local
)
1886 error ("Symbol %s may not be frame-local",
1887 SDATA (SYMBOL_NAME (variable
)));
1888 case SYMBOL_FORWARDED
:
1889 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1890 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1891 error ("Symbol %s may not be frame-local",
1892 SDATA (SYMBOL_NAME (variable
)));
1898 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1900 blv
= make_blv (sym
, forwarded
, valcontents
);
1901 blv
->frame_local
= 1;
1902 sym
->redirect
= SYMBOL_LOCALIZED
;
1903 SET_SYMBOL_BLV (sym
, blv
);
1906 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1907 if (let_shadows_global_binding_p (symbol
))
1908 message ("Making %s frame-local while let-bound!",
1909 SDATA (SYMBOL_NAME (variable
)));
1914 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1916 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1917 BUFFER defaults to the current buffer. */)
1919 register Lisp_Object variable
, buffer
;
1921 register struct buffer
*buf
;
1922 struct Lisp_Symbol
*sym
;
1925 buf
= current_buffer
;
1928 CHECK_BUFFER (buffer
);
1929 buf
= XBUFFER (buffer
);
1932 CHECK_SYMBOL (variable
);
1933 sym
= XSYMBOL (variable
);
1936 switch (sym
->redirect
)
1938 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1939 case SYMBOL_PLAINVAL
: return Qnil
;
1940 case SYMBOL_LOCALIZED
:
1942 Lisp_Object tail
, elt
, tmp
;
1943 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1944 XSETBUFFER (tmp
, buf
);
1946 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1949 if (EQ (variable
, XCAR (elt
)))
1951 eassert (!blv
->frame_local
);
1952 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1956 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1959 case SYMBOL_FORWARDED
:
1961 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1962 if (BUFFER_OBJFWDP (valcontents
))
1964 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1965 int idx
= PER_BUFFER_IDX (offset
);
1966 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1975 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1977 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1978 More precisely, this means that setting the variable \(with `set' or`setq'),
1979 while it does not have a `let'-style binding that was made in BUFFER,
1980 will produce a buffer local binding. See Info node
1981 `(elisp)Creating Buffer-Local'.
1982 BUFFER defaults to the current buffer. */)
1984 register Lisp_Object variable
, buffer
;
1986 struct Lisp_Symbol
*sym
;
1988 CHECK_SYMBOL (variable
);
1989 sym
= XSYMBOL (variable
);
1992 switch (sym
->redirect
)
1994 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1995 case SYMBOL_PLAINVAL
: return Qnil
;
1996 case SYMBOL_LOCALIZED
:
1998 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1999 if (blv
->local_if_set
)
2001 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2002 return Flocal_variable_p (variable
, buffer
);
2004 case SYMBOL_FORWARDED
:
2005 /* All BUFFER_OBJFWD slots become local if they are set. */
2006 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2011 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2013 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2014 If the current binding is buffer-local, the value is the current buffer.
2015 If the current binding is frame-local, the value is the selected frame.
2016 If the current binding is global (the default), the value is nil. */)
2018 register Lisp_Object variable
;
2020 struct Lisp_Symbol
*sym
;
2022 CHECK_SYMBOL (variable
);
2023 sym
= XSYMBOL (variable
);
2025 /* Make sure the current binding is actually swapped in. */
2026 find_symbol_value (variable
);
2029 switch (sym
->redirect
)
2031 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2032 case SYMBOL_PLAINVAL
: return Qnil
;
2033 case SYMBOL_FORWARDED
:
2035 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2036 if (KBOARD_OBJFWDP (valcontents
))
2037 return Fframe_terminal (Fselected_frame ());
2038 else if (!BUFFER_OBJFWDP (valcontents
))
2042 case SYMBOL_LOCALIZED
:
2043 /* For a local variable, record both the symbol and which
2044 buffer's or frame's value we are saving. */
2045 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2046 return Fcurrent_buffer ();
2047 else if (sym
->redirect
== SYMBOL_LOCALIZED
2048 && BLV_FOUND (SYMBOL_BLV (sym
)))
2049 return SYMBOL_BLV (sym
)->where
;
2056 /* This code is disabled now that we use the selected frame to return
2057 keyboard-local-values. */
2059 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2061 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2062 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2063 If SYMBOL is not a terminal-local variable, then return its normal
2064 value, like `symbol-value'.
2066 TERMINAL may be a terminal object, a frame, or nil (meaning the
2067 selected frame's terminal device). */)
2070 Lisp_Object terminal
;
2073 struct terminal
*t
= get_terminal (terminal
, 1);
2074 push_kboard (t
->kboard
);
2075 result
= Fsymbol_value (symbol
);
2080 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2081 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2082 If VARIABLE is not a terminal-local variable, then set its normal
2083 binding, like `set'.
2085 TERMINAL may be a terminal object, a frame, or nil (meaning the
2086 selected frame's terminal device). */)
2087 (symbol
, terminal
, value
)
2089 Lisp_Object terminal
;
2093 struct terminal
*t
= get_terminal (terminal
, 1);
2094 push_kboard (d
->kboard
);
2095 result
= Fset (symbol
, value
);
2101 /* Find the function at the end of a chain of symbol function indirections. */
2103 /* If OBJECT is a symbol, find the end of its function chain and
2104 return the value found there. If OBJECT is not a symbol, just
2105 return it. If there is a cycle in the function chain, signal a
2106 cyclic-function-indirection error.
2108 This is like Findirect_function, except that it doesn't signal an
2109 error if the chain ends up unbound. */
2111 indirect_function (object
)
2112 register Lisp_Object object
;
2114 Lisp_Object tortoise
, hare
;
2116 hare
= tortoise
= object
;
2120 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2122 hare
= XSYMBOL (hare
)->function
;
2123 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2125 hare
= XSYMBOL (hare
)->function
;
2127 tortoise
= XSYMBOL (tortoise
)->function
;
2129 if (EQ (hare
, tortoise
))
2130 xsignal1 (Qcyclic_function_indirection
, object
);
2136 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2137 doc
: /* Return the function at the end of OBJECT's function chain.
2138 If OBJECT is not a symbol, just return it. Otherwise, follow all
2139 function indirections to find the final function binding and return it.
2140 If the final symbol in the chain is unbound, signal a void-function error.
2141 Optional arg NOERROR non-nil means to return nil instead of signalling.
2142 Signal a cyclic-function-indirection error if there is a loop in the
2143 function chain of symbols. */)
2145 register Lisp_Object object
;
2146 Lisp_Object noerror
;
2150 /* Optimize for no indirection. */
2152 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2153 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2154 result
= indirect_function (result
);
2155 if (!EQ (result
, Qunbound
))
2159 xsignal1 (Qvoid_function
, object
);
2164 /* Extract and set vector and string elements */
2166 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2167 doc
: /* Return the element of ARRAY at index IDX.
2168 ARRAY may be a vector, a string, a char-table, a bool-vector,
2169 or a byte-code object. IDX starts at 0. */)
2171 register Lisp_Object array
;
2174 register int idxval
;
2177 idxval
= XINT (idx
);
2178 if (STRINGP (array
))
2182 if (idxval
< 0 || idxval
>= SCHARS (array
))
2183 args_out_of_range (array
, idx
);
2184 if (! STRING_MULTIBYTE (array
))
2185 return make_number ((unsigned char) SREF (array
, idxval
));
2186 idxval_byte
= string_char_to_byte (array
, idxval
);
2188 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2189 return make_number (c
);
2191 else if (BOOL_VECTOR_P (array
))
2195 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2196 args_out_of_range (array
, idx
);
2198 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2199 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2201 else if (CHAR_TABLE_P (array
))
2203 CHECK_CHARACTER (idx
);
2204 return CHAR_TABLE_REF (array
, idxval
);
2209 if (VECTORP (array
))
2210 size
= XVECTOR (array
)->size
;
2211 else if (COMPILEDP (array
))
2212 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2214 wrong_type_argument (Qarrayp
, array
);
2216 if (idxval
< 0 || idxval
>= size
)
2217 args_out_of_range (array
, idx
);
2218 return XVECTOR (array
)->contents
[idxval
];
2222 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2223 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2224 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2225 bool-vector. IDX starts at 0. */)
2226 (array
, idx
, newelt
)
2227 register Lisp_Object array
;
2228 Lisp_Object idx
, newelt
;
2230 register int idxval
;
2233 idxval
= XINT (idx
);
2234 CHECK_ARRAY (array
, Qarrayp
);
2235 CHECK_IMPURE (array
);
2237 if (VECTORP (array
))
2239 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2240 args_out_of_range (array
, idx
);
2241 XVECTOR (array
)->contents
[idxval
] = newelt
;
2243 else if (BOOL_VECTOR_P (array
))
2247 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2248 args_out_of_range (array
, idx
);
2250 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2252 if (! NILP (newelt
))
2253 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2255 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2256 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2258 else if (CHAR_TABLE_P (array
))
2260 CHECK_CHARACTER (idx
);
2261 CHAR_TABLE_SET (array
, idxval
, newelt
);
2263 else if (STRING_MULTIBYTE (array
))
2265 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2266 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2268 if (idxval
< 0 || idxval
>= SCHARS (array
))
2269 args_out_of_range (array
, idx
);
2270 CHECK_CHARACTER (newelt
);
2272 nbytes
= SBYTES (array
);
2274 idxval_byte
= string_char_to_byte (array
, idxval
);
2275 p1
= SDATA (array
) + idxval_byte
;
2276 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2277 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2278 if (prev_bytes
!= new_bytes
)
2280 /* We must relocate the string data. */
2281 int nchars
= SCHARS (array
);
2285 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2286 bcopy (SDATA (array
), str
, nbytes
);
2287 allocate_string_data (XSTRING (array
), nchars
,
2288 nbytes
+ new_bytes
- prev_bytes
);
2289 bcopy (str
, SDATA (array
), idxval_byte
);
2290 p1
= SDATA (array
) + idxval_byte
;
2291 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2292 nbytes
- (idxval_byte
+ prev_bytes
));
2294 clear_string_char_byte_cache ();
2301 if (idxval
< 0 || idxval
>= SCHARS (array
))
2302 args_out_of_range (array
, idx
);
2303 CHECK_NUMBER (newelt
);
2305 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2309 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2310 if (SREF (array
, i
) >= 0x80)
2311 args_out_of_range (array
, newelt
);
2312 /* ARRAY is an ASCII string. Convert it to a multibyte
2313 string, and try `aset' again. */
2314 STRING_SET_MULTIBYTE (array
);
2315 return Faset (array
, idx
, newelt
);
2317 SSET (array
, idxval
, XINT (newelt
));
2323 /* Arithmetic functions */
2325 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2328 arithcompare (num1
, num2
, comparison
)
2329 Lisp_Object num1
, num2
;
2330 enum comparison comparison
;
2332 double f1
= 0, f2
= 0;
2335 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2336 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2338 if (FLOATP (num1
) || FLOATP (num2
))
2341 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2342 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2348 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2353 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2358 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2363 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2368 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2373 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2382 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2383 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2385 register Lisp_Object num1
, num2
;
2387 return arithcompare (num1
, num2
, equal
);
2390 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2391 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2393 register Lisp_Object num1
, num2
;
2395 return arithcompare (num1
, num2
, less
);
2398 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2399 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2401 register Lisp_Object num1
, num2
;
2403 return arithcompare (num1
, num2
, grtr
);
2406 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2407 doc
: /* Return t if first arg is less than or equal to second arg.
2408 Both must be numbers or markers. */)
2410 register Lisp_Object num1
, num2
;
2412 return arithcompare (num1
, num2
, less_or_equal
);
2415 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2416 doc
: /* Return t if first arg is greater than or equal to second arg.
2417 Both must be numbers or markers. */)
2419 register Lisp_Object num1
, num2
;
2421 return arithcompare (num1
, num2
, grtr_or_equal
);
2424 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2425 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2427 register Lisp_Object num1
, num2
;
2429 return arithcompare (num1
, num2
, notequal
);
2432 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2433 doc
: /* Return t if NUMBER is zero. */)
2435 register Lisp_Object number
;
2437 CHECK_NUMBER_OR_FLOAT (number
);
2439 if (FLOATP (number
))
2441 if (XFLOAT_DATA (number
) == 0.0)
2451 /* Convert between long values and pairs of Lisp integers.
2452 Note that long_to_cons returns a single Lisp integer
2453 when the value fits in one. */
2459 unsigned long top
= i
>> 16;
2460 unsigned int bot
= i
& 0xFFFF;
2462 return make_number (bot
);
2463 if (top
== (unsigned long)-1 >> 16)
2464 return Fcons (make_number (-1), make_number (bot
));
2465 return Fcons (make_number (top
), make_number (bot
));
2472 Lisp_Object top
, bot
;
2479 return ((XINT (top
) << 16) | XINT (bot
));
2482 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2483 doc
: /* Return the decimal representation of NUMBER as a string.
2484 Uses a minus sign if negative.
2485 NUMBER may be an integer or a floating point number. */)
2489 char buffer
[VALBITS
];
2491 CHECK_NUMBER_OR_FLOAT (number
);
2493 if (FLOATP (number
))
2495 char pigbuf
[350]; /* see comments in float_to_string */
2497 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2498 return build_string (pigbuf
);
2501 if (sizeof (int) == sizeof (EMACS_INT
))
2502 sprintf (buffer
, "%d", (int) XINT (number
));
2503 else if (sizeof (long) == sizeof (EMACS_INT
))
2504 sprintf (buffer
, "%ld", (long) XINT (number
));
2507 return build_string (buffer
);
2511 digit_to_number (character
, base
)
2512 int character
, base
;
2516 if (character
>= '0' && character
<= '9')
2517 digit
= character
- '0';
2518 else if (character
>= 'a' && character
<= 'z')
2519 digit
= character
- 'a' + 10;
2520 else if (character
>= 'A' && character
<= 'Z')
2521 digit
= character
- 'A' + 10;
2531 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2532 doc
: /* Parse STRING as a decimal number and return the number.
2533 This parses both integers and floating point numbers.
2534 It ignores leading spaces and tabs, and all trailing chars.
2536 If BASE, interpret STRING as a number in that base. If BASE isn't
2537 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2538 If the base used is not 10, STRING is always parsed as integer. */)
2540 register Lisp_Object string
, base
;
2542 register unsigned char *p
;
2547 CHECK_STRING (string
);
2553 CHECK_NUMBER (base
);
2555 if (b
< 2 || b
> 16)
2556 xsignal1 (Qargs_out_of_range
, base
);
2559 /* Skip any whitespace at the front of the number. Some versions of
2560 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2562 while (*p
== ' ' || *p
== '\t')
2573 if (isfloat_string (p
, 1) && b
== 10)
2574 val
= make_float (sign
* atof (p
));
2581 int digit
= digit_to_number (*p
++, b
);
2587 val
= make_fixnum_or_float (sign
* v
);
2607 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2608 int, Lisp_Object
*));
2609 extern Lisp_Object
fmod_float ();
2612 arith_driver (code
, nargs
, args
)
2615 register Lisp_Object
*args
;
2617 register Lisp_Object val
;
2618 register int argnum
;
2619 register EMACS_INT accum
= 0;
2620 register EMACS_INT next
;
2622 switch (SWITCH_ENUM_CAST (code
))
2640 for (argnum
= 0; argnum
< nargs
; argnum
++)
2642 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2644 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2647 return float_arith_driver ((double) accum
, argnum
, code
,
2650 next
= XINT (args
[argnum
]);
2651 switch (SWITCH_ENUM_CAST (code
))
2657 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2668 xsignal0 (Qarith_error
);
2682 if (!argnum
|| next
> accum
)
2686 if (!argnum
|| next
< accum
)
2692 XSETINT (val
, accum
);
2697 #define isnan(x) ((x) != (x))
2700 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2702 register int argnum
;
2705 register Lisp_Object
*args
;
2707 register Lisp_Object val
;
2710 for (; argnum
< nargs
; argnum
++)
2712 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2713 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2717 next
= XFLOAT_DATA (val
);
2721 args
[argnum
] = val
; /* runs into a compiler bug. */
2722 next
= XINT (args
[argnum
]);
2724 switch (SWITCH_ENUM_CAST (code
))
2730 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2740 if (! IEEE_FLOATING_POINT
&& next
== 0)
2741 xsignal0 (Qarith_error
);
2748 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2750 if (!argnum
|| isnan (next
) || next
> accum
)
2754 if (!argnum
|| isnan (next
) || next
< accum
)
2760 return make_float (accum
);
2764 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2765 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2766 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2771 return arith_driver (Aadd
, nargs
, args
);
2774 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2775 doc
: /* Negate number or subtract numbers or markers and return the result.
2776 With one arg, negates it. With more than one arg,
2777 subtracts all but the first from the first.
2778 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2783 return arith_driver (Asub
, nargs
, args
);
2786 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2787 doc
: /* Return product of any number of arguments, which are numbers or markers.
2788 usage: (* &rest NUMBERS-OR-MARKERS) */)
2793 return arith_driver (Amult
, nargs
, args
);
2796 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2797 doc
: /* Return first argument divided by all the remaining arguments.
2798 The arguments must be numbers or markers.
2799 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2805 for (argnum
= 2; argnum
< nargs
; argnum
++)
2806 if (FLOATP (args
[argnum
]))
2807 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2808 return arith_driver (Adiv
, nargs
, args
);
2811 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2812 doc
: /* Return remainder of X divided by Y.
2813 Both must be integers or markers. */)
2815 register Lisp_Object x
, y
;
2819 CHECK_NUMBER_COERCE_MARKER (x
);
2820 CHECK_NUMBER_COERCE_MARKER (y
);
2822 if (XFASTINT (y
) == 0)
2823 xsignal0 (Qarith_error
);
2825 XSETINT (val
, XINT (x
) % XINT (y
));
2839 /* If the magnitude of the result exceeds that of the divisor, or
2840 the sign of the result does not agree with that of the dividend,
2841 iterate with the reduced value. This does not yield a
2842 particularly accurate result, but at least it will be in the
2843 range promised by fmod. */
2845 r
-= f2
* floor (r
/ f2
);
2846 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2850 #endif /* ! HAVE_FMOD */
2852 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2853 doc
: /* Return X modulo Y.
2854 The result falls between zero (inclusive) and Y (exclusive).
2855 Both X and Y must be numbers or markers. */)
2857 register Lisp_Object x
, y
;
2862 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2863 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2865 if (FLOATP (x
) || FLOATP (y
))
2866 return fmod_float (x
, y
);
2872 xsignal0 (Qarith_error
);
2876 /* If the "remainder" comes out with the wrong sign, fix it. */
2877 if (i2
< 0 ? i1
> 0 : i1
< 0)
2884 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2885 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2886 The value is always a number; markers are converted to numbers.
2887 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2892 return arith_driver (Amax
, nargs
, args
);
2895 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2896 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2897 The value is always a number; markers are converted to numbers.
2898 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2903 return arith_driver (Amin
, nargs
, args
);
2906 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2907 doc
: /* Return bitwise-and of all the arguments.
2908 Arguments may be integers, or markers converted to integers.
2909 usage: (logand &rest INTS-OR-MARKERS) */)
2914 return arith_driver (Alogand
, nargs
, args
);
2917 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2918 doc
: /* Return bitwise-or of all the arguments.
2919 Arguments may be integers, or markers converted to integers.
2920 usage: (logior &rest INTS-OR-MARKERS) */)
2925 return arith_driver (Alogior
, nargs
, args
);
2928 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2929 doc
: /* Return bitwise-exclusive-or of all the arguments.
2930 Arguments may be integers, or markers converted to integers.
2931 usage: (logxor &rest INTS-OR-MARKERS) */)
2936 return arith_driver (Alogxor
, nargs
, args
);
2939 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2940 doc
: /* Return VALUE with its bits shifted left by COUNT.
2941 If COUNT is negative, shifting is actually to the right.
2942 In this case, the sign bit is duplicated. */)
2944 register Lisp_Object value
, count
;
2946 register Lisp_Object val
;
2948 CHECK_NUMBER (value
);
2949 CHECK_NUMBER (count
);
2951 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2953 else if (XINT (count
) > 0)
2954 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2955 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2956 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2958 XSETINT (val
, XINT (value
) >> -XINT (count
));
2962 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2963 doc
: /* Return VALUE with its bits shifted left by COUNT.
2964 If COUNT is negative, shifting is actually to the right.
2965 In this case, zeros are shifted in on the left. */)
2967 register Lisp_Object value
, count
;
2969 register Lisp_Object val
;
2971 CHECK_NUMBER (value
);
2972 CHECK_NUMBER (count
);
2974 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2976 else if (XINT (count
) > 0)
2977 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2978 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2981 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2985 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2986 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2987 Markers are converted to integers. */)
2989 register Lisp_Object number
;
2991 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2993 if (FLOATP (number
))
2994 return (make_float (1.0 + XFLOAT_DATA (number
)));
2996 XSETINT (number
, XINT (number
) + 1);
3000 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3001 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3002 Markers are converted to integers. */)
3004 register Lisp_Object number
;
3006 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3008 if (FLOATP (number
))
3009 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3011 XSETINT (number
, XINT (number
) - 1);
3015 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3016 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3018 register Lisp_Object number
;
3020 CHECK_NUMBER (number
);
3021 XSETINT (number
, ~XINT (number
));
3025 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3026 doc
: /* Return the byteorder for the machine.
3027 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3028 lowercase l) for small endian machines. */)
3031 unsigned i
= 0x04030201;
3032 int order
= *(char *)&i
== 1 ? 108 : 66;
3034 return make_number (order
);
3042 Lisp_Object error_tail
, arith_tail
;
3044 Qquote
= intern_c_string ("quote");
3045 Qlambda
= intern_c_string ("lambda");
3046 Qsubr
= intern_c_string ("subr");
3047 Qerror_conditions
= intern_c_string ("error-conditions");
3048 Qerror_message
= intern_c_string ("error-message");
3049 Qtop_level
= intern_c_string ("top-level");
3051 Qerror
= intern_c_string ("error");
3052 Qquit
= intern_c_string ("quit");
3053 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3054 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3055 Qvoid_function
= intern_c_string ("void-function");
3056 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3057 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3058 Qvoid_variable
= intern_c_string ("void-variable");
3059 Qsetting_constant
= intern_c_string ("setting-constant");
3060 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3062 Qinvalid_function
= intern_c_string ("invalid-function");
3063 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3064 Qno_catch
= intern_c_string ("no-catch");
3065 Qend_of_file
= intern_c_string ("end-of-file");
3066 Qarith_error
= intern_c_string ("arith-error");
3067 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3068 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3069 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3070 Qtext_read_only
= intern_c_string ("text-read-only");
3071 Qmark_inactive
= intern_c_string ("mark-inactive");
3073 Qlistp
= intern_c_string ("listp");
3074 Qconsp
= intern_c_string ("consp");
3075 Qsymbolp
= intern_c_string ("symbolp");
3076 Qkeywordp
= intern_c_string ("keywordp");
3077 Qintegerp
= intern_c_string ("integerp");
3078 Qnatnump
= intern_c_string ("natnump");
3079 Qwholenump
= intern_c_string ("wholenump");
3080 Qstringp
= intern_c_string ("stringp");
3081 Qarrayp
= intern_c_string ("arrayp");
3082 Qsequencep
= intern_c_string ("sequencep");
3083 Qbufferp
= intern_c_string ("bufferp");
3084 Qvectorp
= intern_c_string ("vectorp");
3085 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3086 Qmarkerp
= intern_c_string ("markerp");
3087 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3088 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3089 Qboundp
= intern_c_string ("boundp");
3090 Qfboundp
= intern_c_string ("fboundp");
3092 Qfloatp
= intern_c_string ("floatp");
3093 Qnumberp
= intern_c_string ("numberp");
3094 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3096 Qchar_table_p
= intern_c_string ("char-table-p");
3097 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3099 Qsubrp
= intern_c_string ("subrp");
3100 Qunevalled
= intern_c_string ("unevalled");
3101 Qmany
= intern_c_string ("many");
3103 Qcdr
= intern_c_string ("cdr");
3105 /* Handle automatic advice activation */
3106 Qad_advice_info
= intern_c_string ("ad-advice-info");
3107 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3109 error_tail
= pure_cons (Qerror
, Qnil
);
3111 /* ERROR is used as a signaler for random errors for which nothing else is right */
3113 Fput (Qerror
, Qerror_conditions
,
3115 Fput (Qerror
, Qerror_message
,
3116 make_pure_c_string ("error"));
3118 Fput (Qquit
, Qerror_conditions
,
3119 pure_cons (Qquit
, Qnil
));
3120 Fput (Qquit
, Qerror_message
,
3121 make_pure_c_string ("Quit"));
3123 Fput (Qwrong_type_argument
, Qerror_conditions
,
3124 pure_cons (Qwrong_type_argument
, error_tail
));
3125 Fput (Qwrong_type_argument
, Qerror_message
,
3126 make_pure_c_string ("Wrong type argument"));
3128 Fput (Qargs_out_of_range
, Qerror_conditions
,
3129 pure_cons (Qargs_out_of_range
, error_tail
));
3130 Fput (Qargs_out_of_range
, Qerror_message
,
3131 make_pure_c_string ("Args out of range"));
3133 Fput (Qvoid_function
, Qerror_conditions
,
3134 pure_cons (Qvoid_function
, error_tail
));
3135 Fput (Qvoid_function
, Qerror_message
,
3136 make_pure_c_string ("Symbol's function definition is void"));
3138 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3139 pure_cons (Qcyclic_function_indirection
, error_tail
));
3140 Fput (Qcyclic_function_indirection
, Qerror_message
,
3141 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3143 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3144 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3145 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3146 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3148 Qcircular_list
= intern_c_string ("circular-list");
3149 staticpro (&Qcircular_list
);
3150 Fput (Qcircular_list
, Qerror_conditions
,
3151 pure_cons (Qcircular_list
, error_tail
));
3152 Fput (Qcircular_list
, Qerror_message
,
3153 make_pure_c_string ("List contains a loop"));
3155 Fput (Qvoid_variable
, Qerror_conditions
,
3156 pure_cons (Qvoid_variable
, error_tail
));
3157 Fput (Qvoid_variable
, Qerror_message
,
3158 make_pure_c_string ("Symbol's value as variable is void"));
3160 Fput (Qsetting_constant
, Qerror_conditions
,
3161 pure_cons (Qsetting_constant
, error_tail
));
3162 Fput (Qsetting_constant
, Qerror_message
,
3163 make_pure_c_string ("Attempt to set a constant symbol"));
3165 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3166 pure_cons (Qinvalid_read_syntax
, error_tail
));
3167 Fput (Qinvalid_read_syntax
, Qerror_message
,
3168 make_pure_c_string ("Invalid read syntax"));
3170 Fput (Qinvalid_function
, Qerror_conditions
,
3171 pure_cons (Qinvalid_function
, error_tail
));
3172 Fput (Qinvalid_function
, Qerror_message
,
3173 make_pure_c_string ("Invalid function"));
3175 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3176 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3177 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3178 make_pure_c_string ("Wrong number of arguments"));
3180 Fput (Qno_catch
, Qerror_conditions
,
3181 pure_cons (Qno_catch
, error_tail
));
3182 Fput (Qno_catch
, Qerror_message
,
3183 make_pure_c_string ("No catch for tag"));
3185 Fput (Qend_of_file
, Qerror_conditions
,
3186 pure_cons (Qend_of_file
, error_tail
));
3187 Fput (Qend_of_file
, Qerror_message
,
3188 make_pure_c_string ("End of file during parsing"));
3190 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3191 Fput (Qarith_error
, Qerror_conditions
,
3193 Fput (Qarith_error
, Qerror_message
,
3194 make_pure_c_string ("Arithmetic error"));
3196 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3197 pure_cons (Qbeginning_of_buffer
, error_tail
));
3198 Fput (Qbeginning_of_buffer
, Qerror_message
,
3199 make_pure_c_string ("Beginning of buffer"));
3201 Fput (Qend_of_buffer
, Qerror_conditions
,
3202 pure_cons (Qend_of_buffer
, error_tail
));
3203 Fput (Qend_of_buffer
, Qerror_message
,
3204 make_pure_c_string ("End of buffer"));
3206 Fput (Qbuffer_read_only
, Qerror_conditions
,
3207 pure_cons (Qbuffer_read_only
, error_tail
));
3208 Fput (Qbuffer_read_only
, Qerror_message
,
3209 make_pure_c_string ("Buffer is read-only"));
3211 Fput (Qtext_read_only
, Qerror_conditions
,
3212 pure_cons (Qtext_read_only
, error_tail
));
3213 Fput (Qtext_read_only
, Qerror_message
,
3214 make_pure_c_string ("Text is read-only"));
3216 Qrange_error
= intern_c_string ("range-error");
3217 Qdomain_error
= intern_c_string ("domain-error");
3218 Qsingularity_error
= intern_c_string ("singularity-error");
3219 Qoverflow_error
= intern_c_string ("overflow-error");
3220 Qunderflow_error
= intern_c_string ("underflow-error");
3222 Fput (Qdomain_error
, Qerror_conditions
,
3223 pure_cons (Qdomain_error
, arith_tail
));
3224 Fput (Qdomain_error
, Qerror_message
,
3225 make_pure_c_string ("Arithmetic domain error"));
3227 Fput (Qrange_error
, Qerror_conditions
,
3228 pure_cons (Qrange_error
, arith_tail
));
3229 Fput (Qrange_error
, Qerror_message
,
3230 make_pure_c_string ("Arithmetic range error"));
3232 Fput (Qsingularity_error
, Qerror_conditions
,
3233 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3234 Fput (Qsingularity_error
, Qerror_message
,
3235 make_pure_c_string ("Arithmetic singularity error"));
3237 Fput (Qoverflow_error
, Qerror_conditions
,
3238 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3239 Fput (Qoverflow_error
, Qerror_message
,
3240 make_pure_c_string ("Arithmetic overflow error"));
3242 Fput (Qunderflow_error
, Qerror_conditions
,
3243 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3244 Fput (Qunderflow_error
, Qerror_message
,
3245 make_pure_c_string ("Arithmetic underflow error"));
3247 staticpro (&Qrange_error
);
3248 staticpro (&Qdomain_error
);
3249 staticpro (&Qsingularity_error
);
3250 staticpro (&Qoverflow_error
);
3251 staticpro (&Qunderflow_error
);
3255 staticpro (&Qquote
);
3256 staticpro (&Qlambda
);
3258 staticpro (&Qunbound
);
3259 staticpro (&Qerror_conditions
);
3260 staticpro (&Qerror_message
);
3261 staticpro (&Qtop_level
);
3263 staticpro (&Qerror
);
3265 staticpro (&Qwrong_type_argument
);
3266 staticpro (&Qargs_out_of_range
);
3267 staticpro (&Qvoid_function
);
3268 staticpro (&Qcyclic_function_indirection
);
3269 staticpro (&Qcyclic_variable_indirection
);
3270 staticpro (&Qvoid_variable
);
3271 staticpro (&Qsetting_constant
);
3272 staticpro (&Qinvalid_read_syntax
);
3273 staticpro (&Qwrong_number_of_arguments
);
3274 staticpro (&Qinvalid_function
);
3275 staticpro (&Qno_catch
);
3276 staticpro (&Qend_of_file
);
3277 staticpro (&Qarith_error
);
3278 staticpro (&Qbeginning_of_buffer
);
3279 staticpro (&Qend_of_buffer
);
3280 staticpro (&Qbuffer_read_only
);
3281 staticpro (&Qtext_read_only
);
3282 staticpro (&Qmark_inactive
);
3284 staticpro (&Qlistp
);
3285 staticpro (&Qconsp
);
3286 staticpro (&Qsymbolp
);
3287 staticpro (&Qkeywordp
);
3288 staticpro (&Qintegerp
);
3289 staticpro (&Qnatnump
);
3290 staticpro (&Qwholenump
);
3291 staticpro (&Qstringp
);
3292 staticpro (&Qarrayp
);
3293 staticpro (&Qsequencep
);
3294 staticpro (&Qbufferp
);
3295 staticpro (&Qvectorp
);
3296 staticpro (&Qchar_or_string_p
);
3297 staticpro (&Qmarkerp
);
3298 staticpro (&Qbuffer_or_string_p
);
3299 staticpro (&Qinteger_or_marker_p
);
3300 staticpro (&Qfloatp
);
3301 staticpro (&Qnumberp
);
3302 staticpro (&Qnumber_or_marker_p
);
3303 staticpro (&Qchar_table_p
);
3304 staticpro (&Qvector_or_char_table_p
);
3305 staticpro (&Qsubrp
);
3307 staticpro (&Qunevalled
);
3309 staticpro (&Qboundp
);
3310 staticpro (&Qfboundp
);
3312 staticpro (&Qad_advice_info
);
3313 staticpro (&Qad_activate_internal
);
3315 /* Types that type-of returns. */
3316 Qinteger
= intern_c_string ("integer");
3317 Qsymbol
= intern_c_string ("symbol");
3318 Qstring
= intern_c_string ("string");
3319 Qcons
= intern_c_string ("cons");
3320 Qmarker
= intern_c_string ("marker");
3321 Qoverlay
= intern_c_string ("overlay");
3322 Qfloat
= intern_c_string ("float");
3323 Qwindow_configuration
= intern_c_string ("window-configuration");
3324 Qprocess
= intern_c_string ("process");
3325 Qwindow
= intern_c_string ("window");
3326 /* Qsubr = intern_c_string ("subr"); */
3327 Qcompiled_function
= intern_c_string ("compiled-function");
3328 Qbuffer
= intern_c_string ("buffer");
3329 Qframe
= intern_c_string ("frame");
3330 Qvector
= intern_c_string ("vector");
3331 Qchar_table
= intern_c_string ("char-table");
3332 Qbool_vector
= intern_c_string ("bool-vector");
3333 Qhash_table
= intern_c_string ("hash-table");
3335 DEFSYM (Qfont_spec
, "font-spec");
3336 DEFSYM (Qfont_entity
, "font-entity");
3337 DEFSYM (Qfont_object
, "font-object");
3339 DEFSYM (Qinteractive_form
, "interactive-form");
3341 staticpro (&Qinteger
);
3342 staticpro (&Qsymbol
);
3343 staticpro (&Qstring
);
3345 staticpro (&Qmarker
);
3346 staticpro (&Qoverlay
);
3347 staticpro (&Qfloat
);
3348 staticpro (&Qwindow_configuration
);
3349 staticpro (&Qprocess
);
3350 staticpro (&Qwindow
);
3351 /* staticpro (&Qsubr); */
3352 staticpro (&Qcompiled_function
);
3353 staticpro (&Qbuffer
);
3354 staticpro (&Qframe
);
3355 staticpro (&Qvector
);
3356 staticpro (&Qchar_table
);
3357 staticpro (&Qbool_vector
);
3358 staticpro (&Qhash_table
);
3360 defsubr (&Sindirect_variable
);
3361 defsubr (&Sinteractive_form
);
3364 defsubr (&Stype_of
);
3369 defsubr (&Sintegerp
);
3370 defsubr (&Sinteger_or_marker_p
);
3371 defsubr (&Snumberp
);
3372 defsubr (&Snumber_or_marker_p
);
3374 defsubr (&Snatnump
);
3375 defsubr (&Ssymbolp
);
3376 defsubr (&Skeywordp
);
3377 defsubr (&Sstringp
);
3378 defsubr (&Smultibyte_string_p
);
3379 defsubr (&Svectorp
);
3380 defsubr (&Schar_table_p
);
3381 defsubr (&Svector_or_char_table_p
);
3382 defsubr (&Sbool_vector_p
);
3384 defsubr (&Ssequencep
);
3385 defsubr (&Sbufferp
);
3386 defsubr (&Smarkerp
);
3388 defsubr (&Sbyte_code_function_p
);
3389 defsubr (&Schar_or_string_p
);
3392 defsubr (&Scar_safe
);
3393 defsubr (&Scdr_safe
);
3396 defsubr (&Ssymbol_function
);
3397 defsubr (&Sindirect_function
);
3398 defsubr (&Ssymbol_plist
);
3399 defsubr (&Ssymbol_name
);
3400 defsubr (&Smakunbound
);
3401 defsubr (&Sfmakunbound
);
3403 defsubr (&Sfboundp
);
3405 defsubr (&Sdefalias
);
3406 defsubr (&Ssetplist
);
3407 defsubr (&Ssymbol_value
);
3409 defsubr (&Sdefault_boundp
);
3410 defsubr (&Sdefault_value
);
3411 defsubr (&Sset_default
);
3412 defsubr (&Ssetq_default
);
3413 defsubr (&Smake_variable_buffer_local
);
3414 defsubr (&Smake_local_variable
);
3415 defsubr (&Skill_local_variable
);
3416 defsubr (&Smake_variable_frame_local
);
3417 defsubr (&Slocal_variable_p
);
3418 defsubr (&Slocal_variable_if_set_p
);
3419 defsubr (&Svariable_binding_locus
);
3420 #if 0 /* XXX Remove this. --lorentey */
3421 defsubr (&Sterminal_local_value
);
3422 defsubr (&Sset_terminal_local_value
);
3426 defsubr (&Snumber_to_string
);
3427 defsubr (&Sstring_to_number
);
3428 defsubr (&Seqlsign
);
3451 defsubr (&Sbyteorder
);
3452 defsubr (&Ssubr_arity
);
3453 defsubr (&Ssubr_name
);
3455 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3457 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3458 doc
: /* The largest value that is representable in a Lisp integer. */);
3459 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3460 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3462 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3463 doc
: /* The smallest value that is representable in a Lisp integer. */);
3464 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3465 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3472 sigsetmask (SIGEMPTYMASK
);
3474 SIGNAL_THREAD_CHECK (signo
);
3475 xsignal0 (Qarith_error
);
3481 /* Don't do this if just dumping out.
3482 We don't want to call `signal' in this case
3483 so that we don't have trouble with dumping
3484 signal-delivering routines in an inconsistent state. */
3488 #endif /* CANNOT_DUMP */
3489 signal (SIGFPE
, arith_error
);
3492 signal (SIGEMT
, arith_error
);
3496 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3497 (do not change this comment) */