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
, Qnil
, 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/frame-locality is an issue, WHERE specifies which context to use.
1200 (nil stands for the current buffer/frame).
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
, where
, bindflag
)
1208 register Lisp_Object symbol
, newval
, where
;
1211 int voide
= EQ (newval
, Qunbound
);
1212 struct Lisp_Symbol
*sym
;
1215 /* If restoring in a dead buffer, do nothing. */
1216 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1219 CHECK_SYMBOL (symbol
);
1220 if (SYMBOL_CONSTANT_P (symbol
))
1222 if (NILP (Fkeywordp (symbol
))
1223 || !EQ (newval
, Fsymbol_value (symbol
)))
1224 xsignal1 (Qsetting_constant
, symbol
);
1226 /* Allow setting keywords to their own value. */
1230 sym
= XSYMBOL (symbol
);
1233 switch (sym
->redirect
)
1235 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1236 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1237 case SYMBOL_LOCALIZED
:
1239 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1242 if (blv
->frame_local
)
1243 where
= selected_frame
;
1245 XSETBUFFER (where
, current_buffer
);
1247 /* If the current buffer is not the buffer whose binding is
1248 loaded, or if there may be frame-local bindings and the frame
1249 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1250 the default binding is loaded, the loaded binding may be the
1252 if (!EQ (blv
->where
, where
)
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. */
1264 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1265 tem1
= Fassq (symbol
,
1267 ? XFRAME (where
)->param_alist
1268 : XBUFFER (where
)->local_var_alist
));
1274 /* This buffer still sees the default value. */
1276 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1277 or if this is `let' rather than `set',
1278 make CURRENT-ALIST-ELEMENT point to itself,
1279 indicating that we're seeing the default value.
1280 Likewise if the variable has been let-bound
1281 in the current buffer. */
1282 if (bindflag
|| !blv
->local_if_set
1283 || let_shadows_buffer_binding_p (sym
))
1286 tem1
= blv
->defcell
;
1288 /* If it's a local_if_set, being set not bound,
1289 and we're not within a let that was made for this buffer,
1290 create a new buffer-local binding for the variable.
1291 That means, give this buffer a new assoc for a local value
1292 and load that binding. */
1295 /* local_if_set is only supported for buffer-local
1296 bindings, not for frame-local bindings. */
1297 eassert (!blv
->frame_local
);
1298 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1299 XBUFFER (where
)->local_var_alist
1300 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1304 /* Record which binding is now loaded. */
1305 blv
->valcell
= tem1
;
1308 /* Store the new value in the cons cell. */
1309 SET_BLV_VALUE (blv
, newval
);
1314 /* If storing void (making the symbol void), forward only through
1315 buffer-local indicator, not through Lisp_Objfwd, etc. */
1318 store_symval_forwarding (blv
->fwd
, newval
,
1320 ? XBUFFER (where
) : current_buffer
);
1324 case SYMBOL_FORWARDED
:
1327 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1328 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1329 if (BUFFER_OBJFWDP (innercontents
))
1331 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1332 int idx
= PER_BUFFER_IDX (offset
);
1335 && !let_shadows_buffer_binding_p (sym
))
1336 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1340 { /* If storing void (making the symbol void), forward only through
1341 buffer-local indicator, not through Lisp_Objfwd, etc. */
1342 sym
->redirect
= SYMBOL_PLAINVAL
;
1343 SET_SYMBOL_VAL (sym
, newval
);
1346 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1354 /* Access or set a buffer-local symbol's default value. */
1356 /* Return the default value of SYMBOL, but don't check for voidness.
1357 Return Qunbound if it is void. */
1360 default_value (symbol
)
1363 struct Lisp_Symbol
*sym
;
1365 CHECK_SYMBOL (symbol
);
1366 sym
= XSYMBOL (symbol
);
1369 switch (sym
->redirect
)
1371 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1372 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1373 case SYMBOL_LOCALIZED
:
1375 /* If var is set up for a buffer that lacks a local value for it,
1376 the current value is nominally the default value.
1377 But the `realvalue' slot may be more up to date, since
1378 ordinary setq stores just that slot. So use that. */
1379 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1380 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1381 return do_symval_forwarding (blv
->fwd
);
1383 return XCDR (blv
->defcell
);
1385 case SYMBOL_FORWARDED
:
1387 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1389 /* For a built-in buffer-local variable, get the default value
1390 rather than letting do_symval_forwarding get the current value. */
1391 if (BUFFER_OBJFWDP (valcontents
))
1393 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1394 if (PER_BUFFER_IDX (offset
) != 0)
1395 return PER_BUFFER_DEFAULT (offset
);
1398 /* For other variables, get the current value. */
1399 return do_symval_forwarding (valcontents
);
1405 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1406 doc
: /* Return t if SYMBOL has a non-void default value.
1407 This is the value that is seen in buffers that do not have their own values
1408 for this variable. */)
1412 register Lisp_Object value
;
1414 value
= default_value (symbol
);
1415 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1418 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1419 doc
: /* Return SYMBOL's default value.
1420 This is the value that is seen in buffers that do not have their own values
1421 for this variable. The default value is meaningful for variables with
1422 local bindings in certain buffers. */)
1426 register Lisp_Object value
;
1428 value
= default_value (symbol
);
1429 if (!EQ (value
, Qunbound
))
1432 xsignal1 (Qvoid_variable
, symbol
);
1435 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1436 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1437 The default value is seen in buffers that do not have their own values
1438 for this variable. */)
1440 Lisp_Object symbol
, value
;
1442 struct Lisp_Symbol
*sym
;
1444 CHECK_SYMBOL (symbol
);
1445 if (SYMBOL_CONSTANT_P (symbol
))
1447 if (NILP (Fkeywordp (symbol
))
1448 || !EQ (value
, Fdefault_value (symbol
)))
1449 xsignal1 (Qsetting_constant
, symbol
);
1451 /* Allow setting keywords to their own value. */
1454 sym
= XSYMBOL (symbol
);
1457 switch (sym
->redirect
)
1459 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1460 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1461 case SYMBOL_LOCALIZED
:
1463 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1465 /* Store new value into the DEFAULT-VALUE slot. */
1466 XSETCDR (blv
->defcell
, value
);
1468 /* If the default binding is now loaded, set the REALVALUE slot too. */
1469 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1470 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1473 case SYMBOL_FORWARDED
:
1475 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1477 /* Handle variables like case-fold-search that have special slots
1479 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1480 if (BUFFER_OBJFWDP (valcontents
))
1482 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1483 int idx
= PER_BUFFER_IDX (offset
);
1485 PER_BUFFER_DEFAULT (offset
) = value
;
1487 /* If this variable is not always local in all buffers,
1488 set it in the buffers that don't nominally have a local value. */
1493 for (b
= all_buffers
; b
; b
= b
->next
)
1494 if (!PER_BUFFER_VALUE_P (b
, idx
))
1495 PER_BUFFER_VALUE (b
, offset
) = value
;
1500 return Fset (symbol
, value
);
1506 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1507 doc
: /* Set the default value of variable VAR to VALUE.
1508 VAR, the variable name, is literal (not evaluated);
1509 VALUE is an expression: it is evaluated and its value returned.
1510 The default value of a variable is seen in buffers
1511 that do not have their own values for the variable.
1513 More generally, you can use multiple variables and values, as in
1514 (setq-default VAR VALUE VAR VALUE...)
1515 This sets each VAR's default value to the corresponding VALUE.
1516 The VALUE for the Nth VAR can refer to the new default values
1518 usage: (setq-default [VAR VALUE]...) */)
1522 register Lisp_Object args_left
;
1523 register Lisp_Object val
, symbol
;
1524 struct gcpro gcpro1
;
1534 val
= Feval (Fcar (Fcdr (args_left
)));
1535 symbol
= XCAR (args_left
);
1536 Fset_default (symbol
, val
);
1537 args_left
= Fcdr (XCDR (args_left
));
1539 while (!NILP (args_left
));
1545 /* Lisp functions for creating and removing buffer-local variables. */
1550 union Lisp_Fwd
*fwd
;
1553 static struct Lisp_Buffer_Local_Value
*
1554 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1556 struct Lisp_Buffer_Local_Value
*blv
1557 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1561 XSETSYMBOL (symbol
, sym
);
1562 tem
= Fcons (symbol
, (forwarded
1563 ? do_symval_forwarding (valcontents
.fwd
)
1564 : valcontents
.value
));
1566 /* Buffer_Local_Values cannot have as realval a buffer-local
1567 or keyboard-local forwarding. */
1568 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1569 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1570 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1572 blv
->frame_local
= 0;
1573 blv
->local_if_set
= 0;
1576 SET_BLV_FOUND (blv
, 0);
1580 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1581 1, 1, "vMake Variable Buffer Local: ",
1582 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1583 At any time, the value for the current buffer is in effect,
1584 unless the variable has never been set in this buffer,
1585 in which case the default value is in effect.
1586 Note that binding the variable with `let', or setting it while
1587 a `let'-style binding made in this buffer is in effect,
1588 does not make the variable buffer-local. Return VARIABLE.
1590 In most cases it is better to use `make-local-variable',
1591 which makes a variable local in just one buffer.
1593 The function `default-value' gets the default value and `set-default' sets it. */)
1595 register Lisp_Object variable
;
1597 struct Lisp_Symbol
*sym
;
1598 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1599 union Lisp_Val_Fwd valcontents
;
1602 CHECK_SYMBOL (variable
);
1603 sym
= XSYMBOL (variable
);
1606 switch (sym
->redirect
)
1608 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1609 case SYMBOL_PLAINVAL
:
1610 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1611 if (EQ (valcontents
.value
, Qunbound
))
1612 valcontents
.value
= Qnil
;
1614 case SYMBOL_LOCALIZED
:
1615 blv
= SYMBOL_BLV (sym
);
1616 if (blv
->frame_local
)
1617 error ("Symbol %s may not be buffer-local",
1618 SDATA (SYMBOL_NAME (variable
)));
1620 case SYMBOL_FORWARDED
:
1621 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1622 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1623 error ("Symbol %s may not be buffer-local",
1624 SDATA (SYMBOL_NAME (variable
)));
1625 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1632 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1636 blv
= make_blv (sym
, forwarded
, valcontents
);
1637 sym
->redirect
= SYMBOL_LOCALIZED
;
1638 SET_SYMBOL_BLV (sym
, blv
);
1641 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1642 if (let_shadows_global_binding_p (symbol
))
1643 message ("Making %s buffer-local while let-bound!",
1644 SDATA (SYMBOL_NAME (variable
)));
1648 blv
->local_if_set
= 1;
1652 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1653 1, 1, "vMake Local Variable: ",
1654 doc
: /* Make VARIABLE have a separate value in the current buffer.
1655 Other buffers will continue to share a common default value.
1656 \(The buffer-local value of VARIABLE starts out as the same value
1657 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1660 If the variable is already arranged to become local when set,
1661 this function causes a local value to exist for this buffer,
1662 just as setting the variable would do.
1664 This function returns VARIABLE, and therefore
1665 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1668 See also `make-variable-buffer-local'.
1670 Do not use `make-local-variable' to make a hook variable buffer-local.
1671 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1673 register Lisp_Object variable
;
1675 register Lisp_Object tem
;
1677 union Lisp_Val_Fwd valcontents
;
1678 struct Lisp_Symbol
*sym
;
1679 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1681 CHECK_SYMBOL (variable
);
1682 sym
= XSYMBOL (variable
);
1685 switch (sym
->redirect
)
1687 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1688 case SYMBOL_PLAINVAL
:
1689 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1690 case SYMBOL_LOCALIZED
:
1691 blv
= SYMBOL_BLV (sym
);
1692 if (blv
->frame_local
)
1693 error ("Symbol %s may not be buffer-local",
1694 SDATA (SYMBOL_NAME (variable
)));
1696 case SYMBOL_FORWARDED
:
1697 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1698 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1699 error ("Symbol %s may not be buffer-local",
1700 SDATA (SYMBOL_NAME (variable
)));
1706 error ("Symbol %s may not be buffer-local",
1707 SDATA (SYMBOL_NAME (variable
)));
1709 if (blv
? blv
->local_if_set
1710 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1712 tem
= Fboundp (variable
);
1713 /* Make sure the symbol has a local value in this particular buffer,
1714 by setting it to the same value it already has. */
1715 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1720 blv
= make_blv (sym
, forwarded
, valcontents
);
1721 sym
->redirect
= SYMBOL_LOCALIZED
;
1722 SET_SYMBOL_BLV (sym
, blv
);
1725 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1726 if (let_shadows_global_binding_p (symbol
))
1727 message ("Making %s local to %s while let-bound!",
1728 SDATA (SYMBOL_NAME (variable
)),
1729 SDATA (current_buffer
->name
));
1733 /* Make sure this buffer has its own value of symbol. */
1734 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1735 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1738 if (let_shadows_buffer_binding_p (sym
))
1739 message ("Making %s buffer-local while locally let-bound!",
1740 SDATA (SYMBOL_NAME (variable
)));
1742 /* Swap out any local binding for some other buffer, and make
1743 sure the current value is permanently recorded, if it's the
1745 find_symbol_value (variable
);
1747 current_buffer
->local_var_alist
1748 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1749 current_buffer
->local_var_alist
);
1751 /* Make sure symbol does not think it is set up for this buffer;
1752 force it to look once again for this buffer's value. */
1753 if (current_buffer
== XBUFFER (blv
->where
))
1755 /* blv->valcell = blv->defcell;
1756 * SET_BLV_FOUND (blv, 0); */
1760 /* If the symbol forwards into a C variable, then load the binding
1761 for this buffer now. If C code modifies the variable before we
1762 load the binding in, then that new value will clobber the default
1763 binding the next time we unload it. */
1765 swap_in_symval_forwarding (sym
, blv
);
1770 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1771 1, 1, "vKill Local Variable: ",
1772 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1773 From now on the default value will apply in this buffer. Return VARIABLE. */)
1775 register Lisp_Object variable
;
1777 register Lisp_Object tem
;
1778 struct Lisp_Buffer_Local_Value
*blv
;
1779 struct Lisp_Symbol
*sym
;
1781 CHECK_SYMBOL (variable
);
1782 sym
= XSYMBOL (variable
);
1785 switch (sym
->redirect
)
1787 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1788 case SYMBOL_PLAINVAL
: return variable
;
1789 case SYMBOL_FORWARDED
:
1791 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1792 if (BUFFER_OBJFWDP (valcontents
))
1794 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1795 int idx
= PER_BUFFER_IDX (offset
);
1799 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1800 PER_BUFFER_VALUE (current_buffer
, offset
)
1801 = PER_BUFFER_DEFAULT (offset
);
1806 case SYMBOL_LOCALIZED
:
1807 blv
= SYMBOL_BLV (sym
);
1808 if (blv
->frame_local
)
1814 /* Get rid of this buffer's alist element, if any. */
1815 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1816 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1818 current_buffer
->local_var_alist
1819 = Fdelq (tem
, current_buffer
->local_var_alist
);
1821 /* If the symbol is set up with the current buffer's binding
1822 loaded, recompute its value. We have to do it now, or else
1823 forwarded objects won't work right. */
1825 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1826 if (EQ (buf
, blv
->where
))
1829 /* blv->valcell = blv->defcell;
1830 * SET_BLV_FOUND (blv, 0); */
1832 find_symbol_value (variable
);
1839 /* Lisp functions for creating and removing buffer-local variables. */
1841 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1842 when/if this is removed. */
1844 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1845 1, 1, "vMake Variable Frame Local: ",
1846 doc
: /* Enable VARIABLE to have frame-local bindings.
1847 This does not create any frame-local bindings for VARIABLE,
1848 it just makes them possible.
1850 A frame-local binding is actually a frame parameter value.
1851 If a frame F has a value for the frame parameter named VARIABLE,
1852 that also acts as a frame-local binding for VARIABLE in F--
1853 provided this function has been called to enable VARIABLE
1854 to have frame-local bindings at all.
1856 The only way to create a frame-local binding for VARIABLE in a frame
1857 is to set the VARIABLE frame parameter of that frame. See
1858 `modify-frame-parameters' for how to set frame parameters.
1860 Note that since Emacs 23.1, variables cannot be both buffer-local and
1861 frame-local any more (buffer-local bindings used to take precedence over
1862 frame-local bindings). */)
1864 register Lisp_Object variable
;
1867 union Lisp_Val_Fwd valcontents
;
1868 struct Lisp_Symbol
*sym
;
1869 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1871 CHECK_SYMBOL (variable
);
1872 sym
= XSYMBOL (variable
);
1875 switch (sym
->redirect
)
1877 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1878 case SYMBOL_PLAINVAL
:
1879 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1880 if (EQ (valcontents
.value
, Qunbound
))
1881 valcontents
.value
= Qnil
;
1883 case SYMBOL_LOCALIZED
:
1884 if (SYMBOL_BLV (sym
)->frame_local
)
1887 error ("Symbol %s may not be frame-local",
1888 SDATA (SYMBOL_NAME (variable
)));
1889 case SYMBOL_FORWARDED
:
1890 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1891 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1892 error ("Symbol %s may not be frame-local",
1893 SDATA (SYMBOL_NAME (variable
)));
1899 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1901 blv
= make_blv (sym
, forwarded
, valcontents
);
1902 blv
->frame_local
= 1;
1903 sym
->redirect
= SYMBOL_LOCALIZED
;
1904 SET_SYMBOL_BLV (sym
, blv
);
1907 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1908 if (let_shadows_global_binding_p (symbol
))
1909 message ("Making %s frame-local while let-bound!",
1910 SDATA (SYMBOL_NAME (variable
)));
1915 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1917 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1918 BUFFER defaults to the current buffer. */)
1920 register Lisp_Object variable
, buffer
;
1922 register struct buffer
*buf
;
1923 struct Lisp_Symbol
*sym
;
1926 buf
= current_buffer
;
1929 CHECK_BUFFER (buffer
);
1930 buf
= XBUFFER (buffer
);
1933 CHECK_SYMBOL (variable
);
1934 sym
= XSYMBOL (variable
);
1937 switch (sym
->redirect
)
1939 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1940 case SYMBOL_PLAINVAL
: return Qnil
;
1941 case SYMBOL_LOCALIZED
:
1943 Lisp_Object tail
, elt
, tmp
;
1944 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1945 XSETBUFFER (tmp
, buf
);
1947 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1950 if (EQ (variable
, XCAR (elt
)))
1952 eassert (!blv
->frame_local
);
1953 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1957 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1960 case SYMBOL_FORWARDED
:
1962 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1963 if (BUFFER_OBJFWDP (valcontents
))
1965 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1966 int idx
= PER_BUFFER_IDX (offset
);
1967 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1976 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1978 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1979 More precisely, this means that setting the variable \(with `set' or`setq'),
1980 while it does not have a `let'-style binding that was made in BUFFER,
1981 will produce a buffer local binding. See Info node
1982 `(elisp)Creating Buffer-Local'.
1983 BUFFER defaults to the current buffer. */)
1985 register Lisp_Object variable
, buffer
;
1987 struct Lisp_Symbol
*sym
;
1989 CHECK_SYMBOL (variable
);
1990 sym
= XSYMBOL (variable
);
1993 switch (sym
->redirect
)
1995 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1996 case SYMBOL_PLAINVAL
: return Qnil
;
1997 case SYMBOL_LOCALIZED
:
1999 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2000 if (blv
->local_if_set
)
2002 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2003 return Flocal_variable_p (variable
, buffer
);
2005 case SYMBOL_FORWARDED
:
2006 /* All BUFFER_OBJFWD slots become local if they are set. */
2007 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2012 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2014 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2015 If the current binding is buffer-local, the value is the current buffer.
2016 If the current binding is frame-local, the value is the selected frame.
2017 If the current binding is global (the default), the value is nil. */)
2019 register Lisp_Object variable
;
2021 struct Lisp_Symbol
*sym
;
2023 CHECK_SYMBOL (variable
);
2024 sym
= XSYMBOL (variable
);
2026 /* Make sure the current binding is actually swapped in. */
2027 find_symbol_value (variable
);
2030 switch (sym
->redirect
)
2032 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2033 case SYMBOL_PLAINVAL
: return Qnil
;
2034 case SYMBOL_FORWARDED
:
2036 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2037 if (KBOARD_OBJFWDP (valcontents
))
2038 return Fframe_terminal (Fselected_frame ());
2039 else if (!BUFFER_OBJFWDP (valcontents
))
2043 case SYMBOL_LOCALIZED
:
2044 /* For a local variable, record both the symbol and which
2045 buffer's or frame's value we are saving. */
2046 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2047 return Fcurrent_buffer ();
2048 else if (sym
->redirect
== SYMBOL_LOCALIZED
2049 && BLV_FOUND (SYMBOL_BLV (sym
)))
2050 return SYMBOL_BLV (sym
)->where
;
2057 /* This code is disabled now that we use the selected frame to return
2058 keyboard-local-values. */
2060 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2062 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2063 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2064 If SYMBOL is not a terminal-local variable, then return its normal
2065 value, like `symbol-value'.
2067 TERMINAL may be a terminal object, a frame, or nil (meaning the
2068 selected frame's terminal device). */)
2071 Lisp_Object terminal
;
2074 struct terminal
*t
= get_terminal (terminal
, 1);
2075 push_kboard (t
->kboard
);
2076 result
= Fsymbol_value (symbol
);
2081 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2082 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2083 If VARIABLE is not a terminal-local variable, then set its normal
2084 binding, like `set'.
2086 TERMINAL may be a terminal object, a frame, or nil (meaning the
2087 selected frame's terminal device). */)
2088 (symbol
, terminal
, value
)
2090 Lisp_Object terminal
;
2094 struct terminal
*t
= get_terminal (terminal
, 1);
2095 push_kboard (d
->kboard
);
2096 result
= Fset (symbol
, value
);
2102 /* Find the function at the end of a chain of symbol function indirections. */
2104 /* If OBJECT is a symbol, find the end of its function chain and
2105 return the value found there. If OBJECT is not a symbol, just
2106 return it. If there is a cycle in the function chain, signal a
2107 cyclic-function-indirection error.
2109 This is like Findirect_function, except that it doesn't signal an
2110 error if the chain ends up unbound. */
2112 indirect_function (object
)
2113 register Lisp_Object object
;
2115 Lisp_Object tortoise
, hare
;
2117 hare
= tortoise
= object
;
2121 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2123 hare
= XSYMBOL (hare
)->function
;
2124 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2126 hare
= XSYMBOL (hare
)->function
;
2128 tortoise
= XSYMBOL (tortoise
)->function
;
2130 if (EQ (hare
, tortoise
))
2131 xsignal1 (Qcyclic_function_indirection
, object
);
2137 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2138 doc
: /* Return the function at the end of OBJECT's function chain.
2139 If OBJECT is not a symbol, just return it. Otherwise, follow all
2140 function indirections to find the final function binding and return it.
2141 If the final symbol in the chain is unbound, signal a void-function error.
2142 Optional arg NOERROR non-nil means to return nil instead of signalling.
2143 Signal a cyclic-function-indirection error if there is a loop in the
2144 function chain of symbols. */)
2146 register Lisp_Object object
;
2147 Lisp_Object noerror
;
2151 /* Optimize for no indirection. */
2153 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2154 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2155 result
= indirect_function (result
);
2156 if (!EQ (result
, Qunbound
))
2160 xsignal1 (Qvoid_function
, object
);
2165 /* Extract and set vector and string elements */
2167 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2168 doc
: /* Return the element of ARRAY at index IDX.
2169 ARRAY may be a vector, a string, a char-table, a bool-vector,
2170 or a byte-code object. IDX starts at 0. */)
2172 register Lisp_Object array
;
2175 register int idxval
;
2178 idxval
= XINT (idx
);
2179 if (STRINGP (array
))
2183 if (idxval
< 0 || idxval
>= SCHARS (array
))
2184 args_out_of_range (array
, idx
);
2185 if (! STRING_MULTIBYTE (array
))
2186 return make_number ((unsigned char) SREF (array
, idxval
));
2187 idxval_byte
= string_char_to_byte (array
, idxval
);
2189 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2190 return make_number (c
);
2192 else if (BOOL_VECTOR_P (array
))
2196 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2197 args_out_of_range (array
, idx
);
2199 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2200 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2202 else if (CHAR_TABLE_P (array
))
2204 CHECK_CHARACTER (idx
);
2205 return CHAR_TABLE_REF (array
, idxval
);
2210 if (VECTORP (array
))
2211 size
= XVECTOR (array
)->size
;
2212 else if (COMPILEDP (array
))
2213 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2215 wrong_type_argument (Qarrayp
, array
);
2217 if (idxval
< 0 || idxval
>= size
)
2218 args_out_of_range (array
, idx
);
2219 return XVECTOR (array
)->contents
[idxval
];
2223 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2224 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2225 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2226 bool-vector. IDX starts at 0. */)
2227 (array
, idx
, newelt
)
2228 register Lisp_Object array
;
2229 Lisp_Object idx
, newelt
;
2231 register int idxval
;
2234 idxval
= XINT (idx
);
2235 CHECK_ARRAY (array
, Qarrayp
);
2236 CHECK_IMPURE (array
);
2238 if (VECTORP (array
))
2240 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2241 args_out_of_range (array
, idx
);
2242 XVECTOR (array
)->contents
[idxval
] = newelt
;
2244 else if (BOOL_VECTOR_P (array
))
2248 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2249 args_out_of_range (array
, idx
);
2251 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2253 if (! NILP (newelt
))
2254 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2256 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2257 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2259 else if (CHAR_TABLE_P (array
))
2261 CHECK_CHARACTER (idx
);
2262 CHAR_TABLE_SET (array
, idxval
, newelt
);
2264 else if (STRING_MULTIBYTE (array
))
2266 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2267 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2269 if (idxval
< 0 || idxval
>= SCHARS (array
))
2270 args_out_of_range (array
, idx
);
2271 CHECK_CHARACTER (newelt
);
2273 nbytes
= SBYTES (array
);
2275 idxval_byte
= string_char_to_byte (array
, idxval
);
2276 p1
= SDATA (array
) + idxval_byte
;
2277 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2278 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2279 if (prev_bytes
!= new_bytes
)
2281 /* We must relocate the string data. */
2282 int nchars
= SCHARS (array
);
2286 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2287 bcopy (SDATA (array
), str
, nbytes
);
2288 allocate_string_data (XSTRING (array
), nchars
,
2289 nbytes
+ new_bytes
- prev_bytes
);
2290 bcopy (str
, SDATA (array
), idxval_byte
);
2291 p1
= SDATA (array
) + idxval_byte
;
2292 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2293 nbytes
- (idxval_byte
+ prev_bytes
));
2295 clear_string_char_byte_cache ();
2302 if (idxval
< 0 || idxval
>= SCHARS (array
))
2303 args_out_of_range (array
, idx
);
2304 CHECK_NUMBER (newelt
);
2306 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2310 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2311 if (SREF (array
, i
) >= 0x80)
2312 args_out_of_range (array
, newelt
);
2313 /* ARRAY is an ASCII string. Convert it to a multibyte
2314 string, and try `aset' again. */
2315 STRING_SET_MULTIBYTE (array
);
2316 return Faset (array
, idx
, newelt
);
2318 SSET (array
, idxval
, XINT (newelt
));
2324 /* Arithmetic functions */
2326 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2329 arithcompare (num1
, num2
, comparison
)
2330 Lisp_Object num1
, num2
;
2331 enum comparison comparison
;
2333 double f1
= 0, f2
= 0;
2336 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2337 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2339 if (FLOATP (num1
) || FLOATP (num2
))
2342 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2343 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2349 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2354 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2359 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2364 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2369 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2374 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2383 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2384 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2386 register Lisp_Object num1
, num2
;
2388 return arithcompare (num1
, num2
, equal
);
2391 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2392 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2394 register Lisp_Object num1
, num2
;
2396 return arithcompare (num1
, num2
, less
);
2399 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2400 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2402 register Lisp_Object num1
, num2
;
2404 return arithcompare (num1
, num2
, grtr
);
2407 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2408 doc
: /* Return t if first arg is less than or equal to second arg.
2409 Both must be numbers or markers. */)
2411 register Lisp_Object num1
, num2
;
2413 return arithcompare (num1
, num2
, less_or_equal
);
2416 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2417 doc
: /* Return t if first arg is greater than or equal to second arg.
2418 Both must be numbers or markers. */)
2420 register Lisp_Object num1
, num2
;
2422 return arithcompare (num1
, num2
, grtr_or_equal
);
2425 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2426 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2428 register Lisp_Object num1
, num2
;
2430 return arithcompare (num1
, num2
, notequal
);
2433 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2434 doc
: /* Return t if NUMBER is zero. */)
2436 register Lisp_Object number
;
2438 CHECK_NUMBER_OR_FLOAT (number
);
2440 if (FLOATP (number
))
2442 if (XFLOAT_DATA (number
) == 0.0)
2452 /* Convert between long values and pairs of Lisp integers.
2453 Note that long_to_cons returns a single Lisp integer
2454 when the value fits in one. */
2460 unsigned long top
= i
>> 16;
2461 unsigned int bot
= i
& 0xFFFF;
2463 return make_number (bot
);
2464 if (top
== (unsigned long)-1 >> 16)
2465 return Fcons (make_number (-1), make_number (bot
));
2466 return Fcons (make_number (top
), make_number (bot
));
2473 Lisp_Object top
, bot
;
2480 return ((XINT (top
) << 16) | XINT (bot
));
2483 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2484 doc
: /* Return the decimal representation of NUMBER as a string.
2485 Uses a minus sign if negative.
2486 NUMBER may be an integer or a floating point number. */)
2490 char buffer
[VALBITS
];
2492 CHECK_NUMBER_OR_FLOAT (number
);
2494 if (FLOATP (number
))
2496 char pigbuf
[350]; /* see comments in float_to_string */
2498 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2499 return build_string (pigbuf
);
2502 if (sizeof (int) == sizeof (EMACS_INT
))
2503 sprintf (buffer
, "%d", (int) XINT (number
));
2504 else if (sizeof (long) == sizeof (EMACS_INT
))
2505 sprintf (buffer
, "%ld", (long) XINT (number
));
2508 return build_string (buffer
);
2512 digit_to_number (character
, base
)
2513 int character
, base
;
2517 if (character
>= '0' && character
<= '9')
2518 digit
= character
- '0';
2519 else if (character
>= 'a' && character
<= 'z')
2520 digit
= character
- 'a' + 10;
2521 else if (character
>= 'A' && character
<= 'Z')
2522 digit
= character
- 'A' + 10;
2532 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2533 doc
: /* Parse STRING as a decimal number and return the number.
2534 This parses both integers and floating point numbers.
2535 It ignores leading spaces and tabs, and all trailing chars.
2537 If BASE, interpret STRING as a number in that base. If BASE isn't
2538 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2539 If the base used is not 10, STRING is always parsed as integer. */)
2541 register Lisp_Object string
, base
;
2543 register unsigned char *p
;
2548 CHECK_STRING (string
);
2554 CHECK_NUMBER (base
);
2556 if (b
< 2 || b
> 16)
2557 xsignal1 (Qargs_out_of_range
, base
);
2560 /* Skip any whitespace at the front of the number. Some versions of
2561 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2563 while (*p
== ' ' || *p
== '\t')
2574 if (isfloat_string (p
, 1) && b
== 10)
2575 val
= make_float (sign
* atof (p
));
2582 int digit
= digit_to_number (*p
++, b
);
2588 val
= make_fixnum_or_float (sign
* v
);
2608 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2609 int, Lisp_Object
*));
2610 extern Lisp_Object
fmod_float ();
2613 arith_driver (code
, nargs
, args
)
2616 register Lisp_Object
*args
;
2618 register Lisp_Object val
;
2619 register int argnum
;
2620 register EMACS_INT accum
= 0;
2621 register EMACS_INT next
;
2623 switch (SWITCH_ENUM_CAST (code
))
2641 for (argnum
= 0; argnum
< nargs
; argnum
++)
2643 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2645 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2648 return float_arith_driver ((double) accum
, argnum
, code
,
2651 next
= XINT (args
[argnum
]);
2652 switch (SWITCH_ENUM_CAST (code
))
2658 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2669 xsignal0 (Qarith_error
);
2683 if (!argnum
|| next
> accum
)
2687 if (!argnum
|| next
< accum
)
2693 XSETINT (val
, accum
);
2698 #define isnan(x) ((x) != (x))
2701 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2703 register int argnum
;
2706 register Lisp_Object
*args
;
2708 register Lisp_Object val
;
2711 for (; argnum
< nargs
; argnum
++)
2713 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2714 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2718 next
= XFLOAT_DATA (val
);
2722 args
[argnum
] = val
; /* runs into a compiler bug. */
2723 next
= XINT (args
[argnum
]);
2725 switch (SWITCH_ENUM_CAST (code
))
2731 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2741 if (! IEEE_FLOATING_POINT
&& next
== 0)
2742 xsignal0 (Qarith_error
);
2749 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2751 if (!argnum
|| isnan (next
) || next
> accum
)
2755 if (!argnum
|| isnan (next
) || next
< accum
)
2761 return make_float (accum
);
2765 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2766 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2767 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2772 return arith_driver (Aadd
, nargs
, args
);
2775 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2776 doc
: /* Negate number or subtract numbers or markers and return the result.
2777 With one arg, negates it. With more than one arg,
2778 subtracts all but the first from the first.
2779 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2784 return arith_driver (Asub
, nargs
, args
);
2787 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2788 doc
: /* Return product of any number of arguments, which are numbers or markers.
2789 usage: (* &rest NUMBERS-OR-MARKERS) */)
2794 return arith_driver (Amult
, nargs
, args
);
2797 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2798 doc
: /* Return first argument divided by all the remaining arguments.
2799 The arguments must be numbers or markers.
2800 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2806 for (argnum
= 2; argnum
< nargs
; argnum
++)
2807 if (FLOATP (args
[argnum
]))
2808 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2809 return arith_driver (Adiv
, nargs
, args
);
2812 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2813 doc
: /* Return remainder of X divided by Y.
2814 Both must be integers or markers. */)
2816 register Lisp_Object x
, y
;
2820 CHECK_NUMBER_COERCE_MARKER (x
);
2821 CHECK_NUMBER_COERCE_MARKER (y
);
2823 if (XFASTINT (y
) == 0)
2824 xsignal0 (Qarith_error
);
2826 XSETINT (val
, XINT (x
) % XINT (y
));
2840 /* If the magnitude of the result exceeds that of the divisor, or
2841 the sign of the result does not agree with that of the dividend,
2842 iterate with the reduced value. This does not yield a
2843 particularly accurate result, but at least it will be in the
2844 range promised by fmod. */
2846 r
-= f2
* floor (r
/ f2
);
2847 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2851 #endif /* ! HAVE_FMOD */
2853 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2854 doc
: /* Return X modulo Y.
2855 The result falls between zero (inclusive) and Y (exclusive).
2856 Both X and Y must be numbers or markers. */)
2858 register Lisp_Object x
, y
;
2863 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2864 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2866 if (FLOATP (x
) || FLOATP (y
))
2867 return fmod_float (x
, y
);
2873 xsignal0 (Qarith_error
);
2877 /* If the "remainder" comes out with the wrong sign, fix it. */
2878 if (i2
< 0 ? i1
> 0 : i1
< 0)
2885 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2886 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2887 The value is always a number; markers are converted to numbers.
2888 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2893 return arith_driver (Amax
, nargs
, args
);
2896 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2897 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2898 The value is always a number; markers are converted to numbers.
2899 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2904 return arith_driver (Amin
, nargs
, args
);
2907 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2908 doc
: /* Return bitwise-and of all the arguments.
2909 Arguments may be integers, or markers converted to integers.
2910 usage: (logand &rest INTS-OR-MARKERS) */)
2915 return arith_driver (Alogand
, nargs
, args
);
2918 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2919 doc
: /* Return bitwise-or of all the arguments.
2920 Arguments may be integers, or markers converted to integers.
2921 usage: (logior &rest INTS-OR-MARKERS) */)
2926 return arith_driver (Alogior
, nargs
, args
);
2929 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2930 doc
: /* Return bitwise-exclusive-or of all the arguments.
2931 Arguments may be integers, or markers converted to integers.
2932 usage: (logxor &rest INTS-OR-MARKERS) */)
2937 return arith_driver (Alogxor
, nargs
, args
);
2940 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2941 doc
: /* Return VALUE with its bits shifted left by COUNT.
2942 If COUNT is negative, shifting is actually to the right.
2943 In this case, the sign bit is duplicated. */)
2945 register Lisp_Object value
, count
;
2947 register Lisp_Object val
;
2949 CHECK_NUMBER (value
);
2950 CHECK_NUMBER (count
);
2952 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2954 else if (XINT (count
) > 0)
2955 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2956 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2957 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2959 XSETINT (val
, XINT (value
) >> -XINT (count
));
2963 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2964 doc
: /* Return VALUE with its bits shifted left by COUNT.
2965 If COUNT is negative, shifting is actually to the right.
2966 In this case, zeros are shifted in on the left. */)
2968 register Lisp_Object value
, count
;
2970 register Lisp_Object val
;
2972 CHECK_NUMBER (value
);
2973 CHECK_NUMBER (count
);
2975 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2977 else if (XINT (count
) > 0)
2978 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2979 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2982 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2986 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2987 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2988 Markers are converted to integers. */)
2990 register Lisp_Object number
;
2992 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2994 if (FLOATP (number
))
2995 return (make_float (1.0 + XFLOAT_DATA (number
)));
2997 XSETINT (number
, XINT (number
) + 1);
3001 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3002 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3003 Markers are converted to integers. */)
3005 register Lisp_Object number
;
3007 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3009 if (FLOATP (number
))
3010 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3012 XSETINT (number
, XINT (number
) - 1);
3016 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3017 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3019 register Lisp_Object number
;
3021 CHECK_NUMBER (number
);
3022 XSETINT (number
, ~XINT (number
));
3026 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3027 doc
: /* Return the byteorder for the machine.
3028 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3029 lowercase l) for small endian machines. */)
3032 unsigned i
= 0x04030201;
3033 int order
= *(char *)&i
== 1 ? 108 : 66;
3035 return make_number (order
);
3043 Lisp_Object error_tail
, arith_tail
;
3045 Qquote
= intern_c_string ("quote");
3046 Qlambda
= intern_c_string ("lambda");
3047 Qsubr
= intern_c_string ("subr");
3048 Qerror_conditions
= intern_c_string ("error-conditions");
3049 Qerror_message
= intern_c_string ("error-message");
3050 Qtop_level
= intern_c_string ("top-level");
3052 Qerror
= intern_c_string ("error");
3053 Qquit
= intern_c_string ("quit");
3054 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3055 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3056 Qvoid_function
= intern_c_string ("void-function");
3057 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3058 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3059 Qvoid_variable
= intern_c_string ("void-variable");
3060 Qsetting_constant
= intern_c_string ("setting-constant");
3061 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3063 Qinvalid_function
= intern_c_string ("invalid-function");
3064 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3065 Qno_catch
= intern_c_string ("no-catch");
3066 Qend_of_file
= intern_c_string ("end-of-file");
3067 Qarith_error
= intern_c_string ("arith-error");
3068 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3069 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3070 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3071 Qtext_read_only
= intern_c_string ("text-read-only");
3072 Qmark_inactive
= intern_c_string ("mark-inactive");
3074 Qlistp
= intern_c_string ("listp");
3075 Qconsp
= intern_c_string ("consp");
3076 Qsymbolp
= intern_c_string ("symbolp");
3077 Qkeywordp
= intern_c_string ("keywordp");
3078 Qintegerp
= intern_c_string ("integerp");
3079 Qnatnump
= intern_c_string ("natnump");
3080 Qwholenump
= intern_c_string ("wholenump");
3081 Qstringp
= intern_c_string ("stringp");
3082 Qarrayp
= intern_c_string ("arrayp");
3083 Qsequencep
= intern_c_string ("sequencep");
3084 Qbufferp
= intern_c_string ("bufferp");
3085 Qvectorp
= intern_c_string ("vectorp");
3086 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3087 Qmarkerp
= intern_c_string ("markerp");
3088 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3089 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3090 Qboundp
= intern_c_string ("boundp");
3091 Qfboundp
= intern_c_string ("fboundp");
3093 Qfloatp
= intern_c_string ("floatp");
3094 Qnumberp
= intern_c_string ("numberp");
3095 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3097 Qchar_table_p
= intern_c_string ("char-table-p");
3098 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3100 Qsubrp
= intern_c_string ("subrp");
3101 Qunevalled
= intern_c_string ("unevalled");
3102 Qmany
= intern_c_string ("many");
3104 Qcdr
= intern_c_string ("cdr");
3106 /* Handle automatic advice activation */
3107 Qad_advice_info
= intern_c_string ("ad-advice-info");
3108 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3110 error_tail
= pure_cons (Qerror
, Qnil
);
3112 /* ERROR is used as a signaler for random errors for which nothing else is right */
3114 Fput (Qerror
, Qerror_conditions
,
3116 Fput (Qerror
, Qerror_message
,
3117 make_pure_c_string ("error"));
3119 Fput (Qquit
, Qerror_conditions
,
3120 pure_cons (Qquit
, Qnil
));
3121 Fput (Qquit
, Qerror_message
,
3122 make_pure_c_string ("Quit"));
3124 Fput (Qwrong_type_argument
, Qerror_conditions
,
3125 pure_cons (Qwrong_type_argument
, error_tail
));
3126 Fput (Qwrong_type_argument
, Qerror_message
,
3127 make_pure_c_string ("Wrong type argument"));
3129 Fput (Qargs_out_of_range
, Qerror_conditions
,
3130 pure_cons (Qargs_out_of_range
, error_tail
));
3131 Fput (Qargs_out_of_range
, Qerror_message
,
3132 make_pure_c_string ("Args out of range"));
3134 Fput (Qvoid_function
, Qerror_conditions
,
3135 pure_cons (Qvoid_function
, error_tail
));
3136 Fput (Qvoid_function
, Qerror_message
,
3137 make_pure_c_string ("Symbol's function definition is void"));
3139 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3140 pure_cons (Qcyclic_function_indirection
, error_tail
));
3141 Fput (Qcyclic_function_indirection
, Qerror_message
,
3142 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3144 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3145 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3146 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3147 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3149 Qcircular_list
= intern_c_string ("circular-list");
3150 staticpro (&Qcircular_list
);
3151 Fput (Qcircular_list
, Qerror_conditions
,
3152 pure_cons (Qcircular_list
, error_tail
));
3153 Fput (Qcircular_list
, Qerror_message
,
3154 make_pure_c_string ("List contains a loop"));
3156 Fput (Qvoid_variable
, Qerror_conditions
,
3157 pure_cons (Qvoid_variable
, error_tail
));
3158 Fput (Qvoid_variable
, Qerror_message
,
3159 make_pure_c_string ("Symbol's value as variable is void"));
3161 Fput (Qsetting_constant
, Qerror_conditions
,
3162 pure_cons (Qsetting_constant
, error_tail
));
3163 Fput (Qsetting_constant
, Qerror_message
,
3164 make_pure_c_string ("Attempt to set a constant symbol"));
3166 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3167 pure_cons (Qinvalid_read_syntax
, error_tail
));
3168 Fput (Qinvalid_read_syntax
, Qerror_message
,
3169 make_pure_c_string ("Invalid read syntax"));
3171 Fput (Qinvalid_function
, Qerror_conditions
,
3172 pure_cons (Qinvalid_function
, error_tail
));
3173 Fput (Qinvalid_function
, Qerror_message
,
3174 make_pure_c_string ("Invalid function"));
3176 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3177 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3178 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3179 make_pure_c_string ("Wrong number of arguments"));
3181 Fput (Qno_catch
, Qerror_conditions
,
3182 pure_cons (Qno_catch
, error_tail
));
3183 Fput (Qno_catch
, Qerror_message
,
3184 make_pure_c_string ("No catch for tag"));
3186 Fput (Qend_of_file
, Qerror_conditions
,
3187 pure_cons (Qend_of_file
, error_tail
));
3188 Fput (Qend_of_file
, Qerror_message
,
3189 make_pure_c_string ("End of file during parsing"));
3191 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3192 Fput (Qarith_error
, Qerror_conditions
,
3194 Fput (Qarith_error
, Qerror_message
,
3195 make_pure_c_string ("Arithmetic error"));
3197 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3198 pure_cons (Qbeginning_of_buffer
, error_tail
));
3199 Fput (Qbeginning_of_buffer
, Qerror_message
,
3200 make_pure_c_string ("Beginning of buffer"));
3202 Fput (Qend_of_buffer
, Qerror_conditions
,
3203 pure_cons (Qend_of_buffer
, error_tail
));
3204 Fput (Qend_of_buffer
, Qerror_message
,
3205 make_pure_c_string ("End of buffer"));
3207 Fput (Qbuffer_read_only
, Qerror_conditions
,
3208 pure_cons (Qbuffer_read_only
, error_tail
));
3209 Fput (Qbuffer_read_only
, Qerror_message
,
3210 make_pure_c_string ("Buffer is read-only"));
3212 Fput (Qtext_read_only
, Qerror_conditions
,
3213 pure_cons (Qtext_read_only
, error_tail
));
3214 Fput (Qtext_read_only
, Qerror_message
,
3215 make_pure_c_string ("Text is read-only"));
3217 Qrange_error
= intern_c_string ("range-error");
3218 Qdomain_error
= intern_c_string ("domain-error");
3219 Qsingularity_error
= intern_c_string ("singularity-error");
3220 Qoverflow_error
= intern_c_string ("overflow-error");
3221 Qunderflow_error
= intern_c_string ("underflow-error");
3223 Fput (Qdomain_error
, Qerror_conditions
,
3224 pure_cons (Qdomain_error
, arith_tail
));
3225 Fput (Qdomain_error
, Qerror_message
,
3226 make_pure_c_string ("Arithmetic domain error"));
3228 Fput (Qrange_error
, Qerror_conditions
,
3229 pure_cons (Qrange_error
, arith_tail
));
3230 Fput (Qrange_error
, Qerror_message
,
3231 make_pure_c_string ("Arithmetic range error"));
3233 Fput (Qsingularity_error
, Qerror_conditions
,
3234 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3235 Fput (Qsingularity_error
, Qerror_message
,
3236 make_pure_c_string ("Arithmetic singularity error"));
3238 Fput (Qoverflow_error
, Qerror_conditions
,
3239 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3240 Fput (Qoverflow_error
, Qerror_message
,
3241 make_pure_c_string ("Arithmetic overflow error"));
3243 Fput (Qunderflow_error
, Qerror_conditions
,
3244 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3245 Fput (Qunderflow_error
, Qerror_message
,
3246 make_pure_c_string ("Arithmetic underflow error"));
3248 staticpro (&Qrange_error
);
3249 staticpro (&Qdomain_error
);
3250 staticpro (&Qsingularity_error
);
3251 staticpro (&Qoverflow_error
);
3252 staticpro (&Qunderflow_error
);
3256 staticpro (&Qquote
);
3257 staticpro (&Qlambda
);
3259 staticpro (&Qunbound
);
3260 staticpro (&Qerror_conditions
);
3261 staticpro (&Qerror_message
);
3262 staticpro (&Qtop_level
);
3264 staticpro (&Qerror
);
3266 staticpro (&Qwrong_type_argument
);
3267 staticpro (&Qargs_out_of_range
);
3268 staticpro (&Qvoid_function
);
3269 staticpro (&Qcyclic_function_indirection
);
3270 staticpro (&Qcyclic_variable_indirection
);
3271 staticpro (&Qvoid_variable
);
3272 staticpro (&Qsetting_constant
);
3273 staticpro (&Qinvalid_read_syntax
);
3274 staticpro (&Qwrong_number_of_arguments
);
3275 staticpro (&Qinvalid_function
);
3276 staticpro (&Qno_catch
);
3277 staticpro (&Qend_of_file
);
3278 staticpro (&Qarith_error
);
3279 staticpro (&Qbeginning_of_buffer
);
3280 staticpro (&Qend_of_buffer
);
3281 staticpro (&Qbuffer_read_only
);
3282 staticpro (&Qtext_read_only
);
3283 staticpro (&Qmark_inactive
);
3285 staticpro (&Qlistp
);
3286 staticpro (&Qconsp
);
3287 staticpro (&Qsymbolp
);
3288 staticpro (&Qkeywordp
);
3289 staticpro (&Qintegerp
);
3290 staticpro (&Qnatnump
);
3291 staticpro (&Qwholenump
);
3292 staticpro (&Qstringp
);
3293 staticpro (&Qarrayp
);
3294 staticpro (&Qsequencep
);
3295 staticpro (&Qbufferp
);
3296 staticpro (&Qvectorp
);
3297 staticpro (&Qchar_or_string_p
);
3298 staticpro (&Qmarkerp
);
3299 staticpro (&Qbuffer_or_string_p
);
3300 staticpro (&Qinteger_or_marker_p
);
3301 staticpro (&Qfloatp
);
3302 staticpro (&Qnumberp
);
3303 staticpro (&Qnumber_or_marker_p
);
3304 staticpro (&Qchar_table_p
);
3305 staticpro (&Qvector_or_char_table_p
);
3306 staticpro (&Qsubrp
);
3308 staticpro (&Qunevalled
);
3310 staticpro (&Qboundp
);
3311 staticpro (&Qfboundp
);
3313 staticpro (&Qad_advice_info
);
3314 staticpro (&Qad_activate_internal
);
3316 /* Types that type-of returns. */
3317 Qinteger
= intern_c_string ("integer");
3318 Qsymbol
= intern_c_string ("symbol");
3319 Qstring
= intern_c_string ("string");
3320 Qcons
= intern_c_string ("cons");
3321 Qmarker
= intern_c_string ("marker");
3322 Qoverlay
= intern_c_string ("overlay");
3323 Qfloat
= intern_c_string ("float");
3324 Qwindow_configuration
= intern_c_string ("window-configuration");
3325 Qprocess
= intern_c_string ("process");
3326 Qwindow
= intern_c_string ("window");
3327 /* Qsubr = intern_c_string ("subr"); */
3328 Qcompiled_function
= intern_c_string ("compiled-function");
3329 Qbuffer
= intern_c_string ("buffer");
3330 Qframe
= intern_c_string ("frame");
3331 Qvector
= intern_c_string ("vector");
3332 Qchar_table
= intern_c_string ("char-table");
3333 Qbool_vector
= intern_c_string ("bool-vector");
3334 Qhash_table
= intern_c_string ("hash-table");
3336 DEFSYM (Qfont_spec
, "font-spec");
3337 DEFSYM (Qfont_entity
, "font-entity");
3338 DEFSYM (Qfont_object
, "font-object");
3340 DEFSYM (Qinteractive_form
, "interactive-form");
3342 staticpro (&Qinteger
);
3343 staticpro (&Qsymbol
);
3344 staticpro (&Qstring
);
3346 staticpro (&Qmarker
);
3347 staticpro (&Qoverlay
);
3348 staticpro (&Qfloat
);
3349 staticpro (&Qwindow_configuration
);
3350 staticpro (&Qprocess
);
3351 staticpro (&Qwindow
);
3352 /* staticpro (&Qsubr); */
3353 staticpro (&Qcompiled_function
);
3354 staticpro (&Qbuffer
);
3355 staticpro (&Qframe
);
3356 staticpro (&Qvector
);
3357 staticpro (&Qchar_table
);
3358 staticpro (&Qbool_vector
);
3359 staticpro (&Qhash_table
);
3361 defsubr (&Sindirect_variable
);
3362 defsubr (&Sinteractive_form
);
3365 defsubr (&Stype_of
);
3370 defsubr (&Sintegerp
);
3371 defsubr (&Sinteger_or_marker_p
);
3372 defsubr (&Snumberp
);
3373 defsubr (&Snumber_or_marker_p
);
3375 defsubr (&Snatnump
);
3376 defsubr (&Ssymbolp
);
3377 defsubr (&Skeywordp
);
3378 defsubr (&Sstringp
);
3379 defsubr (&Smultibyte_string_p
);
3380 defsubr (&Svectorp
);
3381 defsubr (&Schar_table_p
);
3382 defsubr (&Svector_or_char_table_p
);
3383 defsubr (&Sbool_vector_p
);
3385 defsubr (&Ssequencep
);
3386 defsubr (&Sbufferp
);
3387 defsubr (&Smarkerp
);
3389 defsubr (&Sbyte_code_function_p
);
3390 defsubr (&Schar_or_string_p
);
3393 defsubr (&Scar_safe
);
3394 defsubr (&Scdr_safe
);
3397 defsubr (&Ssymbol_function
);
3398 defsubr (&Sindirect_function
);
3399 defsubr (&Ssymbol_plist
);
3400 defsubr (&Ssymbol_name
);
3401 defsubr (&Smakunbound
);
3402 defsubr (&Sfmakunbound
);
3404 defsubr (&Sfboundp
);
3406 defsubr (&Sdefalias
);
3407 defsubr (&Ssetplist
);
3408 defsubr (&Ssymbol_value
);
3410 defsubr (&Sdefault_boundp
);
3411 defsubr (&Sdefault_value
);
3412 defsubr (&Sset_default
);
3413 defsubr (&Ssetq_default
);
3414 defsubr (&Smake_variable_buffer_local
);
3415 defsubr (&Smake_local_variable
);
3416 defsubr (&Skill_local_variable
);
3417 defsubr (&Smake_variable_frame_local
);
3418 defsubr (&Slocal_variable_p
);
3419 defsubr (&Slocal_variable_if_set_p
);
3420 defsubr (&Svariable_binding_locus
);
3421 #if 0 /* XXX Remove this. --lorentey */
3422 defsubr (&Sterminal_local_value
);
3423 defsubr (&Sset_terminal_local_value
);
3427 defsubr (&Snumber_to_string
);
3428 defsubr (&Sstring_to_number
);
3429 defsubr (&Seqlsign
);
3452 defsubr (&Sbyteorder
);
3453 defsubr (&Ssubr_arity
);
3454 defsubr (&Ssubr_name
);
3456 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3458 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3459 doc
: /* The largest value that is representable in a Lisp integer. */);
3460 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3461 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3463 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3464 doc
: /* The smallest value that is representable in a Lisp integer. */);
3465 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3466 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3473 sigsetmask (SIGEMPTYMASK
);
3475 SIGNAL_THREAD_CHECK (signo
);
3476 xsignal0 (Qarith_error
);
3482 /* Don't do this if just dumping out.
3483 We don't want to call `signal' in this case
3484 so that we don't have trouble with dumping
3485 signal-delivering routines in an inconsistent state. */
3489 #endif /* CANNOT_DUMP */
3490 signal (SIGFPE
, arith_error
);
3493 signal (SIGEMT
, arith_error
);
3497 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3498 (do not change this comment) */