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
, Qfunction_vector
, 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 (FUNVECP (object
))
223 if (FUNVEC_COMPILED_P (object
))
224 return Qcompiled_function
;
226 return Qfunction_vector
;
227 if (BUFFERP (object
))
229 if (CHAR_TABLE_P (object
))
231 if (BOOL_VECTOR_P (object
))
235 if (HASH_TABLE_P (object
))
237 if (FONT_SPEC_P (object
))
239 if (FONT_ENTITY_P (object
))
241 if (FONT_OBJECT_P (object
))
253 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
254 doc
: /* Return t if OBJECT is a cons cell. */)
263 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
264 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
273 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
274 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
275 Otherwise, return nil. */)
279 if (CONSP (object
) || NILP (object
))
284 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
285 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
289 if (CONSP (object
) || NILP (object
))
294 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
295 doc
: /* Return t if OBJECT is a symbol. */)
299 if (SYMBOLP (object
))
304 /* Define this in C to avoid unnecessarily consing up the symbol
306 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is a keyword.
308 This means that it is a symbol with a print name beginning with `:'
309 interned in the initial obarray. */)
314 && SREF (SYMBOL_NAME (object
), 0) == ':'
315 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
320 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a vector. */)
325 if (VECTORP (object
))
330 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
331 doc
: /* Return t if OBJECT is a string. */)
335 if (STRINGP (object
))
340 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
342 doc
: /* Return t if OBJECT is a multibyte string. */)
346 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
351 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a char-table. */)
356 if (CHAR_TABLE_P (object
))
361 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
362 Svector_or_char_table_p
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is a char-table or vector. */)
367 if (VECTORP (object
) || CHAR_TABLE_P (object
))
372 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
373 doc
: /* Return t if OBJECT is a bool-vector. */)
377 if (BOOL_VECTOR_P (object
))
382 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
383 doc
: /* Return t if OBJECT is an array (string or vector). */)
392 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
393 doc
: /* Return t if OBJECT is a sequence (list or array). */)
395 register Lisp_Object object
;
397 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
402 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
403 doc
: /* Return t if OBJECT is an editor buffer. */)
407 if (BUFFERP (object
))
412 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
413 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
417 if (MARKERP (object
))
422 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
423 doc
: /* Return t if OBJECT is a built-in function. */)
432 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
434 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
438 if (COMPILEDP (object
))
443 DEFUN ("funvecp", Ffunvecp
, Sfunvecp
, 1, 1, 0,
444 doc
: /* Return t if OBJECT is a `function vector' object. */)
448 return FUNVECP (object
) ? Qt
: Qnil
;
451 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
452 doc
: /* Return t if OBJECT is a character or a string. */)
454 register Lisp_Object object
;
456 if (CHARACTERP (object
) || STRINGP (object
))
461 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
462 doc
: /* Return t if OBJECT is an integer. */)
466 if (INTEGERP (object
))
471 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
472 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
474 register Lisp_Object object
;
476 if (MARKERP (object
) || INTEGERP (object
))
481 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
482 doc
: /* Return t if OBJECT is a nonnegative integer. */)
486 if (NATNUMP (object
))
491 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
492 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
496 if (NUMBERP (object
))
502 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
503 Snumber_or_marker_p
, 1, 1, 0,
504 doc
: /* Return t if OBJECT is a number or a marker. */)
508 if (NUMBERP (object
) || MARKERP (object
))
513 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
514 doc
: /* Return t if OBJECT is a floating point number. */)
524 /* Extract and set components of lists */
526 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
527 doc
: /* Return the car of LIST. If arg is nil, return nil.
528 Error if arg is not nil and not a cons cell. See also `car-safe'.
530 See Info node `(elisp)Cons Cells' for a discussion of related basic
531 Lisp concepts such as car, cdr, cons cell and list. */)
533 register Lisp_Object list
;
538 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
539 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
543 return CAR_SAFE (object
);
546 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
547 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
548 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
550 See Info node `(elisp)Cons Cells' for a discussion of related basic
551 Lisp concepts such as cdr, car, cons cell and list. */)
553 register Lisp_Object list
;
558 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
559 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
563 return CDR_SAFE (object
);
566 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
567 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
569 register Lisp_Object cell
, newcar
;
573 XSETCAR (cell
, newcar
);
577 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
578 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
580 register Lisp_Object cell
, newcdr
;
584 XSETCDR (cell
, newcdr
);
588 /* Extract and set components of symbols */
590 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
591 doc
: /* Return t if SYMBOL's value is not void. */)
593 register Lisp_Object symbol
;
595 Lisp_Object valcontents
;
596 struct Lisp_Symbol
*sym
;
597 CHECK_SYMBOL (symbol
);
598 sym
= XSYMBOL (symbol
);
601 switch (sym
->redirect
)
603 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
604 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
605 case SYMBOL_LOCALIZED
:
607 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
609 /* In set_internal, we un-forward vars when their value is
614 swap_in_symval_forwarding (sym
, blv
);
615 valcontents
= BLV_VALUE (blv
);
619 case SYMBOL_FORWARDED
:
620 /* In set_internal, we un-forward vars when their value is
626 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
629 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
630 doc
: /* Return t if SYMBOL's function definition is not void. */)
632 register Lisp_Object symbol
;
634 CHECK_SYMBOL (symbol
);
635 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
638 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
639 doc
: /* Make SYMBOL's value be void.
642 register Lisp_Object symbol
;
644 CHECK_SYMBOL (symbol
);
645 if (SYMBOL_CONSTANT_P (symbol
))
646 xsignal1 (Qsetting_constant
, symbol
);
647 Fset (symbol
, Qunbound
);
651 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
652 doc
: /* Make SYMBOL's function definition be void.
655 register Lisp_Object symbol
;
657 CHECK_SYMBOL (symbol
);
658 if (NILP (symbol
) || EQ (symbol
, Qt
))
659 xsignal1 (Qsetting_constant
, symbol
);
660 XSYMBOL (symbol
)->function
= Qunbound
;
664 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
665 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
667 register Lisp_Object symbol
;
669 CHECK_SYMBOL (symbol
);
670 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
671 return XSYMBOL (symbol
)->function
;
672 xsignal1 (Qvoid_function
, symbol
);
675 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
676 doc
: /* Return SYMBOL's property list. */)
678 register Lisp_Object symbol
;
680 CHECK_SYMBOL (symbol
);
681 return XSYMBOL (symbol
)->plist
;
684 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
685 doc
: /* Return SYMBOL's name, a string. */)
687 register Lisp_Object symbol
;
689 register Lisp_Object name
;
691 CHECK_SYMBOL (symbol
);
692 name
= SYMBOL_NAME (symbol
);
696 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
697 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
699 register Lisp_Object symbol
, definition
;
701 register Lisp_Object function
;
703 CHECK_SYMBOL (symbol
);
704 if (NILP (symbol
) || EQ (symbol
, Qt
))
705 xsignal1 (Qsetting_constant
, symbol
);
707 function
= XSYMBOL (symbol
)->function
;
709 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
710 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
712 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
713 Fput (symbol
, Qautoload
, XCDR (function
));
715 XSYMBOL (symbol
)->function
= definition
;
716 /* Handle automatic advice activation */
717 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
719 call2 (Qad_activate_internal
, symbol
, Qnil
);
720 definition
= XSYMBOL (symbol
)->function
;
725 extern Lisp_Object Qfunction_documentation
;
727 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
728 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
729 Associates the function with the current load file, if any.
730 The optional third argument DOCSTRING specifies the documentation string
731 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
732 determined by DEFINITION. */)
733 (symbol
, definition
, docstring
)
734 register Lisp_Object symbol
, definition
, docstring
;
736 CHECK_SYMBOL (symbol
);
737 if (CONSP (XSYMBOL (symbol
)->function
)
738 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
739 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
740 definition
= Ffset (symbol
, definition
);
741 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
742 if (!NILP (docstring
))
743 Fput (symbol
, Qfunction_documentation
, docstring
);
747 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
748 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
750 register Lisp_Object symbol
, newplist
;
752 CHECK_SYMBOL (symbol
);
753 XSYMBOL (symbol
)->plist
= newplist
;
757 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
758 doc
: /* Return minimum and maximum number of args allowed for SUBR.
759 SUBR must be a built-in function.
760 The returned value is a pair (MIN . MAX). MIN is the minimum number
761 of args. MAX is the maximum number or the symbol `many', for a
762 function with `&rest' args, or `unevalled' for a special form. */)
766 short minargs
, maxargs
;
768 minargs
= XSUBR (subr
)->min_args
;
769 maxargs
= XSUBR (subr
)->max_args
;
771 return Fcons (make_number (minargs
), Qmany
);
772 else if (maxargs
== UNEVALLED
)
773 return Fcons (make_number (minargs
), Qunevalled
);
775 return Fcons (make_number (minargs
), make_number (maxargs
));
778 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
779 doc
: /* Return name of subroutine SUBR.
780 SUBR must be a built-in function. */)
786 name
= XSUBR (subr
)->symbol_name
;
787 return make_string (name
, strlen (name
));
790 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
791 doc
: /* Return the interactive form of CMD or nil if none.
792 If CMD is not a command, the return value is nil.
793 Value, if non-nil, is a list \(interactive SPEC). */)
797 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
799 if (NILP (fun
) || EQ (fun
, Qunbound
))
802 /* Use an `interactive-form' property if present, analogous to the
803 function-documentation property. */
805 while (SYMBOLP (fun
))
807 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
811 fun
= Fsymbol_function (fun
);
816 char *spec
= XSUBR (fun
)->intspec
;
818 return list2 (Qinteractive
,
819 (*spec
!= '(') ? build_string (spec
) :
820 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
822 else if (COMPILEDP (fun
))
824 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
825 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
827 else if (CONSP (fun
))
829 Lisp_Object funcar
= XCAR (fun
);
830 if (EQ (funcar
, Qlambda
))
831 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
832 else if (EQ (funcar
, Qautoload
))
836 do_autoload (fun
, cmd
);
838 return Finteractive_form (cmd
);
845 /***********************************************************************
846 Getting and Setting Values of Symbols
847 ***********************************************************************/
849 /* Return the symbol holding SYMBOL's value. Signal
850 `cyclic-variable-indirection' if SYMBOL's chain of variable
851 indirections contains a loop. */
854 indirect_variable (symbol
)
855 struct Lisp_Symbol
*symbol
;
857 struct Lisp_Symbol
*tortoise
, *hare
;
859 hare
= tortoise
= symbol
;
861 while (hare
->redirect
== SYMBOL_VARALIAS
)
863 hare
= SYMBOL_ALIAS (hare
);
864 if (hare
->redirect
!= SYMBOL_VARALIAS
)
867 hare
= SYMBOL_ALIAS (hare
);
868 tortoise
= SYMBOL_ALIAS (tortoise
);
870 if (hare
== tortoise
)
873 XSETSYMBOL (tem
, symbol
);
874 xsignal1 (Qcyclic_variable_indirection
, tem
);
882 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
883 doc
: /* Return the variable at the end of OBJECT's variable chain.
884 If OBJECT is a symbol, follow all variable indirections and return the final
885 variable. If OBJECT is not a symbol, just return it.
886 Signal a cyclic-variable-indirection error if there is a loop in the
887 variable chain of symbols. */)
891 if (SYMBOLP (object
))
892 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
897 /* Given the raw contents of a symbol value cell,
898 return the Lisp value of the symbol.
899 This does not handle buffer-local variables; use
900 swap_in_symval_forwarding for that. */
902 #define do_blv_forwarding(blv) \
903 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
906 do_symval_forwarding (valcontents
)
907 register union Lisp_Fwd
*valcontents
;
909 register Lisp_Object val
;
910 switch (XFWDTYPE (valcontents
))
913 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
917 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
920 return *XOBJFWD (valcontents
)->objvar
;
922 case Lisp_Fwd_Buffer_Obj
:
923 return PER_BUFFER_VALUE (current_buffer
,
924 XBUFFER_OBJFWD (valcontents
)->offset
);
926 case Lisp_Fwd_Kboard_Obj
:
927 /* We used to simply use current_kboard here, but from Lisp
928 code, it's value is often unexpected. It seems nicer to
929 allow constructions like this to work as intuitively expected:
931 (with-selected-frame frame
932 (define-key local-function-map "\eOP" [f1]))
934 On the other hand, this affects the semantics of
935 last-command and real-last-command, and people may rely on
936 that. I took a quick look at the Lisp codebase, and I
937 don't think anything will break. --lorentey */
938 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
939 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
944 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
945 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
946 buffer-independent contents of the value cell: forwarded just one
947 step past the buffer-localness.
949 BUF non-zero means set the value in buffer BUF instead of the
950 current buffer. This only plays a role for per-buffer variables. */
952 #define store_blv_forwarding(blv, newval, buf) \
954 if ((blv)->forwarded) \
955 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
957 SET_BLV_VALUE (blv, newval); \
961 store_symval_forwarding (/* symbol, */ valcontents
, newval
, buf
)
962 /* struct Lisp_Symbol *symbol; */
963 union Lisp_Fwd
*valcontents
;
964 register Lisp_Object newval
;
967 switch (XFWDTYPE (valcontents
))
970 CHECK_NUMBER (newval
);
971 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
975 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
979 *XOBJFWD (valcontents
)->objvar
= newval
;
981 /* If this variable is a default for something stored
982 in the buffer itself, such as default-fill-column,
983 find the buffers that don't have local values for it
985 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
986 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
988 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
989 - (char *) &buffer_defaults
);
990 int idx
= PER_BUFFER_IDX (offset
);
997 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
1002 buf
= Fcdr (XCAR (tail
));
1003 if (!BUFFERP (buf
)) continue;
1006 if (! PER_BUFFER_VALUE_P (b
, idx
))
1007 PER_BUFFER_VALUE (b
, offset
) = newval
;
1012 case Lisp_Fwd_Buffer_Obj
:
1014 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1015 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1017 if (!(NILP (type
) || NILP (newval
)
1018 || (XINT (type
) == LISP_INT_TAG
1020 : XTYPE (newval
) == XINT (type
))))
1021 buffer_slot_type_mismatch (newval
, XINT (type
));
1024 buf
= current_buffer
;
1025 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1029 case Lisp_Fwd_Kboard_Obj
:
1031 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1032 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1033 *(Lisp_Object
*) p
= newval
;
1038 abort (); /* goto def; */
1042 /* Set up SYMBOL to refer to its global binding.
1043 This makes it safe to alter the status of other bindings. */
1046 swap_in_global_binding (symbol
)
1047 struct Lisp_Symbol
*symbol
;
1049 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1051 /* Unload the previously loaded binding. */
1053 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1055 /* Select the global binding in the symbol. */
1056 blv
->valcell
= blv
->defcell
;
1058 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1060 /* Indicate that the global binding is set up now. */
1062 SET_BLV_FOUND (blv
, 0);
1065 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1066 VALCONTENTS is the contents of its value cell,
1067 which points to a struct Lisp_Buffer_Local_Value.
1069 Return the value forwarded one step past the buffer-local stage.
1070 This could be another forwarding pointer. */
1073 swap_in_symval_forwarding (symbol
, blv
)
1074 struct Lisp_Symbol
*symbol
;
1075 struct Lisp_Buffer_Local_Value
*blv
;
1077 register Lisp_Object tem1
;
1079 eassert (blv
== SYMBOL_BLV (symbol
));
1084 || (blv
->frame_local
1085 ? !EQ (selected_frame
, tem1
)
1086 : current_buffer
!= XBUFFER (tem1
)))
1089 /* Unload the previously loaded binding. */
1090 tem1
= blv
->valcell
;
1092 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1093 /* Choose the new binding. */
1096 XSETSYMBOL (var
, symbol
);
1097 if (blv
->frame_local
)
1099 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1100 blv
->where
= selected_frame
;
1104 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1105 XSETBUFFER (blv
->where
, current_buffer
);
1108 if (!(blv
->found
= !NILP (tem1
)))
1109 tem1
= blv
->defcell
;
1111 /* Load the new binding. */
1112 blv
->valcell
= tem1
;
1114 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1118 /* Find the value of a symbol, returning Qunbound if it's not bound.
1119 This is helpful for code which just wants to get a variable's value
1120 if it has one, without signaling an error.
1121 Note that it must not be possible to quit
1122 within this function. Great care is required for this. */
1125 find_symbol_value (symbol
)
1128 struct Lisp_Symbol
*sym
;
1130 CHECK_SYMBOL (symbol
);
1131 sym
= XSYMBOL (symbol
);
1134 switch (sym
->redirect
)
1136 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1137 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1138 case SYMBOL_LOCALIZED
:
1140 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1141 swap_in_symval_forwarding (sym
, blv
);
1142 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1145 case SYMBOL_FORWARDED
:
1146 return do_symval_forwarding (SYMBOL_FWD (sym
));
1151 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1152 doc
: /* Return SYMBOL's value. Error if that is void. */)
1158 val
= find_symbol_value (symbol
);
1159 if (!EQ (val
, Qunbound
))
1162 xsignal1 (Qvoid_variable
, symbol
);
1165 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1166 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1168 register Lisp_Object symbol
, newval
;
1170 set_internal (symbol
, newval
, Qnil
, 0);
1174 /* Return 1 if SYMBOL currently has a let-binding
1175 which was made in the buffer that is now current. */
1178 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1180 struct specbinding
*p
;
1182 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1184 && CONSP (p
->symbol
))
1186 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1187 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1188 if (symbol
== let_bound_symbol
1189 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1193 return p
>= specpdl
;
1197 let_shadows_global_binding_p (symbol
)
1200 struct specbinding
*p
;
1202 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1203 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1206 return p
>= specpdl
;
1209 /* Store the value NEWVAL into SYMBOL.
1210 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1211 (nil stands for the current buffer/frame).
1213 If BINDFLAG is zero, then if this symbol is supposed to become
1214 local in every buffer where it is set, then we make it local.
1215 If BINDFLAG is nonzero, we don't do that. */
1218 set_internal (symbol
, newval
, where
, bindflag
)
1219 register Lisp_Object symbol
, newval
, where
;
1222 int voide
= EQ (newval
, Qunbound
);
1223 struct Lisp_Symbol
*sym
;
1226 /* If restoring in a dead buffer, do nothing. */
1227 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1230 CHECK_SYMBOL (symbol
);
1231 if (SYMBOL_CONSTANT_P (symbol
))
1233 if (NILP (Fkeywordp (symbol
))
1234 || !EQ (newval
, Fsymbol_value (symbol
)))
1235 xsignal1 (Qsetting_constant
, symbol
);
1237 /* Allow setting keywords to their own value. */
1241 sym
= XSYMBOL (symbol
);
1244 switch (sym
->redirect
)
1246 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1247 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1248 case SYMBOL_LOCALIZED
:
1250 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1253 if (blv
->frame_local
)
1254 where
= selected_frame
;
1256 XSETBUFFER (where
, current_buffer
);
1258 /* If the current buffer is not the buffer whose binding is
1259 loaded, or if there may be frame-local bindings and the frame
1260 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1261 the default binding is loaded, the loaded binding may be the
1263 if (!EQ (blv
->where
, where
)
1264 /* Also unload a global binding (if the var is local_if_set). */
1265 || (EQ (blv
->valcell
, blv
->defcell
)))
1267 /* The currently loaded binding is not necessarily valid.
1268 We need to unload it, and choose a new binding. */
1270 /* Write out `realvalue' to the old loaded binding. */
1272 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1274 /* Find the new binding. */
1275 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1276 tem1
= Fassq (symbol
,
1278 ? XFRAME (where
)->param_alist
1279 : XBUFFER (where
)->local_var_alist
));
1285 /* This buffer still sees the default value. */
1287 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1288 or if this is `let' rather than `set',
1289 make CURRENT-ALIST-ELEMENT point to itself,
1290 indicating that we're seeing the default value.
1291 Likewise if the variable has been let-bound
1292 in the current buffer. */
1293 if (bindflag
|| !blv
->local_if_set
1294 || let_shadows_buffer_binding_p (sym
))
1297 tem1
= blv
->defcell
;
1299 /* If it's a local_if_set, being set not bound,
1300 and we're not within a let that was made for this buffer,
1301 create a new buffer-local binding for the variable.
1302 That means, give this buffer a new assoc for a local value
1303 and load that binding. */
1306 /* local_if_set is only supported for buffer-local
1307 bindings, not for frame-local bindings. */
1308 eassert (!blv
->frame_local
);
1309 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1310 XBUFFER (where
)->local_var_alist
1311 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1315 /* Record which binding is now loaded. */
1316 blv
->valcell
= tem1
;
1319 /* Store the new value in the cons cell. */
1320 SET_BLV_VALUE (blv
, newval
);
1325 /* If storing void (making the symbol void), forward only through
1326 buffer-local indicator, not through Lisp_Objfwd, etc. */
1329 store_symval_forwarding (blv
->fwd
, newval
,
1331 ? XBUFFER (where
) : current_buffer
);
1335 case SYMBOL_FORWARDED
:
1338 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1339 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1340 if (BUFFER_OBJFWDP (innercontents
))
1342 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1343 int idx
= PER_BUFFER_IDX (offset
);
1346 && !let_shadows_buffer_binding_p (sym
))
1347 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1351 { /* If storing void (making the symbol void), forward only through
1352 buffer-local indicator, not through Lisp_Objfwd, etc. */
1353 sym
->redirect
= SYMBOL_PLAINVAL
;
1354 SET_SYMBOL_VAL (sym
, newval
);
1357 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1365 /* Access or set a buffer-local symbol's default value. */
1367 /* Return the default value of SYMBOL, but don't check for voidness.
1368 Return Qunbound if it is void. */
1371 default_value (symbol
)
1374 struct Lisp_Symbol
*sym
;
1376 CHECK_SYMBOL (symbol
);
1377 sym
= XSYMBOL (symbol
);
1380 switch (sym
->redirect
)
1382 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1383 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1384 case SYMBOL_LOCALIZED
:
1386 /* If var is set up for a buffer that lacks a local value for it,
1387 the current value is nominally the default value.
1388 But the `realvalue' slot may be more up to date, since
1389 ordinary setq stores just that slot. So use that. */
1390 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1391 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1392 return do_symval_forwarding (blv
->fwd
);
1394 return XCDR (blv
->defcell
);
1396 case SYMBOL_FORWARDED
:
1398 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1400 /* For a built-in buffer-local variable, get the default value
1401 rather than letting do_symval_forwarding get the current value. */
1402 if (BUFFER_OBJFWDP (valcontents
))
1404 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1405 if (PER_BUFFER_IDX (offset
) != 0)
1406 return PER_BUFFER_DEFAULT (offset
);
1409 /* For other variables, get the current value. */
1410 return do_symval_forwarding (valcontents
);
1416 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1417 doc
: /* Return t if SYMBOL has a non-void default value.
1418 This is the value that is seen in buffers that do not have their own values
1419 for this variable. */)
1423 register Lisp_Object value
;
1425 value
= default_value (symbol
);
1426 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1429 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1430 doc
: /* Return SYMBOL's default value.
1431 This is the value that is seen in buffers that do not have their own values
1432 for this variable. The default value is meaningful for variables with
1433 local bindings in certain buffers. */)
1437 register Lisp_Object value
;
1439 value
= default_value (symbol
);
1440 if (!EQ (value
, Qunbound
))
1443 xsignal1 (Qvoid_variable
, symbol
);
1446 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1447 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1448 The default value is seen in buffers that do not have their own values
1449 for this variable. */)
1451 Lisp_Object symbol
, value
;
1453 struct Lisp_Symbol
*sym
;
1455 CHECK_SYMBOL (symbol
);
1456 if (SYMBOL_CONSTANT_P (symbol
))
1458 if (NILP (Fkeywordp (symbol
))
1459 || !EQ (value
, Fdefault_value (symbol
)))
1460 xsignal1 (Qsetting_constant
, symbol
);
1462 /* Allow setting keywords to their own value. */
1465 sym
= XSYMBOL (symbol
);
1468 switch (sym
->redirect
)
1470 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1471 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1472 case SYMBOL_LOCALIZED
:
1474 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1476 /* Store new value into the DEFAULT-VALUE slot. */
1477 XSETCDR (blv
->defcell
, value
);
1479 /* If the default binding is now loaded, set the REALVALUE slot too. */
1480 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1481 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1484 case SYMBOL_FORWARDED
:
1486 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1488 /* Handle variables like case-fold-search that have special slots
1490 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1491 if (BUFFER_OBJFWDP (valcontents
))
1493 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1494 int idx
= PER_BUFFER_IDX (offset
);
1496 PER_BUFFER_DEFAULT (offset
) = value
;
1498 /* If this variable is not always local in all buffers,
1499 set it in the buffers that don't nominally have a local value. */
1504 for (b
= all_buffers
; b
; b
= b
->next
)
1505 if (!PER_BUFFER_VALUE_P (b
, idx
))
1506 PER_BUFFER_VALUE (b
, offset
) = value
;
1511 return Fset (symbol
, value
);
1517 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1518 doc
: /* Set the default value of variable VAR to VALUE.
1519 VAR, the variable name, is literal (not evaluated);
1520 VALUE is an expression: it is evaluated and its value returned.
1521 The default value of a variable is seen in buffers
1522 that do not have their own values for the variable.
1524 More generally, you can use multiple variables and values, as in
1525 (setq-default VAR VALUE VAR VALUE...)
1526 This sets each VAR's default value to the corresponding VALUE.
1527 The VALUE for the Nth VAR can refer to the new default values
1529 usage: (setq-default [VAR VALUE]...) */)
1533 register Lisp_Object args_left
;
1534 register Lisp_Object val
, symbol
;
1535 struct gcpro gcpro1
;
1545 val
= Feval (Fcar (Fcdr (args_left
)));
1546 symbol
= XCAR (args_left
);
1547 Fset_default (symbol
, val
);
1548 args_left
= Fcdr (XCDR (args_left
));
1550 while (!NILP (args_left
));
1556 /* Lisp functions for creating and removing buffer-local variables. */
1561 union Lisp_Fwd
*fwd
;
1564 static struct Lisp_Buffer_Local_Value
*
1565 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1567 struct Lisp_Buffer_Local_Value
*blv
1568 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1572 XSETSYMBOL (symbol
, sym
);
1573 tem
= Fcons (symbol
, (forwarded
1574 ? do_symval_forwarding (valcontents
.fwd
)
1575 : valcontents
.value
));
1577 /* Buffer_Local_Values cannot have as realval a buffer-local
1578 or keyboard-local forwarding. */
1579 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1580 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1581 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1583 blv
->frame_local
= 0;
1584 blv
->local_if_set
= 0;
1587 SET_BLV_FOUND (blv
, 0);
1591 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1592 1, 1, "vMake Variable Buffer Local: ",
1593 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1594 At any time, the value for the current buffer is in effect,
1595 unless the variable has never been set in this buffer,
1596 in which case the default value is in effect.
1597 Note that binding the variable with `let', or setting it while
1598 a `let'-style binding made in this buffer is in effect,
1599 does not make the variable buffer-local. Return VARIABLE.
1601 In most cases it is better to use `make-local-variable',
1602 which makes a variable local in just one buffer.
1604 The function `default-value' gets the default value and `set-default' sets it. */)
1606 register Lisp_Object variable
;
1608 struct Lisp_Symbol
*sym
;
1609 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1610 union Lisp_Val_Fwd valcontents
;
1613 CHECK_SYMBOL (variable
);
1614 sym
= XSYMBOL (variable
);
1617 switch (sym
->redirect
)
1619 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1620 case SYMBOL_PLAINVAL
:
1621 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1622 if (EQ (valcontents
.value
, Qunbound
))
1623 valcontents
.value
= Qnil
;
1625 case SYMBOL_LOCALIZED
:
1626 blv
= SYMBOL_BLV (sym
);
1627 if (blv
->frame_local
)
1628 error ("Symbol %s may not be buffer-local",
1629 SDATA (SYMBOL_NAME (variable
)));
1631 case SYMBOL_FORWARDED
:
1632 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1633 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1634 error ("Symbol %s may not be buffer-local",
1635 SDATA (SYMBOL_NAME (variable
)));
1636 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1643 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1647 blv
= make_blv (sym
, forwarded
, valcontents
);
1648 sym
->redirect
= SYMBOL_LOCALIZED
;
1649 SET_SYMBOL_BLV (sym
, blv
);
1652 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1653 if (let_shadows_global_binding_p (symbol
))
1654 message ("Making %s buffer-local while let-bound!",
1655 SDATA (SYMBOL_NAME (variable
)));
1659 blv
->local_if_set
= 1;
1663 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1664 1, 1, "vMake Local Variable: ",
1665 doc
: /* Make VARIABLE have a separate value in the current buffer.
1666 Other buffers will continue to share a common default value.
1667 \(The buffer-local value of VARIABLE starts out as the same value
1668 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1671 If the variable is already arranged to become local when set,
1672 this function causes a local value to exist for this buffer,
1673 just as setting the variable would do.
1675 This function returns VARIABLE, and therefore
1676 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1679 See also `make-variable-buffer-local'.
1681 Do not use `make-local-variable' to make a hook variable buffer-local.
1682 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1684 register Lisp_Object variable
;
1686 register Lisp_Object tem
;
1688 union Lisp_Val_Fwd valcontents
;
1689 struct Lisp_Symbol
*sym
;
1690 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1692 CHECK_SYMBOL (variable
);
1693 sym
= XSYMBOL (variable
);
1696 switch (sym
->redirect
)
1698 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1699 case SYMBOL_PLAINVAL
:
1700 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1701 case SYMBOL_LOCALIZED
:
1702 blv
= SYMBOL_BLV (sym
);
1703 if (blv
->frame_local
)
1704 error ("Symbol %s may not be buffer-local",
1705 SDATA (SYMBOL_NAME (variable
)));
1707 case SYMBOL_FORWARDED
:
1708 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1709 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1710 error ("Symbol %s may not be buffer-local",
1711 SDATA (SYMBOL_NAME (variable
)));
1717 error ("Symbol %s may not be buffer-local",
1718 SDATA (SYMBOL_NAME (variable
)));
1720 if (blv
? blv
->local_if_set
1721 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1723 tem
= Fboundp (variable
);
1724 /* Make sure the symbol has a local value in this particular buffer,
1725 by setting it to the same value it already has. */
1726 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1731 blv
= make_blv (sym
, forwarded
, valcontents
);
1732 sym
->redirect
= SYMBOL_LOCALIZED
;
1733 SET_SYMBOL_BLV (sym
, blv
);
1736 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1737 if (let_shadows_global_binding_p (symbol
))
1738 message ("Making %s local to %s while let-bound!",
1739 SDATA (SYMBOL_NAME (variable
)),
1740 SDATA (current_buffer
->name
));
1744 /* Make sure this buffer has its own value of symbol. */
1745 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1746 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1749 if (let_shadows_buffer_binding_p (sym
))
1750 message ("Making %s buffer-local while locally let-bound!",
1751 SDATA (SYMBOL_NAME (variable
)));
1753 /* Swap out any local binding for some other buffer, and make
1754 sure the current value is permanently recorded, if it's the
1756 find_symbol_value (variable
);
1758 current_buffer
->local_var_alist
1759 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1760 current_buffer
->local_var_alist
);
1762 /* Make sure symbol does not think it is set up for this buffer;
1763 force it to look once again for this buffer's value. */
1764 if (current_buffer
== XBUFFER (blv
->where
))
1766 /* blv->valcell = blv->defcell;
1767 * SET_BLV_FOUND (blv, 0); */
1771 /* If the symbol forwards into a C variable, then load the binding
1772 for this buffer now. If C code modifies the variable before we
1773 load the binding in, then that new value will clobber the default
1774 binding the next time we unload it. */
1776 swap_in_symval_forwarding (sym
, blv
);
1781 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1782 1, 1, "vKill Local Variable: ",
1783 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1784 From now on the default value will apply in this buffer. Return VARIABLE. */)
1786 register Lisp_Object variable
;
1788 register Lisp_Object tem
;
1789 struct Lisp_Buffer_Local_Value
*blv
;
1790 struct Lisp_Symbol
*sym
;
1792 CHECK_SYMBOL (variable
);
1793 sym
= XSYMBOL (variable
);
1796 switch (sym
->redirect
)
1798 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1799 case SYMBOL_PLAINVAL
: return variable
;
1800 case SYMBOL_FORWARDED
:
1802 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1803 if (BUFFER_OBJFWDP (valcontents
))
1805 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1806 int idx
= PER_BUFFER_IDX (offset
);
1810 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1811 PER_BUFFER_VALUE (current_buffer
, offset
)
1812 = PER_BUFFER_DEFAULT (offset
);
1817 case SYMBOL_LOCALIZED
:
1818 blv
= SYMBOL_BLV (sym
);
1819 if (blv
->frame_local
)
1825 /* Get rid of this buffer's alist element, if any. */
1826 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1827 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1829 current_buffer
->local_var_alist
1830 = Fdelq (tem
, current_buffer
->local_var_alist
);
1832 /* If the symbol is set up with the current buffer's binding
1833 loaded, recompute its value. We have to do it now, or else
1834 forwarded objects won't work right. */
1836 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1837 if (EQ (buf
, blv
->where
))
1840 /* blv->valcell = blv->defcell;
1841 * SET_BLV_FOUND (blv, 0); */
1843 find_symbol_value (variable
);
1850 /* Lisp functions for creating and removing buffer-local variables. */
1852 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1853 when/if this is removed. */
1855 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1856 1, 1, "vMake Variable Frame Local: ",
1857 doc
: /* Enable VARIABLE to have frame-local bindings.
1858 This does not create any frame-local bindings for VARIABLE,
1859 it just makes them possible.
1861 A frame-local binding is actually a frame parameter value.
1862 If a frame F has a value for the frame parameter named VARIABLE,
1863 that also acts as a frame-local binding for VARIABLE in F--
1864 provided this function has been called to enable VARIABLE
1865 to have frame-local bindings at all.
1867 The only way to create a frame-local binding for VARIABLE in a frame
1868 is to set the VARIABLE frame parameter of that frame. See
1869 `modify-frame-parameters' for how to set frame parameters.
1871 Note that since Emacs 23.1, variables cannot be both buffer-local and
1872 frame-local any more (buffer-local bindings used to take precedence over
1873 frame-local bindings). */)
1875 register Lisp_Object variable
;
1878 union Lisp_Val_Fwd valcontents
;
1879 struct Lisp_Symbol
*sym
;
1880 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1882 CHECK_SYMBOL (variable
);
1883 sym
= XSYMBOL (variable
);
1886 switch (sym
->redirect
)
1888 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1889 case SYMBOL_PLAINVAL
:
1890 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1891 if (EQ (valcontents
.value
, Qunbound
))
1892 valcontents
.value
= Qnil
;
1894 case SYMBOL_LOCALIZED
:
1895 if (SYMBOL_BLV (sym
)->frame_local
)
1898 error ("Symbol %s may not be frame-local",
1899 SDATA (SYMBOL_NAME (variable
)));
1900 case SYMBOL_FORWARDED
:
1901 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1902 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1903 error ("Symbol %s may not be frame-local",
1904 SDATA (SYMBOL_NAME (variable
)));
1910 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1912 blv
= make_blv (sym
, forwarded
, valcontents
);
1913 blv
->frame_local
= 1;
1914 sym
->redirect
= SYMBOL_LOCALIZED
;
1915 SET_SYMBOL_BLV (sym
, blv
);
1918 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1919 if (let_shadows_global_binding_p (symbol
))
1920 message ("Making %s frame-local while let-bound!",
1921 SDATA (SYMBOL_NAME (variable
)));
1926 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1928 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1929 BUFFER defaults to the current buffer. */)
1931 register Lisp_Object variable
, buffer
;
1933 register struct buffer
*buf
;
1934 struct Lisp_Symbol
*sym
;
1937 buf
= current_buffer
;
1940 CHECK_BUFFER (buffer
);
1941 buf
= XBUFFER (buffer
);
1944 CHECK_SYMBOL (variable
);
1945 sym
= XSYMBOL (variable
);
1948 switch (sym
->redirect
)
1950 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1951 case SYMBOL_PLAINVAL
: return Qnil
;
1952 case SYMBOL_LOCALIZED
:
1954 Lisp_Object tail
, elt
, tmp
;
1955 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1956 XSETBUFFER (tmp
, buf
);
1958 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1961 if (EQ (variable
, XCAR (elt
)))
1963 eassert (!blv
->frame_local
);
1964 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1968 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1971 case SYMBOL_FORWARDED
:
1973 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1974 if (BUFFER_OBJFWDP (valcontents
))
1976 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1977 int idx
= PER_BUFFER_IDX (offset
);
1978 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1987 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1989 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1990 More precisely, this means that setting the variable \(with `set' or`setq'),
1991 while it does not have a `let'-style binding that was made in BUFFER,
1992 will produce a buffer local binding. See Info node
1993 `(elisp)Creating Buffer-Local'.
1994 BUFFER defaults to the current buffer. */)
1996 register Lisp_Object variable
, buffer
;
1998 struct Lisp_Symbol
*sym
;
2000 CHECK_SYMBOL (variable
);
2001 sym
= XSYMBOL (variable
);
2004 switch (sym
->redirect
)
2006 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2007 case SYMBOL_PLAINVAL
: return Qnil
;
2008 case SYMBOL_LOCALIZED
:
2010 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
2011 if (blv
->local_if_set
)
2013 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
2014 return Flocal_variable_p (variable
, buffer
);
2016 case SYMBOL_FORWARDED
:
2017 /* All BUFFER_OBJFWD slots become local if they are set. */
2018 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2023 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2025 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2026 If the current binding is buffer-local, the value is the current buffer.
2027 If the current binding is frame-local, the value is the selected frame.
2028 If the current binding is global (the default), the value is nil. */)
2030 register Lisp_Object variable
;
2032 struct Lisp_Symbol
*sym
;
2034 CHECK_SYMBOL (variable
);
2035 sym
= XSYMBOL (variable
);
2037 /* Make sure the current binding is actually swapped in. */
2038 find_symbol_value (variable
);
2041 switch (sym
->redirect
)
2043 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2044 case SYMBOL_PLAINVAL
: return Qnil
;
2045 case SYMBOL_FORWARDED
:
2047 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2048 if (KBOARD_OBJFWDP (valcontents
))
2049 return Fframe_terminal (Fselected_frame ());
2050 else if (!BUFFER_OBJFWDP (valcontents
))
2054 case SYMBOL_LOCALIZED
:
2055 /* For a local variable, record both the symbol and which
2056 buffer's or frame's value we are saving. */
2057 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2058 return Fcurrent_buffer ();
2059 else if (sym
->redirect
== SYMBOL_LOCALIZED
2060 && BLV_FOUND (SYMBOL_BLV (sym
)))
2061 return SYMBOL_BLV (sym
)->where
;
2068 /* This code is disabled now that we use the selected frame to return
2069 keyboard-local-values. */
2071 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2073 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2074 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2075 If SYMBOL is not a terminal-local variable, then return its normal
2076 value, like `symbol-value'.
2078 TERMINAL may be a terminal object, a frame, or nil (meaning the
2079 selected frame's terminal device). */)
2082 Lisp_Object terminal
;
2085 struct terminal
*t
= get_terminal (terminal
, 1);
2086 push_kboard (t
->kboard
);
2087 result
= Fsymbol_value (symbol
);
2092 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2093 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2094 If VARIABLE is not a terminal-local variable, then set its normal
2095 binding, like `set'.
2097 TERMINAL may be a terminal object, a frame, or nil (meaning the
2098 selected frame's terminal device). */)
2099 (symbol
, terminal
, value
)
2101 Lisp_Object terminal
;
2105 struct terminal
*t
= get_terminal (terminal
, 1);
2106 push_kboard (d
->kboard
);
2107 result
= Fset (symbol
, value
);
2113 /* Find the function at the end of a chain of symbol function indirections. */
2115 /* If OBJECT is a symbol, find the end of its function chain and
2116 return the value found there. If OBJECT is not a symbol, just
2117 return it. If there is a cycle in the function chain, signal a
2118 cyclic-function-indirection error.
2120 This is like Findirect_function, except that it doesn't signal an
2121 error if the chain ends up unbound. */
2123 indirect_function (object
)
2124 register Lisp_Object object
;
2126 Lisp_Object tortoise
, hare
;
2128 hare
= tortoise
= object
;
2132 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2134 hare
= XSYMBOL (hare
)->function
;
2135 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2137 hare
= XSYMBOL (hare
)->function
;
2139 tortoise
= XSYMBOL (tortoise
)->function
;
2141 if (EQ (hare
, tortoise
))
2142 xsignal1 (Qcyclic_function_indirection
, object
);
2148 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2149 doc
: /* Return the function at the end of OBJECT's function chain.
2150 If OBJECT is not a symbol, just return it. Otherwise, follow all
2151 function indirections to find the final function binding and return it.
2152 If the final symbol in the chain is unbound, signal a void-function error.
2153 Optional arg NOERROR non-nil means to return nil instead of signalling.
2154 Signal a cyclic-function-indirection error if there is a loop in the
2155 function chain of symbols. */)
2157 register Lisp_Object object
;
2158 Lisp_Object noerror
;
2162 /* Optimize for no indirection. */
2164 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2165 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2166 result
= indirect_function (result
);
2167 if (!EQ (result
, Qunbound
))
2171 xsignal1 (Qvoid_function
, object
);
2176 /* Extract and set vector and string elements */
2178 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2179 doc
: /* Return the element of ARRAY at index IDX.
2180 ARRAY may be a vector, a string, a char-table, a bool-vector,
2181 or a byte-code object. IDX starts at 0. */)
2183 register Lisp_Object array
;
2186 register int idxval
;
2189 idxval
= XINT (idx
);
2190 if (STRINGP (array
))
2194 if (idxval
< 0 || idxval
>= SCHARS (array
))
2195 args_out_of_range (array
, idx
);
2196 if (! STRING_MULTIBYTE (array
))
2197 return make_number ((unsigned char) SREF (array
, idxval
));
2198 idxval_byte
= string_char_to_byte (array
, idxval
);
2200 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2201 return make_number (c
);
2203 else if (BOOL_VECTOR_P (array
))
2207 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2208 args_out_of_range (array
, idx
);
2210 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2211 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2213 else if (CHAR_TABLE_P (array
))
2215 CHECK_CHARACTER (idx
);
2216 return CHAR_TABLE_REF (array
, idxval
);
2221 if (VECTORP (array
))
2222 size
= ASIZE (array
);
2223 else if (FUNVECP (array
))
2224 size
= FUNVEC_SIZE (array
);
2226 wrong_type_argument (Qarrayp
, array
);
2228 if (idxval
< 0 || idxval
>= size
)
2229 args_out_of_range (array
, idx
);
2230 return AREF (array
, idxval
);
2234 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2235 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2236 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2237 bool-vector. IDX starts at 0. */)
2238 (array
, idx
, newelt
)
2239 register Lisp_Object array
;
2240 Lisp_Object idx
, newelt
;
2242 register int idxval
;
2245 idxval
= XINT (idx
);
2246 CHECK_ARRAY (array
, Qarrayp
);
2247 CHECK_IMPURE (array
);
2249 if (VECTORP (array
))
2251 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2252 args_out_of_range (array
, idx
);
2253 XVECTOR (array
)->contents
[idxval
] = newelt
;
2255 else if (BOOL_VECTOR_P (array
))
2259 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2260 args_out_of_range (array
, idx
);
2262 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2264 if (! NILP (newelt
))
2265 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2267 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2268 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2270 else if (CHAR_TABLE_P (array
))
2272 CHECK_CHARACTER (idx
);
2273 CHAR_TABLE_SET (array
, idxval
, newelt
);
2275 else if (STRING_MULTIBYTE (array
))
2277 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2278 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2280 if (idxval
< 0 || idxval
>= SCHARS (array
))
2281 args_out_of_range (array
, idx
);
2282 CHECK_CHARACTER (newelt
);
2284 nbytes
= SBYTES (array
);
2286 idxval_byte
= string_char_to_byte (array
, idxval
);
2287 p1
= SDATA (array
) + idxval_byte
;
2288 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2289 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2290 if (prev_bytes
!= new_bytes
)
2292 /* We must relocate the string data. */
2293 int nchars
= SCHARS (array
);
2297 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2298 bcopy (SDATA (array
), str
, nbytes
);
2299 allocate_string_data (XSTRING (array
), nchars
,
2300 nbytes
+ new_bytes
- prev_bytes
);
2301 bcopy (str
, SDATA (array
), idxval_byte
);
2302 p1
= SDATA (array
) + idxval_byte
;
2303 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2304 nbytes
- (idxval_byte
+ prev_bytes
));
2306 clear_string_char_byte_cache ();
2313 if (idxval
< 0 || idxval
>= SCHARS (array
))
2314 args_out_of_range (array
, idx
);
2315 CHECK_NUMBER (newelt
);
2317 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2321 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2322 if (SREF (array
, i
) >= 0x80)
2323 args_out_of_range (array
, newelt
);
2324 /* ARRAY is an ASCII string. Convert it to a multibyte
2325 string, and try `aset' again. */
2326 STRING_SET_MULTIBYTE (array
);
2327 return Faset (array
, idx
, newelt
);
2329 SSET (array
, idxval
, XINT (newelt
));
2335 /* Arithmetic functions */
2337 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2340 arithcompare (num1
, num2
, comparison
)
2341 Lisp_Object num1
, num2
;
2342 enum comparison comparison
;
2344 double f1
= 0, f2
= 0;
2347 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2348 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2350 if (FLOATP (num1
) || FLOATP (num2
))
2353 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2354 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2360 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2365 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2370 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2375 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2380 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2385 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2394 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2395 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2397 register Lisp_Object num1
, num2
;
2399 return arithcompare (num1
, num2
, equal
);
2402 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2403 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2405 register Lisp_Object num1
, num2
;
2407 return arithcompare (num1
, num2
, less
);
2410 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2411 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2413 register Lisp_Object num1
, num2
;
2415 return arithcompare (num1
, num2
, grtr
);
2418 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2419 doc
: /* Return t if first arg is less than or equal to second arg.
2420 Both must be numbers or markers. */)
2422 register Lisp_Object num1
, num2
;
2424 return arithcompare (num1
, num2
, less_or_equal
);
2427 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2428 doc
: /* Return t if first arg is greater than or equal to second arg.
2429 Both must be numbers or markers. */)
2431 register Lisp_Object num1
, num2
;
2433 return arithcompare (num1
, num2
, grtr_or_equal
);
2436 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2437 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2439 register Lisp_Object num1
, num2
;
2441 return arithcompare (num1
, num2
, notequal
);
2444 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2445 doc
: /* Return t if NUMBER is zero. */)
2447 register Lisp_Object number
;
2449 CHECK_NUMBER_OR_FLOAT (number
);
2451 if (FLOATP (number
))
2453 if (XFLOAT_DATA (number
) == 0.0)
2463 /* Convert between long values and pairs of Lisp integers.
2464 Note that long_to_cons returns a single Lisp integer
2465 when the value fits in one. */
2471 unsigned long top
= i
>> 16;
2472 unsigned int bot
= i
& 0xFFFF;
2474 return make_number (bot
);
2475 if (top
== (unsigned long)-1 >> 16)
2476 return Fcons (make_number (-1), make_number (bot
));
2477 return Fcons (make_number (top
), make_number (bot
));
2484 Lisp_Object top
, bot
;
2491 return ((XINT (top
) << 16) | XINT (bot
));
2494 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2495 doc
: /* Return the decimal representation of NUMBER as a string.
2496 Uses a minus sign if negative.
2497 NUMBER may be an integer or a floating point number. */)
2501 char buffer
[VALBITS
];
2503 CHECK_NUMBER_OR_FLOAT (number
);
2505 if (FLOATP (number
))
2507 char pigbuf
[350]; /* see comments in float_to_string */
2509 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2510 return build_string (pigbuf
);
2513 if (sizeof (int) == sizeof (EMACS_INT
))
2514 sprintf (buffer
, "%d", (int) XINT (number
));
2515 else if (sizeof (long) == sizeof (EMACS_INT
))
2516 sprintf (buffer
, "%ld", (long) XINT (number
));
2519 return build_string (buffer
);
2523 digit_to_number (character
, base
)
2524 int character
, base
;
2528 if (character
>= '0' && character
<= '9')
2529 digit
= character
- '0';
2530 else if (character
>= 'a' && character
<= 'z')
2531 digit
= character
- 'a' + 10;
2532 else if (character
>= 'A' && character
<= 'Z')
2533 digit
= character
- 'A' + 10;
2543 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2544 doc
: /* Parse STRING as a decimal number and return the number.
2545 This parses both integers and floating point numbers.
2546 It ignores leading spaces and tabs, and all trailing chars.
2548 If BASE, interpret STRING as a number in that base. If BASE isn't
2549 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2550 If the base used is not 10, STRING is always parsed as integer. */)
2552 register Lisp_Object string
, base
;
2554 register unsigned char *p
;
2559 CHECK_STRING (string
);
2565 CHECK_NUMBER (base
);
2567 if (b
< 2 || b
> 16)
2568 xsignal1 (Qargs_out_of_range
, base
);
2571 /* Skip any whitespace at the front of the number. Some versions of
2572 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2574 while (*p
== ' ' || *p
== '\t')
2585 if (isfloat_string (p
, 1) && b
== 10)
2586 val
= make_float (sign
* atof (p
));
2593 int digit
= digit_to_number (*p
++, b
);
2599 val
= make_fixnum_or_float (sign
* v
);
2619 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2620 int, Lisp_Object
*));
2621 extern Lisp_Object
fmod_float ();
2624 arith_driver (code
, nargs
, args
)
2627 register Lisp_Object
*args
;
2629 register Lisp_Object val
;
2630 register int argnum
;
2631 register EMACS_INT accum
= 0;
2632 register EMACS_INT next
;
2634 switch (SWITCH_ENUM_CAST (code
))
2652 for (argnum
= 0; argnum
< nargs
; argnum
++)
2654 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2656 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2659 return float_arith_driver ((double) accum
, argnum
, code
,
2662 next
= XINT (args
[argnum
]);
2663 switch (SWITCH_ENUM_CAST (code
))
2669 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2680 xsignal0 (Qarith_error
);
2694 if (!argnum
|| next
> accum
)
2698 if (!argnum
|| next
< accum
)
2704 XSETINT (val
, accum
);
2709 #define isnan(x) ((x) != (x))
2712 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2714 register int argnum
;
2717 register Lisp_Object
*args
;
2719 register Lisp_Object val
;
2722 for (; argnum
< nargs
; argnum
++)
2724 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2725 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2729 next
= XFLOAT_DATA (val
);
2733 args
[argnum
] = val
; /* runs into a compiler bug. */
2734 next
= XINT (args
[argnum
]);
2736 switch (SWITCH_ENUM_CAST (code
))
2742 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2752 if (! IEEE_FLOATING_POINT
&& next
== 0)
2753 xsignal0 (Qarith_error
);
2760 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2762 if (!argnum
|| isnan (next
) || next
> accum
)
2766 if (!argnum
|| isnan (next
) || next
< accum
)
2772 return make_float (accum
);
2776 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2777 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2778 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2783 return arith_driver (Aadd
, nargs
, args
);
2786 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2787 doc
: /* Negate number or subtract numbers or markers and return the result.
2788 With one arg, negates it. With more than one arg,
2789 subtracts all but the first from the first.
2790 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2795 return arith_driver (Asub
, nargs
, args
);
2798 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2799 doc
: /* Return product of any number of arguments, which are numbers or markers.
2800 usage: (* &rest NUMBERS-OR-MARKERS) */)
2805 return arith_driver (Amult
, nargs
, args
);
2808 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2809 doc
: /* Return first argument divided by all the remaining arguments.
2810 The arguments must be numbers or markers.
2811 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2817 for (argnum
= 2; argnum
< nargs
; argnum
++)
2818 if (FLOATP (args
[argnum
]))
2819 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2820 return arith_driver (Adiv
, nargs
, args
);
2823 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2824 doc
: /* Return remainder of X divided by Y.
2825 Both must be integers or markers. */)
2827 register Lisp_Object x
, y
;
2831 CHECK_NUMBER_COERCE_MARKER (x
);
2832 CHECK_NUMBER_COERCE_MARKER (y
);
2834 if (XFASTINT (y
) == 0)
2835 xsignal0 (Qarith_error
);
2837 XSETINT (val
, XINT (x
) % XINT (y
));
2851 /* If the magnitude of the result exceeds that of the divisor, or
2852 the sign of the result does not agree with that of the dividend,
2853 iterate with the reduced value. This does not yield a
2854 particularly accurate result, but at least it will be in the
2855 range promised by fmod. */
2857 r
-= f2
* floor (r
/ f2
);
2858 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2862 #endif /* ! HAVE_FMOD */
2864 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2865 doc
: /* Return X modulo Y.
2866 The result falls between zero (inclusive) and Y (exclusive).
2867 Both X and Y must be numbers or markers. */)
2869 register Lisp_Object x
, y
;
2874 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2875 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2877 if (FLOATP (x
) || FLOATP (y
))
2878 return fmod_float (x
, y
);
2884 xsignal0 (Qarith_error
);
2888 /* If the "remainder" comes out with the wrong sign, fix it. */
2889 if (i2
< 0 ? i1
> 0 : i1
< 0)
2896 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2897 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2898 The value is always a number; markers are converted to numbers.
2899 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2904 return arith_driver (Amax
, nargs
, args
);
2907 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2908 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2909 The value is always a number; markers are converted to numbers.
2910 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2915 return arith_driver (Amin
, nargs
, args
);
2918 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2919 doc
: /* Return bitwise-and of all the arguments.
2920 Arguments may be integers, or markers converted to integers.
2921 usage: (logand &rest INTS-OR-MARKERS) */)
2926 return arith_driver (Alogand
, nargs
, args
);
2929 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2930 doc
: /* Return bitwise-or of all the arguments.
2931 Arguments may be integers, or markers converted to integers.
2932 usage: (logior &rest INTS-OR-MARKERS) */)
2937 return arith_driver (Alogior
, nargs
, args
);
2940 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2941 doc
: /* Return bitwise-exclusive-or of all the arguments.
2942 Arguments may be integers, or markers converted to integers.
2943 usage: (logxor &rest INTS-OR-MARKERS) */)
2948 return arith_driver (Alogxor
, nargs
, args
);
2951 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2952 doc
: /* Return VALUE with its bits shifted left by COUNT.
2953 If COUNT is negative, shifting is actually to the right.
2954 In this case, the sign bit is duplicated. */)
2956 register Lisp_Object value
, count
;
2958 register Lisp_Object val
;
2960 CHECK_NUMBER (value
);
2961 CHECK_NUMBER (count
);
2963 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2965 else if (XINT (count
) > 0)
2966 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2967 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2968 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2970 XSETINT (val
, XINT (value
) >> -XINT (count
));
2974 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2975 doc
: /* Return VALUE with its bits shifted left by COUNT.
2976 If COUNT is negative, shifting is actually to the right.
2977 In this case, zeros are shifted in on the left. */)
2979 register Lisp_Object value
, count
;
2981 register Lisp_Object val
;
2983 CHECK_NUMBER (value
);
2984 CHECK_NUMBER (count
);
2986 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2988 else if (XINT (count
) > 0)
2989 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2990 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2993 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2997 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2998 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2999 Markers are converted to integers. */)
3001 register Lisp_Object number
;
3003 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3005 if (FLOATP (number
))
3006 return (make_float (1.0 + XFLOAT_DATA (number
)));
3008 XSETINT (number
, XINT (number
) + 1);
3012 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
3013 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3014 Markers are converted to integers. */)
3016 register Lisp_Object number
;
3018 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
3020 if (FLOATP (number
))
3021 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3023 XSETINT (number
, XINT (number
) - 1);
3027 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3028 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3030 register Lisp_Object number
;
3032 CHECK_NUMBER (number
);
3033 XSETINT (number
, ~XINT (number
));
3037 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3038 doc
: /* Return the byteorder for the machine.
3039 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3040 lowercase l) for small endian machines. */)
3043 unsigned i
= 0x04030201;
3044 int order
= *(char *)&i
== 1 ? 108 : 66;
3046 return make_number (order
);
3054 Lisp_Object error_tail
, arith_tail
;
3056 Qquote
= intern_c_string ("quote");
3057 Qlambda
= intern_c_string ("lambda");
3058 Qsubr
= intern_c_string ("subr");
3059 Qerror_conditions
= intern_c_string ("error-conditions");
3060 Qerror_message
= intern_c_string ("error-message");
3061 Qtop_level
= intern_c_string ("top-level");
3063 Qerror
= intern_c_string ("error");
3064 Qquit
= intern_c_string ("quit");
3065 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3066 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3067 Qvoid_function
= intern_c_string ("void-function");
3068 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3069 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3070 Qvoid_variable
= intern_c_string ("void-variable");
3071 Qsetting_constant
= intern_c_string ("setting-constant");
3072 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3074 Qinvalid_function
= intern_c_string ("invalid-function");
3075 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3076 Qno_catch
= intern_c_string ("no-catch");
3077 Qend_of_file
= intern_c_string ("end-of-file");
3078 Qarith_error
= intern_c_string ("arith-error");
3079 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3080 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3081 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3082 Qtext_read_only
= intern_c_string ("text-read-only");
3083 Qmark_inactive
= intern_c_string ("mark-inactive");
3085 Qlistp
= intern_c_string ("listp");
3086 Qconsp
= intern_c_string ("consp");
3087 Qsymbolp
= intern_c_string ("symbolp");
3088 Qkeywordp
= intern_c_string ("keywordp");
3089 Qintegerp
= intern_c_string ("integerp");
3090 Qnatnump
= intern_c_string ("natnump");
3091 Qwholenump
= intern_c_string ("wholenump");
3092 Qstringp
= intern_c_string ("stringp");
3093 Qarrayp
= intern_c_string ("arrayp");
3094 Qsequencep
= intern_c_string ("sequencep");
3095 Qbufferp
= intern_c_string ("bufferp");
3096 Qvectorp
= intern_c_string ("vectorp");
3097 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3098 Qmarkerp
= intern_c_string ("markerp");
3099 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3100 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3101 Qboundp
= intern_c_string ("boundp");
3102 Qfboundp
= intern_c_string ("fboundp");
3104 Qfloatp
= intern_c_string ("floatp");
3105 Qnumberp
= intern_c_string ("numberp");
3106 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3108 Qchar_table_p
= intern_c_string ("char-table-p");
3109 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3111 Qsubrp
= intern_c_string ("subrp");
3112 Qunevalled
= intern_c_string ("unevalled");
3113 Qmany
= intern_c_string ("many");
3115 Qcdr
= intern_c_string ("cdr");
3117 /* Handle automatic advice activation */
3118 Qad_advice_info
= intern_c_string ("ad-advice-info");
3119 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3121 error_tail
= pure_cons (Qerror
, Qnil
);
3123 /* ERROR is used as a signaler for random errors for which nothing else is right */
3125 Fput (Qerror
, Qerror_conditions
,
3127 Fput (Qerror
, Qerror_message
,
3128 make_pure_c_string ("error"));
3130 Fput (Qquit
, Qerror_conditions
,
3131 pure_cons (Qquit
, Qnil
));
3132 Fput (Qquit
, Qerror_message
,
3133 make_pure_c_string ("Quit"));
3135 Fput (Qwrong_type_argument
, Qerror_conditions
,
3136 pure_cons (Qwrong_type_argument
, error_tail
));
3137 Fput (Qwrong_type_argument
, Qerror_message
,
3138 make_pure_c_string ("Wrong type argument"));
3140 Fput (Qargs_out_of_range
, Qerror_conditions
,
3141 pure_cons (Qargs_out_of_range
, error_tail
));
3142 Fput (Qargs_out_of_range
, Qerror_message
,
3143 make_pure_c_string ("Args out of range"));
3145 Fput (Qvoid_function
, Qerror_conditions
,
3146 pure_cons (Qvoid_function
, error_tail
));
3147 Fput (Qvoid_function
, Qerror_message
,
3148 make_pure_c_string ("Symbol's function definition is void"));
3150 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3151 pure_cons (Qcyclic_function_indirection
, error_tail
));
3152 Fput (Qcyclic_function_indirection
, Qerror_message
,
3153 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3155 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3156 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3157 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3158 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3160 Qcircular_list
= intern_c_string ("circular-list");
3161 staticpro (&Qcircular_list
);
3162 Fput (Qcircular_list
, Qerror_conditions
,
3163 pure_cons (Qcircular_list
, error_tail
));
3164 Fput (Qcircular_list
, Qerror_message
,
3165 make_pure_c_string ("List contains a loop"));
3167 Fput (Qvoid_variable
, Qerror_conditions
,
3168 pure_cons (Qvoid_variable
, error_tail
));
3169 Fput (Qvoid_variable
, Qerror_message
,
3170 make_pure_c_string ("Symbol's value as variable is void"));
3172 Fput (Qsetting_constant
, Qerror_conditions
,
3173 pure_cons (Qsetting_constant
, error_tail
));
3174 Fput (Qsetting_constant
, Qerror_message
,
3175 make_pure_c_string ("Attempt to set a constant symbol"));
3177 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3178 pure_cons (Qinvalid_read_syntax
, error_tail
));
3179 Fput (Qinvalid_read_syntax
, Qerror_message
,
3180 make_pure_c_string ("Invalid read syntax"));
3182 Fput (Qinvalid_function
, Qerror_conditions
,
3183 pure_cons (Qinvalid_function
, error_tail
));
3184 Fput (Qinvalid_function
, Qerror_message
,
3185 make_pure_c_string ("Invalid function"));
3187 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3188 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3189 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3190 make_pure_c_string ("Wrong number of arguments"));
3192 Fput (Qno_catch
, Qerror_conditions
,
3193 pure_cons (Qno_catch
, error_tail
));
3194 Fput (Qno_catch
, Qerror_message
,
3195 make_pure_c_string ("No catch for tag"));
3197 Fput (Qend_of_file
, Qerror_conditions
,
3198 pure_cons (Qend_of_file
, error_tail
));
3199 Fput (Qend_of_file
, Qerror_message
,
3200 make_pure_c_string ("End of file during parsing"));
3202 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3203 Fput (Qarith_error
, Qerror_conditions
,
3205 Fput (Qarith_error
, Qerror_message
,
3206 make_pure_c_string ("Arithmetic error"));
3208 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3209 pure_cons (Qbeginning_of_buffer
, error_tail
));
3210 Fput (Qbeginning_of_buffer
, Qerror_message
,
3211 make_pure_c_string ("Beginning of buffer"));
3213 Fput (Qend_of_buffer
, Qerror_conditions
,
3214 pure_cons (Qend_of_buffer
, error_tail
));
3215 Fput (Qend_of_buffer
, Qerror_message
,
3216 make_pure_c_string ("End of buffer"));
3218 Fput (Qbuffer_read_only
, Qerror_conditions
,
3219 pure_cons (Qbuffer_read_only
, error_tail
));
3220 Fput (Qbuffer_read_only
, Qerror_message
,
3221 make_pure_c_string ("Buffer is read-only"));
3223 Fput (Qtext_read_only
, Qerror_conditions
,
3224 pure_cons (Qtext_read_only
, error_tail
));
3225 Fput (Qtext_read_only
, Qerror_message
,
3226 make_pure_c_string ("Text is read-only"));
3228 Qrange_error
= intern_c_string ("range-error");
3229 Qdomain_error
= intern_c_string ("domain-error");
3230 Qsingularity_error
= intern_c_string ("singularity-error");
3231 Qoverflow_error
= intern_c_string ("overflow-error");
3232 Qunderflow_error
= intern_c_string ("underflow-error");
3234 Fput (Qdomain_error
, Qerror_conditions
,
3235 pure_cons (Qdomain_error
, arith_tail
));
3236 Fput (Qdomain_error
, Qerror_message
,
3237 make_pure_c_string ("Arithmetic domain error"));
3239 Fput (Qrange_error
, Qerror_conditions
,
3240 pure_cons (Qrange_error
, arith_tail
));
3241 Fput (Qrange_error
, Qerror_message
,
3242 make_pure_c_string ("Arithmetic range error"));
3244 Fput (Qsingularity_error
, Qerror_conditions
,
3245 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3246 Fput (Qsingularity_error
, Qerror_message
,
3247 make_pure_c_string ("Arithmetic singularity error"));
3249 Fput (Qoverflow_error
, Qerror_conditions
,
3250 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3251 Fput (Qoverflow_error
, Qerror_message
,
3252 make_pure_c_string ("Arithmetic overflow error"));
3254 Fput (Qunderflow_error
, Qerror_conditions
,
3255 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3256 Fput (Qunderflow_error
, Qerror_message
,
3257 make_pure_c_string ("Arithmetic underflow error"));
3259 staticpro (&Qrange_error
);
3260 staticpro (&Qdomain_error
);
3261 staticpro (&Qsingularity_error
);
3262 staticpro (&Qoverflow_error
);
3263 staticpro (&Qunderflow_error
);
3267 staticpro (&Qquote
);
3268 staticpro (&Qlambda
);
3270 staticpro (&Qunbound
);
3271 staticpro (&Qerror_conditions
);
3272 staticpro (&Qerror_message
);
3273 staticpro (&Qtop_level
);
3275 staticpro (&Qerror
);
3277 staticpro (&Qwrong_type_argument
);
3278 staticpro (&Qargs_out_of_range
);
3279 staticpro (&Qvoid_function
);
3280 staticpro (&Qcyclic_function_indirection
);
3281 staticpro (&Qcyclic_variable_indirection
);
3282 staticpro (&Qvoid_variable
);
3283 staticpro (&Qsetting_constant
);
3284 staticpro (&Qinvalid_read_syntax
);
3285 staticpro (&Qwrong_number_of_arguments
);
3286 staticpro (&Qinvalid_function
);
3287 staticpro (&Qno_catch
);
3288 staticpro (&Qend_of_file
);
3289 staticpro (&Qarith_error
);
3290 staticpro (&Qbeginning_of_buffer
);
3291 staticpro (&Qend_of_buffer
);
3292 staticpro (&Qbuffer_read_only
);
3293 staticpro (&Qtext_read_only
);
3294 staticpro (&Qmark_inactive
);
3296 staticpro (&Qlistp
);
3297 staticpro (&Qconsp
);
3298 staticpro (&Qsymbolp
);
3299 staticpro (&Qkeywordp
);
3300 staticpro (&Qintegerp
);
3301 staticpro (&Qnatnump
);
3302 staticpro (&Qwholenump
);
3303 staticpro (&Qstringp
);
3304 staticpro (&Qarrayp
);
3305 staticpro (&Qsequencep
);
3306 staticpro (&Qbufferp
);
3307 staticpro (&Qvectorp
);
3308 staticpro (&Qchar_or_string_p
);
3309 staticpro (&Qmarkerp
);
3310 staticpro (&Qbuffer_or_string_p
);
3311 staticpro (&Qinteger_or_marker_p
);
3312 staticpro (&Qfloatp
);
3313 staticpro (&Qnumberp
);
3314 staticpro (&Qnumber_or_marker_p
);
3315 staticpro (&Qchar_table_p
);
3316 staticpro (&Qvector_or_char_table_p
);
3317 staticpro (&Qsubrp
);
3319 staticpro (&Qunevalled
);
3321 staticpro (&Qboundp
);
3322 staticpro (&Qfboundp
);
3324 staticpro (&Qad_advice_info
);
3325 staticpro (&Qad_activate_internal
);
3327 /* Types that type-of returns. */
3328 Qinteger
= intern_c_string ("integer");
3329 Qsymbol
= intern_c_string ("symbol");
3330 Qstring
= intern_c_string ("string");
3331 Qcons
= intern_c_string ("cons");
3332 Qmarker
= intern_c_string ("marker");
3333 Qoverlay
= intern_c_string ("overlay");
3334 Qfloat
= intern_c_string ("float");
3335 Qwindow_configuration
= intern_c_string ("window-configuration");
3336 Qprocess
= intern_c_string ("process");
3337 Qwindow
= intern_c_string ("window");
3338 /* Qsubr = intern_c_string ("subr"); */
3339 Qcompiled_function
= intern_c_string ("compiled-function");
3340 Qfunction_vector
= intern_c_string ("function-vector");
3341 Qbuffer
= intern_c_string ("buffer");
3342 Qframe
= intern_c_string ("frame");
3343 Qvector
= intern_c_string ("vector");
3344 Qchar_table
= intern_c_string ("char-table");
3345 Qbool_vector
= intern_c_string ("bool-vector");
3346 Qhash_table
= intern_c_string ("hash-table");
3348 DEFSYM (Qfont_spec
, "font-spec");
3349 DEFSYM (Qfont_entity
, "font-entity");
3350 DEFSYM (Qfont_object
, "font-object");
3352 DEFSYM (Qinteractive_form
, "interactive-form");
3354 staticpro (&Qinteger
);
3355 staticpro (&Qsymbol
);
3356 staticpro (&Qstring
);
3358 staticpro (&Qmarker
);
3359 staticpro (&Qoverlay
);
3360 staticpro (&Qfloat
);
3361 staticpro (&Qwindow_configuration
);
3362 staticpro (&Qprocess
);
3363 staticpro (&Qwindow
);
3364 /* staticpro (&Qsubr); */
3365 staticpro (&Qcompiled_function
);
3366 staticpro (&Qfunction_vector
);
3367 staticpro (&Qbuffer
);
3368 staticpro (&Qframe
);
3369 staticpro (&Qvector
);
3370 staticpro (&Qchar_table
);
3371 staticpro (&Qbool_vector
);
3372 staticpro (&Qhash_table
);
3374 defsubr (&Sindirect_variable
);
3375 defsubr (&Sinteractive_form
);
3378 defsubr (&Stype_of
);
3383 defsubr (&Sintegerp
);
3384 defsubr (&Sinteger_or_marker_p
);
3385 defsubr (&Snumberp
);
3386 defsubr (&Snumber_or_marker_p
);
3388 defsubr (&Snatnump
);
3389 defsubr (&Ssymbolp
);
3390 defsubr (&Skeywordp
);
3391 defsubr (&Sstringp
);
3392 defsubr (&Smultibyte_string_p
);
3393 defsubr (&Svectorp
);
3394 defsubr (&Schar_table_p
);
3395 defsubr (&Svector_or_char_table_p
);
3396 defsubr (&Sbool_vector_p
);
3398 defsubr (&Ssequencep
);
3399 defsubr (&Sbufferp
);
3400 defsubr (&Smarkerp
);
3402 defsubr (&Sbyte_code_function_p
);
3403 defsubr (&Sfunvecp
);
3404 defsubr (&Schar_or_string_p
);
3407 defsubr (&Scar_safe
);
3408 defsubr (&Scdr_safe
);
3411 defsubr (&Ssymbol_function
);
3412 defsubr (&Sindirect_function
);
3413 defsubr (&Ssymbol_plist
);
3414 defsubr (&Ssymbol_name
);
3415 defsubr (&Smakunbound
);
3416 defsubr (&Sfmakunbound
);
3418 defsubr (&Sfboundp
);
3420 defsubr (&Sdefalias
);
3421 defsubr (&Ssetplist
);
3422 defsubr (&Ssymbol_value
);
3424 defsubr (&Sdefault_boundp
);
3425 defsubr (&Sdefault_value
);
3426 defsubr (&Sset_default
);
3427 defsubr (&Ssetq_default
);
3428 defsubr (&Smake_variable_buffer_local
);
3429 defsubr (&Smake_local_variable
);
3430 defsubr (&Skill_local_variable
);
3431 defsubr (&Smake_variable_frame_local
);
3432 defsubr (&Slocal_variable_p
);
3433 defsubr (&Slocal_variable_if_set_p
);
3434 defsubr (&Svariable_binding_locus
);
3435 #if 0 /* XXX Remove this. --lorentey */
3436 defsubr (&Sterminal_local_value
);
3437 defsubr (&Sset_terminal_local_value
);
3441 defsubr (&Snumber_to_string
);
3442 defsubr (&Sstring_to_number
);
3443 defsubr (&Seqlsign
);
3466 defsubr (&Sbyteorder
);
3467 defsubr (&Ssubr_arity
);
3468 defsubr (&Ssubr_name
);
3470 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3472 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3473 doc
: /* The largest value that is representable in a Lisp integer. */);
3474 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3475 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3477 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3478 doc
: /* The smallest value that is representable in a Lisp integer. */);
3479 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3480 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3487 sigsetmask (SIGEMPTYMASK
);
3489 SIGNAL_THREAD_CHECK (signo
);
3490 xsignal0 (Qarith_error
);
3496 /* Don't do this if just dumping out.
3497 We don't want to call `signal' in this case
3498 so that we don't have trouble with dumping
3499 signal-delivering routines in an inconsistent state. */
3503 #endif /* CANNOT_DUMP */
3504 signal (SIGFPE
, arith_error
);
3507 signal (SIGEMT
, arith_error
);
3511 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3512 (do not change this comment) */