1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
53 extern double atof (const char *);
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
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 (Lisp_Object list
)
102 xsignal (Qcircular_list
, list
);
107 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
109 /* If VALUE is not even a valid Lisp object, we'd want to abort here
110 where we can get a backtrace showing where it came from. We used
111 to try and do that by checking the tagbits, but nowadays all
112 tagbits are potentially valid. */
113 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
116 xsignal2 (Qwrong_type_argument
, predicate
, value
);
120 pure_write_error (void)
122 error ("Attempt to modify read-only object");
126 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
128 xsignal2 (Qargs_out_of_range
, a1
, a2
);
132 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
134 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
137 /* On some machines, XINT needs a temporary location.
138 Here it is, in case it is needed. */
140 int sign_extend_temp
;
142 /* On a few machines, XINT can only be done by calling this. */
145 sign_extend_lisp_int (EMACS_INT num
)
147 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
148 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
150 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
153 /* Data type predicates */
155 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
156 doc
: /* Return t if the two args are the same Lisp object. */)
158 Lisp_Object obj1
, obj2
;
165 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
166 doc
: /* Return t if OBJECT is nil. */)
175 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
176 doc
: /* Return a symbol representing the type of OBJECT.
177 The symbol returned names the object's basic type;
178 for example, (type-of 1) returns `integer'. */)
182 switch (XTYPE (object
))
197 switch (XMISCTYPE (object
))
199 case Lisp_Misc_Marker
:
201 case Lisp_Misc_Overlay
:
203 case Lisp_Misc_Float
:
208 case Lisp_Vectorlike
:
209 if (WINDOW_CONFIGURATIONP (object
))
210 return Qwindow_configuration
;
211 if (PROCESSP (object
))
213 if (WINDOWP (object
))
217 if (COMPILEDP (object
))
218 return Qcompiled_function
;
219 if (BUFFERP (object
))
221 if (CHAR_TABLE_P (object
))
223 if (BOOL_VECTOR_P (object
))
227 if (HASH_TABLE_P (object
))
229 if (FONT_SPEC_P (object
))
231 if (FONT_ENTITY_P (object
))
233 if (FONT_OBJECT_P (object
))
245 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
246 doc
: /* Return t if OBJECT is a cons cell. */)
255 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
256 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
265 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
266 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
267 Otherwise, return nil. */)
271 if (CONSP (object
) || NILP (object
))
276 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
277 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
281 if (CONSP (object
) || NILP (object
))
286 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
287 doc
: /* Return t if OBJECT is a symbol. */)
291 if (SYMBOLP (object
))
296 /* Define this in C to avoid unnecessarily consing up the symbol
298 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
299 doc
: /* Return t if OBJECT is a keyword.
300 This means that it is a symbol with a print name beginning with `:'
301 interned in the initial obarray. */)
306 && SREF (SYMBOL_NAME (object
), 0) == ':'
307 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
312 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
313 doc
: /* Return t if OBJECT is a vector. */)
317 if (VECTORP (object
))
322 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
323 doc
: /* Return t if OBJECT is a string. */)
327 if (STRINGP (object
))
332 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
334 doc
: /* Return t if OBJECT is a multibyte string. */)
338 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
343 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
344 doc
: /* Return t if OBJECT is a char-table. */)
348 if (CHAR_TABLE_P (object
))
353 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
354 Svector_or_char_table_p
, 1, 1, 0,
355 doc
: /* Return t if OBJECT is a char-table or vector. */)
359 if (VECTORP (object
) || CHAR_TABLE_P (object
))
364 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
365 doc
: /* Return t if OBJECT is a bool-vector. */)
369 if (BOOL_VECTOR_P (object
))
374 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
375 doc
: /* Return t if OBJECT is an array (string or vector). */)
384 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
385 doc
: /* Return t if OBJECT is a sequence (list or array). */)
387 register Lisp_Object object
;
389 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
394 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
395 doc
: /* Return t if OBJECT is an editor buffer. */)
399 if (BUFFERP (object
))
404 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
405 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
409 if (MARKERP (object
))
414 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is a built-in function. */)
424 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
426 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
430 if (COMPILEDP (object
))
435 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
436 doc
: /* Return t if OBJECT is a character or a string. */)
438 register Lisp_Object object
;
440 if (CHARACTERP (object
) || STRINGP (object
))
445 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
446 doc
: /* Return t if OBJECT is an integer. */)
450 if (INTEGERP (object
))
455 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
456 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
458 register Lisp_Object object
;
460 if (MARKERP (object
) || INTEGERP (object
))
465 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
466 doc
: /* Return t if OBJECT is a nonnegative integer. */)
470 if (NATNUMP (object
))
475 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
476 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
480 if (NUMBERP (object
))
486 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
487 Snumber_or_marker_p
, 1, 1, 0,
488 doc
: /* Return t if OBJECT is a number or a marker. */)
492 if (NUMBERP (object
) || MARKERP (object
))
497 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
498 doc
: /* Return t if OBJECT is a floating point number. */)
508 /* Extract and set components of lists */
510 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
511 doc
: /* Return the car of LIST. If arg is nil, return nil.
512 Error if arg is not nil and not a cons cell. See also `car-safe'.
514 See Info node `(elisp)Cons Cells' for a discussion of related basic
515 Lisp concepts such as car, cdr, cons cell and list. */)
517 register Lisp_Object list
;
522 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
523 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
527 return CAR_SAFE (object
);
530 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
531 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
532 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
534 See Info node `(elisp)Cons Cells' for a discussion of related basic
535 Lisp concepts such as cdr, car, cons cell and list. */)
537 register Lisp_Object list
;
542 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
543 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
547 return CDR_SAFE (object
);
550 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
551 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
553 register Lisp_Object cell
, newcar
;
557 XSETCAR (cell
, newcar
);
561 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
562 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
564 register Lisp_Object cell
, newcdr
;
568 XSETCDR (cell
, newcdr
);
572 /* Extract and set components of symbols */
574 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
575 doc
: /* Return t if SYMBOL's value is not void. */)
577 register Lisp_Object symbol
;
579 Lisp_Object valcontents
;
580 struct Lisp_Symbol
*sym
;
581 CHECK_SYMBOL (symbol
);
582 sym
= XSYMBOL (symbol
);
585 switch (sym
->redirect
)
587 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
588 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
589 case SYMBOL_LOCALIZED
:
591 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
593 /* In set_internal, we un-forward vars when their value is
598 swap_in_symval_forwarding (sym
, blv
);
599 valcontents
= BLV_VALUE (blv
);
603 case SYMBOL_FORWARDED
:
604 /* In set_internal, we un-forward vars when their value is
610 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
613 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
614 doc
: /* Return t if SYMBOL's function definition is not void. */)
616 register Lisp_Object symbol
;
618 CHECK_SYMBOL (symbol
);
619 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
622 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
623 doc
: /* Make SYMBOL's value be void.
626 register Lisp_Object symbol
;
628 CHECK_SYMBOL (symbol
);
629 if (SYMBOL_CONSTANT_P (symbol
))
630 xsignal1 (Qsetting_constant
, symbol
);
631 Fset (symbol
, Qunbound
);
635 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
636 doc
: /* Make SYMBOL's function definition be void.
639 register Lisp_Object symbol
;
641 CHECK_SYMBOL (symbol
);
642 if (NILP (symbol
) || EQ (symbol
, Qt
))
643 xsignal1 (Qsetting_constant
, symbol
);
644 XSYMBOL (symbol
)->function
= Qunbound
;
648 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
649 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
651 register Lisp_Object symbol
;
653 CHECK_SYMBOL (symbol
);
654 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
655 return XSYMBOL (symbol
)->function
;
656 xsignal1 (Qvoid_function
, symbol
);
659 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
660 doc
: /* Return SYMBOL's property list. */)
662 register Lisp_Object symbol
;
664 CHECK_SYMBOL (symbol
);
665 return XSYMBOL (symbol
)->plist
;
668 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
669 doc
: /* Return SYMBOL's name, a string. */)
671 register Lisp_Object symbol
;
673 register Lisp_Object name
;
675 CHECK_SYMBOL (symbol
);
676 name
= SYMBOL_NAME (symbol
);
680 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
681 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
683 register Lisp_Object symbol
, definition
;
685 register Lisp_Object function
;
687 CHECK_SYMBOL (symbol
);
688 if (NILP (symbol
) || EQ (symbol
, Qt
))
689 xsignal1 (Qsetting_constant
, symbol
);
691 function
= XSYMBOL (symbol
)->function
;
693 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
694 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
696 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
697 Fput (symbol
, Qautoload
, XCDR (function
));
699 XSYMBOL (symbol
)->function
= definition
;
700 /* Handle automatic advice activation */
701 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
703 call2 (Qad_activate_internal
, symbol
, Qnil
);
704 definition
= XSYMBOL (symbol
)->function
;
709 extern Lisp_Object Qfunction_documentation
;
711 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
712 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
713 Associates the function with the current load file, if any.
714 The optional third argument DOCSTRING specifies the documentation string
715 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
716 determined by DEFINITION. */)
717 (symbol
, definition
, docstring
)
718 register Lisp_Object symbol
, definition
, docstring
;
720 CHECK_SYMBOL (symbol
);
721 if (CONSP (XSYMBOL (symbol
)->function
)
722 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
723 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
724 definition
= Ffset (symbol
, definition
);
725 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
726 if (!NILP (docstring
))
727 Fput (symbol
, Qfunction_documentation
, docstring
);
731 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
732 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
734 register Lisp_Object symbol
, newplist
;
736 CHECK_SYMBOL (symbol
);
737 XSYMBOL (symbol
)->plist
= newplist
;
741 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
742 doc
: /* Return minimum and maximum number of args allowed for SUBR.
743 SUBR must be a built-in function.
744 The returned value is a pair (MIN . MAX). MIN is the minimum number
745 of args. MAX is the maximum number or the symbol `many', for a
746 function with `&rest' args, or `unevalled' for a special form. */)
750 short minargs
, maxargs
;
752 minargs
= XSUBR (subr
)->min_args
;
753 maxargs
= XSUBR (subr
)->max_args
;
755 return Fcons (make_number (minargs
), Qmany
);
756 else if (maxargs
== UNEVALLED
)
757 return Fcons (make_number (minargs
), Qunevalled
);
759 return Fcons (make_number (minargs
), make_number (maxargs
));
762 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
763 doc
: /* Return name of subroutine SUBR.
764 SUBR must be a built-in function. */)
770 name
= XSUBR (subr
)->symbol_name
;
771 return make_string (name
, strlen (name
));
774 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
775 doc
: /* Return the interactive form of CMD or nil if none.
776 If CMD is not a command, the return value is nil.
777 Value, if non-nil, is a list \(interactive SPEC). */)
781 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
783 if (NILP (fun
) || EQ (fun
, Qunbound
))
786 /* Use an `interactive-form' property if present, analogous to the
787 function-documentation property. */
789 while (SYMBOLP (fun
))
791 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
795 fun
= Fsymbol_function (fun
);
800 char *spec
= XSUBR (fun
)->intspec
;
802 return list2 (Qinteractive
,
803 (*spec
!= '(') ? build_string (spec
) :
804 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
806 else if (COMPILEDP (fun
))
808 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
809 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
811 else if (CONSP (fun
))
813 Lisp_Object funcar
= XCAR (fun
);
814 if (EQ (funcar
, Qlambda
))
815 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
816 else if (EQ (funcar
, Qautoload
))
820 do_autoload (fun
, cmd
);
822 return Finteractive_form (cmd
);
829 /***********************************************************************
830 Getting and Setting Values of Symbols
831 ***********************************************************************/
833 /* Return the symbol holding SYMBOL's value. Signal
834 `cyclic-variable-indirection' if SYMBOL's chain of variable
835 indirections contains a loop. */
838 indirect_variable (struct Lisp_Symbol
*symbol
)
840 struct Lisp_Symbol
*tortoise
, *hare
;
842 hare
= tortoise
= symbol
;
844 while (hare
->redirect
== SYMBOL_VARALIAS
)
846 hare
= SYMBOL_ALIAS (hare
);
847 if (hare
->redirect
!= SYMBOL_VARALIAS
)
850 hare
= SYMBOL_ALIAS (hare
);
851 tortoise
= SYMBOL_ALIAS (tortoise
);
853 if (hare
== tortoise
)
856 XSETSYMBOL (tem
, symbol
);
857 xsignal1 (Qcyclic_variable_indirection
, tem
);
865 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
866 doc
: /* Return the variable at the end of OBJECT's variable chain.
867 If OBJECT is a symbol, follow all variable indirections and return the final
868 variable. If OBJECT is not a symbol, just return it.
869 Signal a cyclic-variable-indirection error if there is a loop in the
870 variable chain of symbols. */)
874 if (SYMBOLP (object
))
875 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
880 /* Given the raw contents of a symbol value cell,
881 return the Lisp value of the symbol.
882 This does not handle buffer-local variables; use
883 swap_in_symval_forwarding for that. */
885 #define do_blv_forwarding(blv) \
886 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
889 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
891 register Lisp_Object val
;
892 switch (XFWDTYPE (valcontents
))
895 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
899 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
902 return *XOBJFWD (valcontents
)->objvar
;
904 case Lisp_Fwd_Buffer_Obj
:
905 return PER_BUFFER_VALUE (current_buffer
,
906 XBUFFER_OBJFWD (valcontents
)->offset
);
908 case Lisp_Fwd_Kboard_Obj
:
909 /* We used to simply use current_kboard here, but from Lisp
910 code, it's value is often unexpected. It seems nicer to
911 allow constructions like this to work as intuitively expected:
913 (with-selected-frame frame
914 (define-key local-function-map "\eOP" [f1]))
916 On the other hand, this affects the semantics of
917 last-command and real-last-command, and people may rely on
918 that. I took a quick look at the Lisp codebase, and I
919 don't think anything will break. --lorentey */
920 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
921 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
926 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
927 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
928 buffer-independent contents of the value cell: forwarded just one
929 step past the buffer-localness.
931 BUF non-zero means set the value in buffer BUF instead of the
932 current buffer. This only plays a role for per-buffer variables. */
934 #define store_blv_forwarding(blv, newval, buf) \
936 if ((blv)->forwarded) \
937 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
939 SET_BLV_VALUE (blv, newval); \
943 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
944 /* struct Lisp_Symbol *symbol; */
949 switch (XFWDTYPE (valcontents
))
952 CHECK_NUMBER (newval
);
953 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
957 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
961 *XOBJFWD (valcontents
)->objvar
= newval
;
963 /* If this variable is a default for something stored
964 in the buffer itself, such as default-fill-column,
965 find the buffers that don't have local values for it
967 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
968 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
970 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
971 - (char *) &buffer_defaults
);
972 int idx
= PER_BUFFER_IDX (offset
);
979 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
984 buf
= Fcdr (XCAR (tail
));
985 if (!BUFFERP (buf
)) continue;
988 if (! PER_BUFFER_VALUE_P (b
, idx
))
989 PER_BUFFER_VALUE (b
, offset
) = newval
;
994 case Lisp_Fwd_Buffer_Obj
:
996 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
997 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
999 if (!(NILP (type
) || NILP (newval
)
1000 || (XINT (type
) == LISP_INT_TAG
1002 : XTYPE (newval
) == XINT (type
))))
1003 buffer_slot_type_mismatch (newval
, XINT (type
));
1006 buf
= current_buffer
;
1007 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1011 case Lisp_Fwd_Kboard_Obj
:
1013 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1014 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1015 *(Lisp_Object
*) p
= newval
;
1020 abort (); /* goto def; */
1024 /* Set up SYMBOL to refer to its global binding.
1025 This makes it safe to alter the status of other bindings. */
1028 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
1030 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1032 /* Unload the previously loaded binding. */
1034 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1036 /* Select the global binding in the symbol. */
1037 blv
->valcell
= blv
->defcell
;
1039 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1041 /* Indicate that the global binding is set up now. */
1043 SET_BLV_FOUND (blv
, 0);
1046 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1047 VALCONTENTS is the contents of its value cell,
1048 which points to a struct Lisp_Buffer_Local_Value.
1050 Return the value forwarded one step past the buffer-local stage.
1051 This could be another forwarding pointer. */
1054 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1056 register Lisp_Object tem1
;
1058 eassert (blv
== SYMBOL_BLV (symbol
));
1063 || (blv
->frame_local
1064 ? !EQ (selected_frame
, tem1
)
1065 : current_buffer
!= XBUFFER (tem1
)))
1068 /* Unload the previously loaded binding. */
1069 tem1
= blv
->valcell
;
1071 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1072 /* Choose the new binding. */
1075 XSETSYMBOL (var
, symbol
);
1076 if (blv
->frame_local
)
1078 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1079 blv
->where
= selected_frame
;
1083 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1084 XSETBUFFER (blv
->where
, current_buffer
);
1087 if (!(blv
->found
= !NILP (tem1
)))
1088 tem1
= blv
->defcell
;
1090 /* Load the new binding. */
1091 blv
->valcell
= tem1
;
1093 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1097 /* Find the value of a symbol, returning Qunbound if it's not bound.
1098 This is helpful for code which just wants to get a variable's value
1099 if it has one, without signaling an error.
1100 Note that it must not be possible to quit
1101 within this function. Great care is required for this. */
1104 find_symbol_value (Lisp_Object symbol
)
1106 struct Lisp_Symbol
*sym
;
1108 CHECK_SYMBOL (symbol
);
1109 sym
= XSYMBOL (symbol
);
1112 switch (sym
->redirect
)
1114 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1115 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1116 case SYMBOL_LOCALIZED
:
1118 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1119 swap_in_symval_forwarding (sym
, blv
);
1120 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1123 case SYMBOL_FORWARDED
:
1124 return do_symval_forwarding (SYMBOL_FWD (sym
));
1129 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1130 doc
: /* Return SYMBOL's value. Error if that is void. */)
1136 val
= find_symbol_value (symbol
);
1137 if (!EQ (val
, Qunbound
))
1140 xsignal1 (Qvoid_variable
, symbol
);
1143 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1144 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1146 register Lisp_Object symbol
, newval
;
1148 set_internal (symbol
, newval
, Qnil
, 0);
1152 /* Return 1 if SYMBOL currently has a let-binding
1153 which was made in the buffer that is now current. */
1156 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1158 struct specbinding
*p
;
1160 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1162 && CONSP (p
->symbol
))
1164 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1165 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1166 if (symbol
== let_bound_symbol
1167 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1171 return p
>= specpdl
;
1175 let_shadows_global_binding_p (Lisp_Object symbol
)
1177 struct specbinding
*p
;
1179 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1180 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1183 return p
>= specpdl
;
1186 /* Store the value NEWVAL into SYMBOL.
1187 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1188 (nil stands for the current buffer/frame).
1190 If BINDFLAG is zero, then if this symbol is supposed to become
1191 local in every buffer where it is set, then we make it local.
1192 If BINDFLAG is nonzero, we don't do that. */
1195 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1197 int voide
= EQ (newval
, Qunbound
);
1198 struct Lisp_Symbol
*sym
;
1201 /* If restoring in a dead buffer, do nothing. */
1202 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1205 CHECK_SYMBOL (symbol
);
1206 if (SYMBOL_CONSTANT_P (symbol
))
1208 if (NILP (Fkeywordp (symbol
))
1209 || !EQ (newval
, Fsymbol_value (symbol
)))
1210 xsignal1 (Qsetting_constant
, symbol
);
1212 /* Allow setting keywords to their own value. */
1216 sym
= XSYMBOL (symbol
);
1219 switch (sym
->redirect
)
1221 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1222 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1223 case SYMBOL_LOCALIZED
:
1225 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1228 if (blv
->frame_local
)
1229 where
= selected_frame
;
1231 XSETBUFFER (where
, current_buffer
);
1233 /* If the current buffer is not the buffer whose binding is
1234 loaded, or if there may be frame-local bindings and the frame
1235 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1236 the default binding is loaded, the loaded binding may be the
1238 if (!EQ (blv
->where
, where
)
1239 /* Also unload a global binding (if the var is local_if_set). */
1240 || (EQ (blv
->valcell
, blv
->defcell
)))
1242 /* The currently loaded binding is not necessarily valid.
1243 We need to unload it, and choose a new binding. */
1245 /* Write out `realvalue' to the old loaded binding. */
1247 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1249 /* Find the new binding. */
1250 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1251 tem1
= Fassq (symbol
,
1253 ? XFRAME (where
)->param_alist
1254 : XBUFFER (where
)->local_var_alist
));
1260 /* This buffer still sees the default value. */
1262 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1263 or if this is `let' rather than `set',
1264 make CURRENT-ALIST-ELEMENT point to itself,
1265 indicating that we're seeing the default value.
1266 Likewise if the variable has been let-bound
1267 in the current buffer. */
1268 if (bindflag
|| !blv
->local_if_set
1269 || let_shadows_buffer_binding_p (sym
))
1272 tem1
= blv
->defcell
;
1274 /* If it's a local_if_set, being set not bound,
1275 and we're not within a let that was made for this buffer,
1276 create a new buffer-local binding for the variable.
1277 That means, give this buffer a new assoc for a local value
1278 and load that binding. */
1281 /* local_if_set is only supported for buffer-local
1282 bindings, not for frame-local bindings. */
1283 eassert (!blv
->frame_local
);
1284 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1285 XBUFFER (where
)->local_var_alist
1286 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1290 /* Record which binding is now loaded. */
1291 blv
->valcell
= tem1
;
1294 /* Store the new value in the cons cell. */
1295 SET_BLV_VALUE (blv
, newval
);
1300 /* If storing void (making the symbol void), forward only through
1301 buffer-local indicator, not through Lisp_Objfwd, etc. */
1304 store_symval_forwarding (blv
->fwd
, newval
,
1306 ? XBUFFER (where
) : current_buffer
);
1310 case SYMBOL_FORWARDED
:
1313 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1314 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1315 if (BUFFER_OBJFWDP (innercontents
))
1317 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1318 int idx
= PER_BUFFER_IDX (offset
);
1321 && !let_shadows_buffer_binding_p (sym
))
1322 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1326 { /* If storing void (making the symbol void), forward only through
1327 buffer-local indicator, not through Lisp_Objfwd, etc. */
1328 sym
->redirect
= SYMBOL_PLAINVAL
;
1329 SET_SYMBOL_VAL (sym
, newval
);
1332 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1340 /* Access or set a buffer-local symbol's default value. */
1342 /* Return the default value of SYMBOL, but don't check for voidness.
1343 Return Qunbound if it is void. */
1346 default_value (Lisp_Object symbol
)
1348 struct Lisp_Symbol
*sym
;
1350 CHECK_SYMBOL (symbol
);
1351 sym
= XSYMBOL (symbol
);
1354 switch (sym
->redirect
)
1356 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1357 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1358 case SYMBOL_LOCALIZED
:
1360 /* If var is set up for a buffer that lacks a local value for it,
1361 the current value is nominally the default value.
1362 But the `realvalue' slot may be more up to date, since
1363 ordinary setq stores just that slot. So use that. */
1364 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1365 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1366 return do_symval_forwarding (blv
->fwd
);
1368 return XCDR (blv
->defcell
);
1370 case SYMBOL_FORWARDED
:
1372 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1374 /* For a built-in buffer-local variable, get the default value
1375 rather than letting do_symval_forwarding get the current value. */
1376 if (BUFFER_OBJFWDP (valcontents
))
1378 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1379 if (PER_BUFFER_IDX (offset
) != 0)
1380 return PER_BUFFER_DEFAULT (offset
);
1383 /* For other variables, get the current value. */
1384 return do_symval_forwarding (valcontents
);
1390 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1391 doc
: /* Return t if SYMBOL has a non-void default value.
1392 This is the value that is seen in buffers that do not have their own values
1393 for this variable. */)
1397 register Lisp_Object value
;
1399 value
= default_value (symbol
);
1400 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1403 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1404 doc
: /* Return SYMBOL's default value.
1405 This is the value that is seen in buffers that do not have their own values
1406 for this variable. The default value is meaningful for variables with
1407 local bindings in certain buffers. */)
1411 register Lisp_Object value
;
1413 value
= default_value (symbol
);
1414 if (!EQ (value
, Qunbound
))
1417 xsignal1 (Qvoid_variable
, symbol
);
1420 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1421 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1422 The default value is seen in buffers that do not have their own values
1423 for this variable. */)
1425 Lisp_Object symbol
, value
;
1427 struct Lisp_Symbol
*sym
;
1429 CHECK_SYMBOL (symbol
);
1430 if (SYMBOL_CONSTANT_P (symbol
))
1432 if (NILP (Fkeywordp (symbol
))
1433 || !EQ (value
, Fdefault_value (symbol
)))
1434 xsignal1 (Qsetting_constant
, symbol
);
1436 /* Allow setting keywords to their own value. */
1439 sym
= XSYMBOL (symbol
);
1442 switch (sym
->redirect
)
1444 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1445 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1446 case SYMBOL_LOCALIZED
:
1448 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1450 /* Store new value into the DEFAULT-VALUE slot. */
1451 XSETCDR (blv
->defcell
, value
);
1453 /* If the default binding is now loaded, set the REALVALUE slot too. */
1454 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1455 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1458 case SYMBOL_FORWARDED
:
1460 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1462 /* Handle variables like case-fold-search that have special slots
1464 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1465 if (BUFFER_OBJFWDP (valcontents
))
1467 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1468 int idx
= PER_BUFFER_IDX (offset
);
1470 PER_BUFFER_DEFAULT (offset
) = value
;
1472 /* If this variable is not always local in all buffers,
1473 set it in the buffers that don't nominally have a local value. */
1478 for (b
= all_buffers
; b
; b
= b
->next
)
1479 if (!PER_BUFFER_VALUE_P (b
, idx
))
1480 PER_BUFFER_VALUE (b
, offset
) = value
;
1485 return Fset (symbol
, value
);
1491 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1492 doc
: /* Set the default value of variable VAR to VALUE.
1493 VAR, the variable name, is literal (not evaluated);
1494 VALUE is an expression: it is evaluated and its value returned.
1495 The default value of a variable is seen in buffers
1496 that do not have their own values for the variable.
1498 More generally, you can use multiple variables and values, as in
1499 (setq-default VAR VALUE VAR VALUE...)
1500 This sets each VAR's default value to the corresponding VALUE.
1501 The VALUE for the Nth VAR can refer to the new default values
1503 usage: (setq-default [VAR VALUE]...) */)
1507 register Lisp_Object args_left
;
1508 register Lisp_Object val
, symbol
;
1509 struct gcpro gcpro1
;
1519 val
= Feval (Fcar (Fcdr (args_left
)));
1520 symbol
= XCAR (args_left
);
1521 Fset_default (symbol
, val
);
1522 args_left
= Fcdr (XCDR (args_left
));
1524 while (!NILP (args_left
));
1530 /* Lisp functions for creating and removing buffer-local variables. */
1535 union Lisp_Fwd
*fwd
;
1538 static struct Lisp_Buffer_Local_Value
*
1539 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1541 struct Lisp_Buffer_Local_Value
*blv
1542 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1546 XSETSYMBOL (symbol
, sym
);
1547 tem
= Fcons (symbol
, (forwarded
1548 ? do_symval_forwarding (valcontents
.fwd
)
1549 : valcontents
.value
));
1551 /* Buffer_Local_Values cannot have as realval a buffer-local
1552 or keyboard-local forwarding. */
1553 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1554 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1555 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1557 blv
->frame_local
= 0;
1558 blv
->local_if_set
= 0;
1561 SET_BLV_FOUND (blv
, 0);
1565 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1566 1, 1, "vMake Variable Buffer Local: ",
1567 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1568 At any time, the value for the current buffer is in effect,
1569 unless the variable has never been set in this buffer,
1570 in which case the default value is in effect.
1571 Note that binding the variable with `let', or setting it while
1572 a `let'-style binding made in this buffer is in effect,
1573 does not make the variable buffer-local. Return VARIABLE.
1575 In most cases it is better to use `make-local-variable',
1576 which makes a variable local in just one buffer.
1578 The function `default-value' gets the default value and `set-default' sets it. */)
1580 register Lisp_Object variable
;
1582 struct Lisp_Symbol
*sym
;
1583 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1584 union Lisp_Val_Fwd valcontents
;
1587 CHECK_SYMBOL (variable
);
1588 sym
= XSYMBOL (variable
);
1591 switch (sym
->redirect
)
1593 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1594 case SYMBOL_PLAINVAL
:
1595 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1596 if (EQ (valcontents
.value
, Qunbound
))
1597 valcontents
.value
= Qnil
;
1599 case SYMBOL_LOCALIZED
:
1600 blv
= SYMBOL_BLV (sym
);
1601 if (blv
->frame_local
)
1602 error ("Symbol %s may not be buffer-local",
1603 SDATA (SYMBOL_NAME (variable
)));
1605 case SYMBOL_FORWARDED
:
1606 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1607 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1608 error ("Symbol %s may not be buffer-local",
1609 SDATA (SYMBOL_NAME (variable
)));
1610 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1617 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1621 blv
= make_blv (sym
, forwarded
, valcontents
);
1622 sym
->redirect
= SYMBOL_LOCALIZED
;
1623 SET_SYMBOL_BLV (sym
, blv
);
1626 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1627 if (let_shadows_global_binding_p (symbol
))
1628 message ("Making %s buffer-local while let-bound!",
1629 SDATA (SYMBOL_NAME (variable
)));
1633 blv
->local_if_set
= 1;
1637 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1638 1, 1, "vMake Local Variable: ",
1639 doc
: /* Make VARIABLE have a separate value in the current buffer.
1640 Other buffers will continue to share a common default value.
1641 \(The buffer-local value of VARIABLE starts out as the same value
1642 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1645 If the variable is already arranged to become local when set,
1646 this function causes a local value to exist for this buffer,
1647 just as setting the variable would do.
1649 This function returns VARIABLE, and therefore
1650 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1653 See also `make-variable-buffer-local'.
1655 Do not use `make-local-variable' to make a hook variable buffer-local.
1656 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1658 register Lisp_Object variable
;
1660 register Lisp_Object tem
;
1662 union Lisp_Val_Fwd valcontents
;
1663 struct Lisp_Symbol
*sym
;
1664 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1666 CHECK_SYMBOL (variable
);
1667 sym
= XSYMBOL (variable
);
1670 switch (sym
->redirect
)
1672 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1673 case SYMBOL_PLAINVAL
:
1674 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1675 case SYMBOL_LOCALIZED
:
1676 blv
= SYMBOL_BLV (sym
);
1677 if (blv
->frame_local
)
1678 error ("Symbol %s may not be buffer-local",
1679 SDATA (SYMBOL_NAME (variable
)));
1681 case SYMBOL_FORWARDED
:
1682 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1683 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1684 error ("Symbol %s may not be buffer-local",
1685 SDATA (SYMBOL_NAME (variable
)));
1691 error ("Symbol %s may not be buffer-local",
1692 SDATA (SYMBOL_NAME (variable
)));
1694 if (blv
? blv
->local_if_set
1695 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1697 tem
= Fboundp (variable
);
1698 /* Make sure the symbol has a local value in this particular buffer,
1699 by setting it to the same value it already has. */
1700 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1705 blv
= make_blv (sym
, forwarded
, valcontents
);
1706 sym
->redirect
= SYMBOL_LOCALIZED
;
1707 SET_SYMBOL_BLV (sym
, blv
);
1710 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1711 if (let_shadows_global_binding_p (symbol
))
1712 message ("Making %s local to %s while let-bound!",
1713 SDATA (SYMBOL_NAME (variable
)),
1714 SDATA (current_buffer
->name
));
1718 /* Make sure this buffer has its own value of symbol. */
1719 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1720 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1723 if (let_shadows_buffer_binding_p (sym
))
1724 message ("Making %s buffer-local while locally let-bound!",
1725 SDATA (SYMBOL_NAME (variable
)));
1727 /* Swap out any local binding for some other buffer, and make
1728 sure the current value is permanently recorded, if it's the
1730 find_symbol_value (variable
);
1732 current_buffer
->local_var_alist
1733 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1734 current_buffer
->local_var_alist
);
1736 /* Make sure symbol does not think it is set up for this buffer;
1737 force it to look once again for this buffer's value. */
1738 if (current_buffer
== XBUFFER (blv
->where
))
1740 /* blv->valcell = blv->defcell;
1741 * SET_BLV_FOUND (blv, 0); */
1745 /* If the symbol forwards into a C variable, then load the binding
1746 for this buffer now. If C code modifies the variable before we
1747 load the binding in, then that new value will clobber the default
1748 binding the next time we unload it. */
1750 swap_in_symval_forwarding (sym
, blv
);
1755 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1756 1, 1, "vKill Local Variable: ",
1757 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1758 From now on the default value will apply in this buffer. Return VARIABLE. */)
1760 register Lisp_Object variable
;
1762 register Lisp_Object tem
;
1763 struct Lisp_Buffer_Local_Value
*blv
;
1764 struct Lisp_Symbol
*sym
;
1766 CHECK_SYMBOL (variable
);
1767 sym
= XSYMBOL (variable
);
1770 switch (sym
->redirect
)
1772 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1773 case SYMBOL_PLAINVAL
: return variable
;
1774 case SYMBOL_FORWARDED
:
1776 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1777 if (BUFFER_OBJFWDP (valcontents
))
1779 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1780 int idx
= PER_BUFFER_IDX (offset
);
1784 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1785 PER_BUFFER_VALUE (current_buffer
, offset
)
1786 = PER_BUFFER_DEFAULT (offset
);
1791 case SYMBOL_LOCALIZED
:
1792 blv
= SYMBOL_BLV (sym
);
1793 if (blv
->frame_local
)
1799 /* Get rid of this buffer's alist element, if any. */
1800 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1801 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1803 current_buffer
->local_var_alist
1804 = Fdelq (tem
, current_buffer
->local_var_alist
);
1806 /* If the symbol is set up with the current buffer's binding
1807 loaded, recompute its value. We have to do it now, or else
1808 forwarded objects won't work right. */
1810 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1811 if (EQ (buf
, blv
->where
))
1814 /* blv->valcell = blv->defcell;
1815 * SET_BLV_FOUND (blv, 0); */
1817 find_symbol_value (variable
);
1824 /* Lisp functions for creating and removing buffer-local variables. */
1826 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1827 when/if this is removed. */
1829 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1830 1, 1, "vMake Variable Frame Local: ",
1831 doc
: /* Enable VARIABLE to have frame-local bindings.
1832 This does not create any frame-local bindings for VARIABLE,
1833 it just makes them possible.
1835 A frame-local binding is actually a frame parameter value.
1836 If a frame F has a value for the frame parameter named VARIABLE,
1837 that also acts as a frame-local binding for VARIABLE in F--
1838 provided this function has been called to enable VARIABLE
1839 to have frame-local bindings at all.
1841 The only way to create a frame-local binding for VARIABLE in a frame
1842 is to set the VARIABLE frame parameter of that frame. See
1843 `modify-frame-parameters' for how to set frame parameters.
1845 Note that since Emacs 23.1, variables cannot be both buffer-local and
1846 frame-local any more (buffer-local bindings used to take precedence over
1847 frame-local bindings). */)
1849 register Lisp_Object variable
;
1852 union Lisp_Val_Fwd valcontents
;
1853 struct Lisp_Symbol
*sym
;
1854 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1856 CHECK_SYMBOL (variable
);
1857 sym
= XSYMBOL (variable
);
1860 switch (sym
->redirect
)
1862 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1863 case SYMBOL_PLAINVAL
:
1864 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1865 if (EQ (valcontents
.value
, Qunbound
))
1866 valcontents
.value
= Qnil
;
1868 case SYMBOL_LOCALIZED
:
1869 if (SYMBOL_BLV (sym
)->frame_local
)
1872 error ("Symbol %s may not be frame-local",
1873 SDATA (SYMBOL_NAME (variable
)));
1874 case SYMBOL_FORWARDED
:
1875 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1876 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1877 error ("Symbol %s may not be frame-local",
1878 SDATA (SYMBOL_NAME (variable
)));
1884 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1886 blv
= make_blv (sym
, forwarded
, valcontents
);
1887 blv
->frame_local
= 1;
1888 sym
->redirect
= SYMBOL_LOCALIZED
;
1889 SET_SYMBOL_BLV (sym
, blv
);
1892 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1893 if (let_shadows_global_binding_p (symbol
))
1894 message ("Making %s frame-local while let-bound!",
1895 SDATA (SYMBOL_NAME (variable
)));
1900 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1902 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1903 BUFFER defaults to the current buffer. */)
1905 register Lisp_Object variable
, buffer
;
1907 register struct buffer
*buf
;
1908 struct Lisp_Symbol
*sym
;
1911 buf
= current_buffer
;
1914 CHECK_BUFFER (buffer
);
1915 buf
= XBUFFER (buffer
);
1918 CHECK_SYMBOL (variable
);
1919 sym
= XSYMBOL (variable
);
1922 switch (sym
->redirect
)
1924 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1925 case SYMBOL_PLAINVAL
: return Qnil
;
1926 case SYMBOL_LOCALIZED
:
1928 Lisp_Object tail
, elt
, tmp
;
1929 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1930 XSETBUFFER (tmp
, buf
);
1932 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1935 if (EQ (variable
, XCAR (elt
)))
1937 eassert (!blv
->frame_local
);
1938 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1942 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1945 case SYMBOL_FORWARDED
:
1947 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1948 if (BUFFER_OBJFWDP (valcontents
))
1950 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1951 int idx
= PER_BUFFER_IDX (offset
);
1952 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1961 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1963 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1964 More precisely, this means that setting the variable \(with `set' or`setq'),
1965 while it does not have a `let'-style binding that was made in BUFFER,
1966 will produce a buffer local binding. See Info node
1967 `(elisp)Creating Buffer-Local'.
1968 BUFFER defaults to the current buffer. */)
1970 register Lisp_Object variable
, buffer
;
1972 struct Lisp_Symbol
*sym
;
1974 CHECK_SYMBOL (variable
);
1975 sym
= XSYMBOL (variable
);
1978 switch (sym
->redirect
)
1980 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1981 case SYMBOL_PLAINVAL
: return Qnil
;
1982 case SYMBOL_LOCALIZED
:
1984 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1985 if (blv
->local_if_set
)
1987 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1988 return Flocal_variable_p (variable
, buffer
);
1990 case SYMBOL_FORWARDED
:
1991 /* All BUFFER_OBJFWD slots become local if they are set. */
1992 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1997 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1999 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2000 If the current binding is buffer-local, the value is the current buffer.
2001 If the current binding is frame-local, the value is the selected frame.
2002 If the current binding is global (the default), the value is nil. */)
2004 register Lisp_Object variable
;
2006 struct Lisp_Symbol
*sym
;
2008 CHECK_SYMBOL (variable
);
2009 sym
= XSYMBOL (variable
);
2011 /* Make sure the current binding is actually swapped in. */
2012 find_symbol_value (variable
);
2015 switch (sym
->redirect
)
2017 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2018 case SYMBOL_PLAINVAL
: return Qnil
;
2019 case SYMBOL_FORWARDED
:
2021 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2022 if (KBOARD_OBJFWDP (valcontents
))
2023 return Fframe_terminal (Fselected_frame ());
2024 else if (!BUFFER_OBJFWDP (valcontents
))
2028 case SYMBOL_LOCALIZED
:
2029 /* For a local variable, record both the symbol and which
2030 buffer's or frame's value we are saving. */
2031 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2032 return Fcurrent_buffer ();
2033 else if (sym
->redirect
== SYMBOL_LOCALIZED
2034 && BLV_FOUND (SYMBOL_BLV (sym
)))
2035 return SYMBOL_BLV (sym
)->where
;
2042 /* This code is disabled now that we use the selected frame to return
2043 keyboard-local-values. */
2045 extern struct terminal
*get_terminal (Lisp_Object display
, int);
2047 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2048 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2049 If SYMBOL is not a terminal-local variable, then return its normal
2050 value, like `symbol-value'.
2052 TERMINAL may be a terminal object, a frame, or nil (meaning the
2053 selected frame's terminal device). */)
2056 Lisp_Object terminal
;
2059 struct terminal
*t
= get_terminal (terminal
, 1);
2060 push_kboard (t
->kboard
);
2061 result
= Fsymbol_value (symbol
);
2066 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2067 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2068 If VARIABLE is not a terminal-local variable, then set its normal
2069 binding, like `set'.
2071 TERMINAL may be a terminal object, a frame, or nil (meaning the
2072 selected frame's terminal device). */)
2073 (symbol
, terminal
, value
)
2075 Lisp_Object terminal
;
2079 struct terminal
*t
= get_terminal (terminal
, 1);
2080 push_kboard (d
->kboard
);
2081 result
= Fset (symbol
, value
);
2087 /* Find the function at the end of a chain of symbol function indirections. */
2089 /* If OBJECT is a symbol, find the end of its function chain and
2090 return the value found there. If OBJECT is not a symbol, just
2091 return it. If there is a cycle in the function chain, signal a
2092 cyclic-function-indirection error.
2094 This is like Findirect_function, except that it doesn't signal an
2095 error if the chain ends up unbound. */
2097 indirect_function (register Lisp_Object object
)
2099 Lisp_Object tortoise
, hare
;
2101 hare
= tortoise
= object
;
2105 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2107 hare
= XSYMBOL (hare
)->function
;
2108 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2110 hare
= XSYMBOL (hare
)->function
;
2112 tortoise
= XSYMBOL (tortoise
)->function
;
2114 if (EQ (hare
, tortoise
))
2115 xsignal1 (Qcyclic_function_indirection
, object
);
2121 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2122 doc
: /* Return the function at the end of OBJECT's function chain.
2123 If OBJECT is not a symbol, just return it. Otherwise, follow all
2124 function indirections to find the final function binding and return it.
2125 If the final symbol in the chain is unbound, signal a void-function error.
2126 Optional arg NOERROR non-nil means to return nil instead of signalling.
2127 Signal a cyclic-function-indirection error if there is a loop in the
2128 function chain of symbols. */)
2130 register Lisp_Object object
;
2131 Lisp_Object noerror
;
2135 /* Optimize for no indirection. */
2137 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2138 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2139 result
= indirect_function (result
);
2140 if (!EQ (result
, Qunbound
))
2144 xsignal1 (Qvoid_function
, object
);
2149 /* Extract and set vector and string elements */
2151 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2152 doc
: /* Return the element of ARRAY at index IDX.
2153 ARRAY may be a vector, a string, a char-table, a bool-vector,
2154 or a byte-code object. IDX starts at 0. */)
2156 register Lisp_Object array
;
2159 register int idxval
;
2162 idxval
= XINT (idx
);
2163 if (STRINGP (array
))
2167 if (idxval
< 0 || idxval
>= SCHARS (array
))
2168 args_out_of_range (array
, idx
);
2169 if (! STRING_MULTIBYTE (array
))
2170 return make_number ((unsigned char) SREF (array
, idxval
));
2171 idxval_byte
= string_char_to_byte (array
, idxval
);
2173 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2174 return make_number (c
);
2176 else if (BOOL_VECTOR_P (array
))
2180 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2181 args_out_of_range (array
, idx
);
2183 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2184 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2186 else if (CHAR_TABLE_P (array
))
2188 CHECK_CHARACTER (idx
);
2189 return CHAR_TABLE_REF (array
, idxval
);
2194 if (VECTORP (array
))
2195 size
= XVECTOR (array
)->size
;
2196 else if (COMPILEDP (array
))
2197 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2199 wrong_type_argument (Qarrayp
, array
);
2201 if (idxval
< 0 || idxval
>= size
)
2202 args_out_of_range (array
, idx
);
2203 return XVECTOR (array
)->contents
[idxval
];
2207 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2208 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2209 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2210 bool-vector. IDX starts at 0. */)
2211 (array
, idx
, newelt
)
2212 register Lisp_Object array
;
2213 Lisp_Object idx
, newelt
;
2215 register int idxval
;
2218 idxval
= XINT (idx
);
2219 CHECK_ARRAY (array
, Qarrayp
);
2220 CHECK_IMPURE (array
);
2222 if (VECTORP (array
))
2224 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2225 args_out_of_range (array
, idx
);
2226 XVECTOR (array
)->contents
[idxval
] = newelt
;
2228 else if (BOOL_VECTOR_P (array
))
2232 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2233 args_out_of_range (array
, idx
);
2235 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2237 if (! NILP (newelt
))
2238 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2240 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2241 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2243 else if (CHAR_TABLE_P (array
))
2245 CHECK_CHARACTER (idx
);
2246 CHAR_TABLE_SET (array
, idxval
, newelt
);
2248 else if (STRING_MULTIBYTE (array
))
2250 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2251 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2253 if (idxval
< 0 || idxval
>= SCHARS (array
))
2254 args_out_of_range (array
, idx
);
2255 CHECK_CHARACTER (newelt
);
2257 nbytes
= SBYTES (array
);
2259 idxval_byte
= string_char_to_byte (array
, idxval
);
2260 p1
= SDATA (array
) + idxval_byte
;
2261 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2262 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2263 if (prev_bytes
!= new_bytes
)
2265 /* We must relocate the string data. */
2266 int nchars
= SCHARS (array
);
2270 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2271 bcopy (SDATA (array
), str
, nbytes
);
2272 allocate_string_data (XSTRING (array
), nchars
,
2273 nbytes
+ new_bytes
- prev_bytes
);
2274 bcopy (str
, SDATA (array
), idxval_byte
);
2275 p1
= SDATA (array
) + idxval_byte
;
2276 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2277 nbytes
- (idxval_byte
+ prev_bytes
));
2279 clear_string_char_byte_cache ();
2286 if (idxval
< 0 || idxval
>= SCHARS (array
))
2287 args_out_of_range (array
, idx
);
2288 CHECK_NUMBER (newelt
);
2290 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2294 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2295 if (SREF (array
, i
) >= 0x80)
2296 args_out_of_range (array
, newelt
);
2297 /* ARRAY is an ASCII string. Convert it to a multibyte
2298 string, and try `aset' again. */
2299 STRING_SET_MULTIBYTE (array
);
2300 return Faset (array
, idx
, newelt
);
2302 SSET (array
, idxval
, XINT (newelt
));
2308 /* Arithmetic functions */
2310 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2313 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2315 double f1
= 0, f2
= 0;
2318 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2319 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2321 if (FLOATP (num1
) || FLOATP (num2
))
2324 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2325 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2331 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2336 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2341 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2346 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2351 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2356 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2365 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2366 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2368 register Lisp_Object num1
, num2
;
2370 return arithcompare (num1
, num2
, equal
);
2373 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2374 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2376 register Lisp_Object num1
, num2
;
2378 return arithcompare (num1
, num2
, less
);
2381 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2382 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2384 register Lisp_Object num1
, num2
;
2386 return arithcompare (num1
, num2
, grtr
);
2389 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2390 doc
: /* Return t if first arg is less than or equal to second arg.
2391 Both must be numbers or markers. */)
2393 register Lisp_Object num1
, num2
;
2395 return arithcompare (num1
, num2
, less_or_equal
);
2398 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2399 doc
: /* Return t if first arg is greater than or equal to second arg.
2400 Both must be numbers or markers. */)
2402 register Lisp_Object num1
, num2
;
2404 return arithcompare (num1
, num2
, grtr_or_equal
);
2407 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2408 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2410 register Lisp_Object num1
, num2
;
2412 return arithcompare (num1
, num2
, notequal
);
2415 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2416 doc
: /* Return t if NUMBER is zero. */)
2418 register Lisp_Object number
;
2420 CHECK_NUMBER_OR_FLOAT (number
);
2422 if (FLOATP (number
))
2424 if (XFLOAT_DATA (number
) == 0.0)
2434 /* Convert between long values and pairs of Lisp integers.
2435 Note that long_to_cons returns a single Lisp integer
2436 when the value fits in one. */
2439 long_to_cons (long unsigned int i
)
2441 unsigned long top
= i
>> 16;
2442 unsigned int bot
= i
& 0xFFFF;
2444 return make_number (bot
);
2445 if (top
== (unsigned long)-1 >> 16)
2446 return Fcons (make_number (-1), make_number (bot
));
2447 return Fcons (make_number (top
), make_number (bot
));
2451 cons_to_long (Lisp_Object c
)
2453 Lisp_Object top
, bot
;
2460 return ((XINT (top
) << 16) | XINT (bot
));
2463 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2464 doc
: /* Return the decimal representation of NUMBER as a string.
2465 Uses a minus sign if negative.
2466 NUMBER may be an integer or a floating point number. */)
2470 char buffer
[VALBITS
];
2472 CHECK_NUMBER_OR_FLOAT (number
);
2474 if (FLOATP (number
))
2476 char pigbuf
[350]; /* see comments in float_to_string */
2478 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2479 return build_string (pigbuf
);
2482 if (sizeof (int) == sizeof (EMACS_INT
))
2483 sprintf (buffer
, "%d", (int) XINT (number
));
2484 else if (sizeof (long) == sizeof (EMACS_INT
))
2485 sprintf (buffer
, "%ld", (long) XINT (number
));
2488 return build_string (buffer
);
2492 digit_to_number (int character
, int base
)
2496 if (character
>= '0' && character
<= '9')
2497 digit
= character
- '0';
2498 else if (character
>= 'a' && character
<= 'z')
2499 digit
= character
- 'a' + 10;
2500 else if (character
>= 'A' && character
<= 'Z')
2501 digit
= character
- 'A' + 10;
2511 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2512 doc
: /* Parse STRING as a decimal number and return the number.
2513 This parses both integers and floating point numbers.
2514 It ignores leading spaces and tabs, and all trailing chars.
2516 If BASE, interpret STRING as a number in that base. If BASE isn't
2517 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2518 If the base used is not 10, STRING is always parsed as integer. */)
2520 register Lisp_Object string
, base
;
2522 register unsigned char *p
;
2527 CHECK_STRING (string
);
2533 CHECK_NUMBER (base
);
2535 if (b
< 2 || b
> 16)
2536 xsignal1 (Qargs_out_of_range
, base
);
2539 /* Skip any whitespace at the front of the number. Some versions of
2540 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2542 while (*p
== ' ' || *p
== '\t')
2553 if (isfloat_string (p
, 1) && b
== 10)
2554 val
= make_float (sign
* atof (p
));
2561 int digit
= digit_to_number (*p
++, b
);
2567 val
= make_fixnum_or_float (sign
* v
);
2587 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2588 int, Lisp_Object
*);
2589 extern Lisp_Object
fmod_float ();
2592 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2594 register Lisp_Object val
;
2595 register int argnum
;
2596 register EMACS_INT accum
= 0;
2597 register EMACS_INT next
;
2599 switch (SWITCH_ENUM_CAST (code
))
2617 for (argnum
= 0; argnum
< nargs
; argnum
++)
2619 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2621 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2624 return float_arith_driver ((double) accum
, argnum
, code
,
2627 next
= XINT (args
[argnum
]);
2628 switch (SWITCH_ENUM_CAST (code
))
2634 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2645 xsignal0 (Qarith_error
);
2659 if (!argnum
|| next
> accum
)
2663 if (!argnum
|| next
< accum
)
2669 XSETINT (val
, accum
);
2674 #define isnan(x) ((x) != (x))
2677 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2679 register Lisp_Object val
;
2682 for (; argnum
< nargs
; argnum
++)
2684 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2685 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2689 next
= XFLOAT_DATA (val
);
2693 args
[argnum
] = val
; /* runs into a compiler bug. */
2694 next
= XINT (args
[argnum
]);
2696 switch (SWITCH_ENUM_CAST (code
))
2702 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2712 if (! IEEE_FLOATING_POINT
&& next
== 0)
2713 xsignal0 (Qarith_error
);
2720 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2722 if (!argnum
|| isnan (next
) || next
> accum
)
2726 if (!argnum
|| isnan (next
) || next
< accum
)
2732 return make_float (accum
);
2736 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2737 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2738 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2743 return arith_driver (Aadd
, nargs
, args
);
2746 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2747 doc
: /* Negate number or subtract numbers or markers and return the result.
2748 With one arg, negates it. With more than one arg,
2749 subtracts all but the first from the first.
2750 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2755 return arith_driver (Asub
, nargs
, args
);
2758 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2759 doc
: /* Return product of any number of arguments, which are numbers or markers.
2760 usage: (* &rest NUMBERS-OR-MARKERS) */)
2765 return arith_driver (Amult
, nargs
, args
);
2768 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2769 doc
: /* Return first argument divided by all the remaining arguments.
2770 The arguments must be numbers or markers.
2771 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2777 for (argnum
= 2; argnum
< nargs
; argnum
++)
2778 if (FLOATP (args
[argnum
]))
2779 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2780 return arith_driver (Adiv
, nargs
, args
);
2783 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2784 doc
: /* Return remainder of X divided by Y.
2785 Both must be integers or markers. */)
2787 register Lisp_Object x
, y
;
2791 CHECK_NUMBER_COERCE_MARKER (x
);
2792 CHECK_NUMBER_COERCE_MARKER (y
);
2794 if (XFASTINT (y
) == 0)
2795 xsignal0 (Qarith_error
);
2797 XSETINT (val
, XINT (x
) % XINT (y
));
2811 /* If the magnitude of the result exceeds that of the divisor, or
2812 the sign of the result does not agree with that of the dividend,
2813 iterate with the reduced value. This does not yield a
2814 particularly accurate result, but at least it will be in the
2815 range promised by fmod. */
2817 r
-= f2
* floor (r
/ f2
);
2818 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2822 #endif /* ! HAVE_FMOD */
2824 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2825 doc
: /* Return X modulo Y.
2826 The result falls between zero (inclusive) and Y (exclusive).
2827 Both X and Y must be numbers or markers. */)
2829 register Lisp_Object x
, y
;
2834 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2835 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2837 if (FLOATP (x
) || FLOATP (y
))
2838 return fmod_float (x
, y
);
2844 xsignal0 (Qarith_error
);
2848 /* If the "remainder" comes out with the wrong sign, fix it. */
2849 if (i2
< 0 ? i1
> 0 : i1
< 0)
2856 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2857 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2858 The value is always a number; markers are converted to numbers.
2859 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2864 return arith_driver (Amax
, nargs
, args
);
2867 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2868 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2869 The value is always a number; markers are converted to numbers.
2870 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2875 return arith_driver (Amin
, nargs
, args
);
2878 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2879 doc
: /* Return bitwise-and of all the arguments.
2880 Arguments may be integers, or markers converted to integers.
2881 usage: (logand &rest INTS-OR-MARKERS) */)
2886 return arith_driver (Alogand
, nargs
, args
);
2889 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2890 doc
: /* Return bitwise-or of all the arguments.
2891 Arguments may be integers, or markers converted to integers.
2892 usage: (logior &rest INTS-OR-MARKERS) */)
2897 return arith_driver (Alogior
, nargs
, args
);
2900 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2901 doc
: /* Return bitwise-exclusive-or of all the arguments.
2902 Arguments may be integers, or markers converted to integers.
2903 usage: (logxor &rest INTS-OR-MARKERS) */)
2908 return arith_driver (Alogxor
, nargs
, args
);
2911 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2912 doc
: /* Return VALUE with its bits shifted left by COUNT.
2913 If COUNT is negative, shifting is actually to the right.
2914 In this case, the sign bit is duplicated. */)
2916 register Lisp_Object value
, count
;
2918 register Lisp_Object val
;
2920 CHECK_NUMBER (value
);
2921 CHECK_NUMBER (count
);
2923 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2925 else if (XINT (count
) > 0)
2926 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2927 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2928 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2930 XSETINT (val
, XINT (value
) >> -XINT (count
));
2934 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2935 doc
: /* Return VALUE with its bits shifted left by COUNT.
2936 If COUNT is negative, shifting is actually to the right.
2937 In this case, zeros are shifted in on the left. */)
2939 register Lisp_Object value
, count
;
2941 register Lisp_Object val
;
2943 CHECK_NUMBER (value
);
2944 CHECK_NUMBER (count
);
2946 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2948 else if (XINT (count
) > 0)
2949 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2950 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2953 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2957 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2958 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2959 Markers are converted to integers. */)
2961 register Lisp_Object number
;
2963 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2965 if (FLOATP (number
))
2966 return (make_float (1.0 + XFLOAT_DATA (number
)));
2968 XSETINT (number
, XINT (number
) + 1);
2972 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2973 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2974 Markers are converted to integers. */)
2976 register Lisp_Object number
;
2978 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2980 if (FLOATP (number
))
2981 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2983 XSETINT (number
, XINT (number
) - 1);
2987 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2988 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2990 register Lisp_Object number
;
2992 CHECK_NUMBER (number
);
2993 XSETINT (number
, ~XINT (number
));
2997 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2998 doc
: /* Return the byteorder for the machine.
2999 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3000 lowercase l) for small endian machines. */)
3003 unsigned i
= 0x04030201;
3004 int order
= *(char *)&i
== 1 ? 108 : 66;
3006 return make_number (order
);
3014 Lisp_Object error_tail
, arith_tail
;
3016 Qquote
= intern_c_string ("quote");
3017 Qlambda
= intern_c_string ("lambda");
3018 Qsubr
= intern_c_string ("subr");
3019 Qerror_conditions
= intern_c_string ("error-conditions");
3020 Qerror_message
= intern_c_string ("error-message");
3021 Qtop_level
= intern_c_string ("top-level");
3023 Qerror
= intern_c_string ("error");
3024 Qquit
= intern_c_string ("quit");
3025 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3026 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3027 Qvoid_function
= intern_c_string ("void-function");
3028 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3029 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3030 Qvoid_variable
= intern_c_string ("void-variable");
3031 Qsetting_constant
= intern_c_string ("setting-constant");
3032 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3034 Qinvalid_function
= intern_c_string ("invalid-function");
3035 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3036 Qno_catch
= intern_c_string ("no-catch");
3037 Qend_of_file
= intern_c_string ("end-of-file");
3038 Qarith_error
= intern_c_string ("arith-error");
3039 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3040 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3041 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3042 Qtext_read_only
= intern_c_string ("text-read-only");
3043 Qmark_inactive
= intern_c_string ("mark-inactive");
3045 Qlistp
= intern_c_string ("listp");
3046 Qconsp
= intern_c_string ("consp");
3047 Qsymbolp
= intern_c_string ("symbolp");
3048 Qkeywordp
= intern_c_string ("keywordp");
3049 Qintegerp
= intern_c_string ("integerp");
3050 Qnatnump
= intern_c_string ("natnump");
3051 Qwholenump
= intern_c_string ("wholenump");
3052 Qstringp
= intern_c_string ("stringp");
3053 Qarrayp
= intern_c_string ("arrayp");
3054 Qsequencep
= intern_c_string ("sequencep");
3055 Qbufferp
= intern_c_string ("bufferp");
3056 Qvectorp
= intern_c_string ("vectorp");
3057 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3058 Qmarkerp
= intern_c_string ("markerp");
3059 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3060 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3061 Qboundp
= intern_c_string ("boundp");
3062 Qfboundp
= intern_c_string ("fboundp");
3064 Qfloatp
= intern_c_string ("floatp");
3065 Qnumberp
= intern_c_string ("numberp");
3066 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3068 Qchar_table_p
= intern_c_string ("char-table-p");
3069 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3071 Qsubrp
= intern_c_string ("subrp");
3072 Qunevalled
= intern_c_string ("unevalled");
3073 Qmany
= intern_c_string ("many");
3075 Qcdr
= intern_c_string ("cdr");
3077 /* Handle automatic advice activation */
3078 Qad_advice_info
= intern_c_string ("ad-advice-info");
3079 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3081 error_tail
= pure_cons (Qerror
, Qnil
);
3083 /* ERROR is used as a signaler for random errors for which nothing else is right */
3085 Fput (Qerror
, Qerror_conditions
,
3087 Fput (Qerror
, Qerror_message
,
3088 make_pure_c_string ("error"));
3090 Fput (Qquit
, Qerror_conditions
,
3091 pure_cons (Qquit
, Qnil
));
3092 Fput (Qquit
, Qerror_message
,
3093 make_pure_c_string ("Quit"));
3095 Fput (Qwrong_type_argument
, Qerror_conditions
,
3096 pure_cons (Qwrong_type_argument
, error_tail
));
3097 Fput (Qwrong_type_argument
, Qerror_message
,
3098 make_pure_c_string ("Wrong type argument"));
3100 Fput (Qargs_out_of_range
, Qerror_conditions
,
3101 pure_cons (Qargs_out_of_range
, error_tail
));
3102 Fput (Qargs_out_of_range
, Qerror_message
,
3103 make_pure_c_string ("Args out of range"));
3105 Fput (Qvoid_function
, Qerror_conditions
,
3106 pure_cons (Qvoid_function
, error_tail
));
3107 Fput (Qvoid_function
, Qerror_message
,
3108 make_pure_c_string ("Symbol's function definition is void"));
3110 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3111 pure_cons (Qcyclic_function_indirection
, error_tail
));
3112 Fput (Qcyclic_function_indirection
, Qerror_message
,
3113 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3115 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3116 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3117 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3118 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3120 Qcircular_list
= intern_c_string ("circular-list");
3121 staticpro (&Qcircular_list
);
3122 Fput (Qcircular_list
, Qerror_conditions
,
3123 pure_cons (Qcircular_list
, error_tail
));
3124 Fput (Qcircular_list
, Qerror_message
,
3125 make_pure_c_string ("List contains a loop"));
3127 Fput (Qvoid_variable
, Qerror_conditions
,
3128 pure_cons (Qvoid_variable
, error_tail
));
3129 Fput (Qvoid_variable
, Qerror_message
,
3130 make_pure_c_string ("Symbol's value as variable is void"));
3132 Fput (Qsetting_constant
, Qerror_conditions
,
3133 pure_cons (Qsetting_constant
, error_tail
));
3134 Fput (Qsetting_constant
, Qerror_message
,
3135 make_pure_c_string ("Attempt to set a constant symbol"));
3137 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3138 pure_cons (Qinvalid_read_syntax
, error_tail
));
3139 Fput (Qinvalid_read_syntax
, Qerror_message
,
3140 make_pure_c_string ("Invalid read syntax"));
3142 Fput (Qinvalid_function
, Qerror_conditions
,
3143 pure_cons (Qinvalid_function
, error_tail
));
3144 Fput (Qinvalid_function
, Qerror_message
,
3145 make_pure_c_string ("Invalid function"));
3147 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3148 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3149 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3150 make_pure_c_string ("Wrong number of arguments"));
3152 Fput (Qno_catch
, Qerror_conditions
,
3153 pure_cons (Qno_catch
, error_tail
));
3154 Fput (Qno_catch
, Qerror_message
,
3155 make_pure_c_string ("No catch for tag"));
3157 Fput (Qend_of_file
, Qerror_conditions
,
3158 pure_cons (Qend_of_file
, error_tail
));
3159 Fput (Qend_of_file
, Qerror_message
,
3160 make_pure_c_string ("End of file during parsing"));
3162 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3163 Fput (Qarith_error
, Qerror_conditions
,
3165 Fput (Qarith_error
, Qerror_message
,
3166 make_pure_c_string ("Arithmetic error"));
3168 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3169 pure_cons (Qbeginning_of_buffer
, error_tail
));
3170 Fput (Qbeginning_of_buffer
, Qerror_message
,
3171 make_pure_c_string ("Beginning of buffer"));
3173 Fput (Qend_of_buffer
, Qerror_conditions
,
3174 pure_cons (Qend_of_buffer
, error_tail
));
3175 Fput (Qend_of_buffer
, Qerror_message
,
3176 make_pure_c_string ("End of buffer"));
3178 Fput (Qbuffer_read_only
, Qerror_conditions
,
3179 pure_cons (Qbuffer_read_only
, error_tail
));
3180 Fput (Qbuffer_read_only
, Qerror_message
,
3181 make_pure_c_string ("Buffer is read-only"));
3183 Fput (Qtext_read_only
, Qerror_conditions
,
3184 pure_cons (Qtext_read_only
, error_tail
));
3185 Fput (Qtext_read_only
, Qerror_message
,
3186 make_pure_c_string ("Text is read-only"));
3188 Qrange_error
= intern_c_string ("range-error");
3189 Qdomain_error
= intern_c_string ("domain-error");
3190 Qsingularity_error
= intern_c_string ("singularity-error");
3191 Qoverflow_error
= intern_c_string ("overflow-error");
3192 Qunderflow_error
= intern_c_string ("underflow-error");
3194 Fput (Qdomain_error
, Qerror_conditions
,
3195 pure_cons (Qdomain_error
, arith_tail
));
3196 Fput (Qdomain_error
, Qerror_message
,
3197 make_pure_c_string ("Arithmetic domain error"));
3199 Fput (Qrange_error
, Qerror_conditions
,
3200 pure_cons (Qrange_error
, arith_tail
));
3201 Fput (Qrange_error
, Qerror_message
,
3202 make_pure_c_string ("Arithmetic range error"));
3204 Fput (Qsingularity_error
, Qerror_conditions
,
3205 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3206 Fput (Qsingularity_error
, Qerror_message
,
3207 make_pure_c_string ("Arithmetic singularity error"));
3209 Fput (Qoverflow_error
, Qerror_conditions
,
3210 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3211 Fput (Qoverflow_error
, Qerror_message
,
3212 make_pure_c_string ("Arithmetic overflow error"));
3214 Fput (Qunderflow_error
, Qerror_conditions
,
3215 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3216 Fput (Qunderflow_error
, Qerror_message
,
3217 make_pure_c_string ("Arithmetic underflow error"));
3219 staticpro (&Qrange_error
);
3220 staticpro (&Qdomain_error
);
3221 staticpro (&Qsingularity_error
);
3222 staticpro (&Qoverflow_error
);
3223 staticpro (&Qunderflow_error
);
3227 staticpro (&Qquote
);
3228 staticpro (&Qlambda
);
3230 staticpro (&Qunbound
);
3231 staticpro (&Qerror_conditions
);
3232 staticpro (&Qerror_message
);
3233 staticpro (&Qtop_level
);
3235 staticpro (&Qerror
);
3237 staticpro (&Qwrong_type_argument
);
3238 staticpro (&Qargs_out_of_range
);
3239 staticpro (&Qvoid_function
);
3240 staticpro (&Qcyclic_function_indirection
);
3241 staticpro (&Qcyclic_variable_indirection
);
3242 staticpro (&Qvoid_variable
);
3243 staticpro (&Qsetting_constant
);
3244 staticpro (&Qinvalid_read_syntax
);
3245 staticpro (&Qwrong_number_of_arguments
);
3246 staticpro (&Qinvalid_function
);
3247 staticpro (&Qno_catch
);
3248 staticpro (&Qend_of_file
);
3249 staticpro (&Qarith_error
);
3250 staticpro (&Qbeginning_of_buffer
);
3251 staticpro (&Qend_of_buffer
);
3252 staticpro (&Qbuffer_read_only
);
3253 staticpro (&Qtext_read_only
);
3254 staticpro (&Qmark_inactive
);
3256 staticpro (&Qlistp
);
3257 staticpro (&Qconsp
);
3258 staticpro (&Qsymbolp
);
3259 staticpro (&Qkeywordp
);
3260 staticpro (&Qintegerp
);
3261 staticpro (&Qnatnump
);
3262 staticpro (&Qwholenump
);
3263 staticpro (&Qstringp
);
3264 staticpro (&Qarrayp
);
3265 staticpro (&Qsequencep
);
3266 staticpro (&Qbufferp
);
3267 staticpro (&Qvectorp
);
3268 staticpro (&Qchar_or_string_p
);
3269 staticpro (&Qmarkerp
);
3270 staticpro (&Qbuffer_or_string_p
);
3271 staticpro (&Qinteger_or_marker_p
);
3272 staticpro (&Qfloatp
);
3273 staticpro (&Qnumberp
);
3274 staticpro (&Qnumber_or_marker_p
);
3275 staticpro (&Qchar_table_p
);
3276 staticpro (&Qvector_or_char_table_p
);
3277 staticpro (&Qsubrp
);
3279 staticpro (&Qunevalled
);
3281 staticpro (&Qboundp
);
3282 staticpro (&Qfboundp
);
3284 staticpro (&Qad_advice_info
);
3285 staticpro (&Qad_activate_internal
);
3287 /* Types that type-of returns. */
3288 Qinteger
= intern_c_string ("integer");
3289 Qsymbol
= intern_c_string ("symbol");
3290 Qstring
= intern_c_string ("string");
3291 Qcons
= intern_c_string ("cons");
3292 Qmarker
= intern_c_string ("marker");
3293 Qoverlay
= intern_c_string ("overlay");
3294 Qfloat
= intern_c_string ("float");
3295 Qwindow_configuration
= intern_c_string ("window-configuration");
3296 Qprocess
= intern_c_string ("process");
3297 Qwindow
= intern_c_string ("window");
3298 /* Qsubr = intern_c_string ("subr"); */
3299 Qcompiled_function
= intern_c_string ("compiled-function");
3300 Qbuffer
= intern_c_string ("buffer");
3301 Qframe
= intern_c_string ("frame");
3302 Qvector
= intern_c_string ("vector");
3303 Qchar_table
= intern_c_string ("char-table");
3304 Qbool_vector
= intern_c_string ("bool-vector");
3305 Qhash_table
= intern_c_string ("hash-table");
3307 DEFSYM (Qfont_spec
, "font-spec");
3308 DEFSYM (Qfont_entity
, "font-entity");
3309 DEFSYM (Qfont_object
, "font-object");
3311 DEFSYM (Qinteractive_form
, "interactive-form");
3313 staticpro (&Qinteger
);
3314 staticpro (&Qsymbol
);
3315 staticpro (&Qstring
);
3317 staticpro (&Qmarker
);
3318 staticpro (&Qoverlay
);
3319 staticpro (&Qfloat
);
3320 staticpro (&Qwindow_configuration
);
3321 staticpro (&Qprocess
);
3322 staticpro (&Qwindow
);
3323 /* staticpro (&Qsubr); */
3324 staticpro (&Qcompiled_function
);
3325 staticpro (&Qbuffer
);
3326 staticpro (&Qframe
);
3327 staticpro (&Qvector
);
3328 staticpro (&Qchar_table
);
3329 staticpro (&Qbool_vector
);
3330 staticpro (&Qhash_table
);
3332 defsubr (&Sindirect_variable
);
3333 defsubr (&Sinteractive_form
);
3336 defsubr (&Stype_of
);
3341 defsubr (&Sintegerp
);
3342 defsubr (&Sinteger_or_marker_p
);
3343 defsubr (&Snumberp
);
3344 defsubr (&Snumber_or_marker_p
);
3346 defsubr (&Snatnump
);
3347 defsubr (&Ssymbolp
);
3348 defsubr (&Skeywordp
);
3349 defsubr (&Sstringp
);
3350 defsubr (&Smultibyte_string_p
);
3351 defsubr (&Svectorp
);
3352 defsubr (&Schar_table_p
);
3353 defsubr (&Svector_or_char_table_p
);
3354 defsubr (&Sbool_vector_p
);
3356 defsubr (&Ssequencep
);
3357 defsubr (&Sbufferp
);
3358 defsubr (&Smarkerp
);
3360 defsubr (&Sbyte_code_function_p
);
3361 defsubr (&Schar_or_string_p
);
3364 defsubr (&Scar_safe
);
3365 defsubr (&Scdr_safe
);
3368 defsubr (&Ssymbol_function
);
3369 defsubr (&Sindirect_function
);
3370 defsubr (&Ssymbol_plist
);
3371 defsubr (&Ssymbol_name
);
3372 defsubr (&Smakunbound
);
3373 defsubr (&Sfmakunbound
);
3375 defsubr (&Sfboundp
);
3377 defsubr (&Sdefalias
);
3378 defsubr (&Ssetplist
);
3379 defsubr (&Ssymbol_value
);
3381 defsubr (&Sdefault_boundp
);
3382 defsubr (&Sdefault_value
);
3383 defsubr (&Sset_default
);
3384 defsubr (&Ssetq_default
);
3385 defsubr (&Smake_variable_buffer_local
);
3386 defsubr (&Smake_local_variable
);
3387 defsubr (&Skill_local_variable
);
3388 defsubr (&Smake_variable_frame_local
);
3389 defsubr (&Slocal_variable_p
);
3390 defsubr (&Slocal_variable_if_set_p
);
3391 defsubr (&Svariable_binding_locus
);
3392 #if 0 /* XXX Remove this. --lorentey */
3393 defsubr (&Sterminal_local_value
);
3394 defsubr (&Sset_terminal_local_value
);
3398 defsubr (&Snumber_to_string
);
3399 defsubr (&Sstring_to_number
);
3400 defsubr (&Seqlsign
);
3423 defsubr (&Sbyteorder
);
3424 defsubr (&Ssubr_arity
);
3425 defsubr (&Ssubr_name
);
3427 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3429 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3430 doc
: /* The largest value that is representable in a Lisp integer. */);
3431 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3432 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3434 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3435 doc
: /* The smallest value that is representable in a Lisp integer. */);
3436 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3437 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3441 arith_error (int signo
)
3443 sigsetmask (SIGEMPTYMASK
);
3445 SIGNAL_THREAD_CHECK (signo
);
3446 xsignal0 (Qarith_error
);
3452 /* Don't do this if just dumping out.
3453 We don't want to call `signal' in this case
3454 so that we don't have trouble with dumping
3455 signal-delivering routines in an inconsistent state. */
3459 #endif /* CANNOT_DUMP */
3460 signal (SIGFPE
, arith_error
);
3463 signal (SIGEMT
, arith_error
);
3467 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3468 (do not change this comment) */