1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
53 extern double atof (const char *);
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
86 static Lisp_Object Qfloat
, Qwindow_configuration
;
88 static Lisp_Object Qcompiled_function
, Qfunction_vector
, Qbuffer
, Qframe
, Qvector
;
89 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
90 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
91 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
93 Lisp_Object Qinteractive_form
;
95 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
97 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
101 circular_list_error (Lisp_Object list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
110 /* If VALUE is not even a valid Lisp object, we'd want to abort here
111 where we can get a backtrace showing where it came from. We used
112 to try and do that by checking the tagbits, but nowadays all
113 tagbits are potentially valid. */
114 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
117 xsignal2 (Qwrong_type_argument
, predicate
, value
);
121 pure_write_error (void)
123 error ("Attempt to modify read-only object");
127 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
129 xsignal2 (Qargs_out_of_range
, a1
, a2
);
133 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
135 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
139 /* Data type predicates */
141 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
142 doc
: /* Return t if the two args are the same Lisp object. */)
143 (Lisp_Object obj1
, Lisp_Object obj2
)
150 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
151 doc
: /* Return t if OBJECT is nil. */)
159 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
160 doc
: /* Return a symbol representing the type of OBJECT.
161 The symbol returned names the object's basic type;
162 for example, (type-of 1) returns `integer'. */)
165 switch (XTYPE (object
))
180 switch (XMISCTYPE (object
))
182 case Lisp_Misc_Marker
:
184 case Lisp_Misc_Overlay
:
186 case Lisp_Misc_Float
:
191 case Lisp_Vectorlike
:
192 if (WINDOW_CONFIGURATIONP (object
))
193 return Qwindow_configuration
;
194 if (PROCESSP (object
))
196 if (WINDOWP (object
))
200 if (FUNVECP (object
))
201 if (FUNVEC_COMPILED_P (object
))
202 return Qcompiled_function
;
204 return Qfunction_vector
;
205 if (BUFFERP (object
))
207 if (CHAR_TABLE_P (object
))
209 if (BOOL_VECTOR_P (object
))
213 if (HASH_TABLE_P (object
))
215 if (FONT_SPEC_P (object
))
217 if (FONT_ENTITY_P (object
))
219 if (FONT_OBJECT_P (object
))
231 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
232 doc
: /* Return t if OBJECT is a cons cell. */)
240 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
241 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
249 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
250 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
251 Otherwise, return nil. */)
254 if (CONSP (object
) || NILP (object
))
259 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
260 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
263 if (CONSP (object
) || NILP (object
))
268 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
269 doc
: /* Return t if OBJECT is a symbol. */)
272 if (SYMBOLP (object
))
277 /* Define this in C to avoid unnecessarily consing up the symbol
279 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is a keyword.
281 This means that it is a symbol with a print name beginning with `:'
282 interned in the initial obarray. */)
286 && SREF (SYMBOL_NAME (object
), 0) == ':'
287 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
292 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
293 doc
: /* Return t if OBJECT is a vector. */)
296 if (VECTORP (object
))
301 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
302 doc
: /* Return t if OBJECT is a string. */)
305 if (STRINGP (object
))
310 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
312 doc
: /* Return t if OBJECT is a multibyte string. */)
315 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
320 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
321 doc
: /* Return t if OBJECT is a char-table. */)
324 if (CHAR_TABLE_P (object
))
329 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
330 Svector_or_char_table_p
, 1, 1, 0,
331 doc
: /* Return t if OBJECT is a char-table or vector. */)
334 if (VECTORP (object
) || CHAR_TABLE_P (object
))
339 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
340 doc
: /* Return t if OBJECT is a bool-vector. */)
343 if (BOOL_VECTOR_P (object
))
348 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
349 doc
: /* Return t if OBJECT is an array (string or vector). */)
357 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
358 doc
: /* Return t if OBJECT is a sequence (list or array). */)
359 (register Lisp_Object object
)
361 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
366 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
367 doc
: /* Return t if OBJECT is an editor buffer. */)
370 if (BUFFERP (object
))
375 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
376 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
379 if (MARKERP (object
))
384 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
385 doc
: /* Return t if OBJECT is a built-in function. */)
393 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
395 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
398 if (COMPILEDP (object
))
403 DEFUN ("funvecp", Ffunvecp
, Sfunvecp
, 1, 1, 0,
404 doc
: /* Return t if OBJECT is a `function vector' object. */)
407 return FUNVECP (object
) ? Qt
: Qnil
;
410 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
411 doc
: /* Return t if OBJECT is a character or a string. */)
412 (register Lisp_Object object
)
414 if (CHARACTERP (object
) || STRINGP (object
))
419 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
420 doc
: /* Return t if OBJECT is an integer. */)
423 if (INTEGERP (object
))
428 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
429 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
430 (register Lisp_Object object
)
432 if (MARKERP (object
) || INTEGERP (object
))
437 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
438 doc
: /* Return t if OBJECT is a nonnegative integer. */)
441 if (NATNUMP (object
))
446 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
447 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
450 if (NUMBERP (object
))
456 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
457 Snumber_or_marker_p
, 1, 1, 0,
458 doc
: /* Return t if OBJECT is a number or a marker. */)
461 if (NUMBERP (object
) || MARKERP (object
))
466 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
467 doc
: /* Return t if OBJECT is a floating point number. */)
476 /* Extract and set components of lists */
478 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
479 doc
: /* Return the car of LIST. If arg is nil, return nil.
480 Error if arg is not nil and not a cons cell. See also `car-safe'.
482 See Info node `(elisp)Cons Cells' for a discussion of related basic
483 Lisp concepts such as car, cdr, cons cell and list. */)
484 (register Lisp_Object list
)
489 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
490 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
493 return CAR_SAFE (object
);
496 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
497 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
498 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
500 See Info node `(elisp)Cons Cells' for a discussion of related basic
501 Lisp concepts such as cdr, car, cons cell and list. */)
502 (register Lisp_Object list
)
507 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
508 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
511 return CDR_SAFE (object
);
514 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
515 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
516 (register Lisp_Object cell
, Lisp_Object newcar
)
520 XSETCAR (cell
, newcar
);
524 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
525 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
526 (register Lisp_Object cell
, Lisp_Object newcdr
)
530 XSETCDR (cell
, newcdr
);
534 /* Extract and set components of symbols */
536 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
537 doc
: /* Return t if SYMBOL's value is not void. */)
538 (register Lisp_Object symbol
)
540 Lisp_Object valcontents
;
541 struct Lisp_Symbol
*sym
;
542 CHECK_SYMBOL (symbol
);
543 sym
= XSYMBOL (symbol
);
546 switch (sym
->redirect
)
548 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
549 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
550 case SYMBOL_LOCALIZED
:
552 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
554 /* In set_internal, we un-forward vars when their value is
559 swap_in_symval_forwarding (sym
, blv
);
560 valcontents
= BLV_VALUE (blv
);
564 case SYMBOL_FORWARDED
:
565 /* In set_internal, we un-forward vars when their value is
571 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
574 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
575 doc
: /* Return t if SYMBOL's function definition is not void. */)
576 (register Lisp_Object symbol
)
578 CHECK_SYMBOL (symbol
);
579 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
582 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
583 doc
: /* Make SYMBOL's value be void.
585 (register Lisp_Object symbol
)
587 CHECK_SYMBOL (symbol
);
588 if (SYMBOL_CONSTANT_P (symbol
))
589 xsignal1 (Qsetting_constant
, symbol
);
590 Fset (symbol
, Qunbound
);
594 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
595 doc
: /* Make SYMBOL's function definition be void.
597 (register Lisp_Object symbol
)
599 CHECK_SYMBOL (symbol
);
600 if (NILP (symbol
) || EQ (symbol
, Qt
))
601 xsignal1 (Qsetting_constant
, symbol
);
602 XSYMBOL (symbol
)->function
= Qunbound
;
606 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
607 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
608 (register Lisp_Object symbol
)
610 CHECK_SYMBOL (symbol
);
611 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
612 return XSYMBOL (symbol
)->function
;
613 xsignal1 (Qvoid_function
, symbol
);
616 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
617 doc
: /* Return SYMBOL's property list. */)
618 (register Lisp_Object symbol
)
620 CHECK_SYMBOL (symbol
);
621 return XSYMBOL (symbol
)->plist
;
624 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
625 doc
: /* Return SYMBOL's name, a string. */)
626 (register Lisp_Object symbol
)
628 register Lisp_Object name
;
630 CHECK_SYMBOL (symbol
);
631 name
= SYMBOL_NAME (symbol
);
635 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
636 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
637 (register Lisp_Object symbol
, Lisp_Object definition
)
639 register Lisp_Object function
;
641 CHECK_SYMBOL (symbol
);
642 if (NILP (symbol
) || EQ (symbol
, Qt
))
643 xsignal1 (Qsetting_constant
, symbol
);
645 function
= XSYMBOL (symbol
)->function
;
647 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
648 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
650 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
651 Fput (symbol
, Qautoload
, XCDR (function
));
653 XSYMBOL (symbol
)->function
= definition
;
654 /* Handle automatic advice activation */
655 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
657 call2 (Qad_activate_internal
, symbol
, Qnil
);
658 definition
= XSYMBOL (symbol
)->function
;
663 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
664 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
665 Associates the function with the current load file, if any.
666 The optional third argument DOCSTRING specifies the documentation string
667 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
668 determined by DEFINITION. */)
669 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
671 CHECK_SYMBOL (symbol
);
672 if (CONSP (XSYMBOL (symbol
)->function
)
673 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
674 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
675 definition
= Ffset (symbol
, definition
);
676 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
677 if (!NILP (docstring
))
678 Fput (symbol
, Qfunction_documentation
, docstring
);
682 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
683 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
684 (register Lisp_Object symbol
, Lisp_Object newplist
)
686 CHECK_SYMBOL (symbol
);
687 XSYMBOL (symbol
)->plist
= newplist
;
691 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
692 doc
: /* Return minimum and maximum number of args allowed for SUBR.
693 SUBR must be a built-in function.
694 The returned value is a pair (MIN . MAX). MIN is the minimum number
695 of args. MAX is the maximum number or the symbol `many', for a
696 function with `&rest' args, or `unevalled' for a special form. */)
699 short minargs
, maxargs
;
701 minargs
= XSUBR (subr
)->min_args
;
702 maxargs
= XSUBR (subr
)->max_args
;
704 return Fcons (make_number (minargs
), Qmany
);
705 else if (maxargs
== UNEVALLED
)
706 return Fcons (make_number (minargs
), Qunevalled
);
708 return Fcons (make_number (minargs
), make_number (maxargs
));
711 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
712 doc
: /* Return name of subroutine SUBR.
713 SUBR must be a built-in function. */)
718 name
= XSUBR (subr
)->symbol_name
;
719 return make_string (name
, strlen (name
));
722 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
723 doc
: /* Return the interactive form of CMD or nil if none.
724 If CMD is not a command, the return value is nil.
725 Value, if non-nil, is a list \(interactive SPEC). */)
728 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
730 if (NILP (fun
) || EQ (fun
, Qunbound
))
733 /* Use an `interactive-form' property if present, analogous to the
734 function-documentation property. */
736 while (SYMBOLP (fun
))
738 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
742 fun
= Fsymbol_function (fun
);
747 const char *spec
= XSUBR (fun
)->intspec
;
749 return list2 (Qinteractive
,
750 (*spec
!= '(') ? build_string (spec
) :
751 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
753 else if (COMPILEDP (fun
))
755 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
756 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
758 else if (CONSP (fun
))
760 Lisp_Object funcar
= XCAR (fun
);
761 if (EQ (funcar
, Qlambda
))
762 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
763 else if (EQ (funcar
, Qautoload
))
767 do_autoload (fun
, cmd
);
769 return Finteractive_form (cmd
);
776 /***********************************************************************
777 Getting and Setting Values of Symbols
778 ***********************************************************************/
780 /* Return the symbol holding SYMBOL's value. Signal
781 `cyclic-variable-indirection' if SYMBOL's chain of variable
782 indirections contains a loop. */
785 indirect_variable (struct Lisp_Symbol
*symbol
)
787 struct Lisp_Symbol
*tortoise
, *hare
;
789 hare
= tortoise
= symbol
;
791 while (hare
->redirect
== SYMBOL_VARALIAS
)
793 hare
= SYMBOL_ALIAS (hare
);
794 if (hare
->redirect
!= SYMBOL_VARALIAS
)
797 hare
= SYMBOL_ALIAS (hare
);
798 tortoise
= SYMBOL_ALIAS (tortoise
);
800 if (hare
== tortoise
)
803 XSETSYMBOL (tem
, symbol
);
804 xsignal1 (Qcyclic_variable_indirection
, tem
);
812 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
813 doc
: /* Return the variable at the end of OBJECT's variable chain.
814 If OBJECT is a symbol, follow all variable indirections and return the final
815 variable. If OBJECT is not a symbol, just return it.
816 Signal a cyclic-variable-indirection error if there is a loop in the
817 variable chain of symbols. */)
820 if (SYMBOLP (object
))
821 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
826 /* Given the raw contents of a symbol value cell,
827 return the Lisp value of the symbol.
828 This does not handle buffer-local variables; use
829 swap_in_symval_forwarding for that. */
831 #define do_blv_forwarding(blv) \
832 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
835 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
837 register Lisp_Object val
;
838 switch (XFWDTYPE (valcontents
))
841 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
845 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
848 return *XOBJFWD (valcontents
)->objvar
;
850 case Lisp_Fwd_Buffer_Obj
:
851 return PER_BUFFER_VALUE (current_buffer
,
852 XBUFFER_OBJFWD (valcontents
)->offset
);
854 case Lisp_Fwd_Kboard_Obj
:
855 /* We used to simply use current_kboard here, but from Lisp
856 code, it's value is often unexpected. It seems nicer to
857 allow constructions like this to work as intuitively expected:
859 (with-selected-frame frame
860 (define-key local-function-map "\eOP" [f1]))
862 On the other hand, this affects the semantics of
863 last-command and real-last-command, and people may rely on
864 that. I took a quick look at the Lisp codebase, and I
865 don't think anything will break. --lorentey */
866 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
867 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
872 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
873 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
874 buffer-independent contents of the value cell: forwarded just one
875 step past the buffer-localness.
877 BUF non-zero means set the value in buffer BUF instead of the
878 current buffer. This only plays a role for per-buffer variables. */
880 #define store_blv_forwarding(blv, newval, buf) \
882 if ((blv)->forwarded) \
883 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
885 SET_BLV_VALUE (blv, newval); \
889 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
891 switch (XFWDTYPE (valcontents
))
894 CHECK_NUMBER (newval
);
895 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
899 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
903 *XOBJFWD (valcontents
)->objvar
= newval
;
905 /* If this variable is a default for something stored
906 in the buffer itself, such as default-fill-column,
907 find the buffers that don't have local values for it
909 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
910 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
912 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
913 - (char *) &buffer_defaults
);
914 int idx
= PER_BUFFER_IDX (offset
);
921 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
926 buf
= Fcdr (XCAR (tail
));
927 if (!BUFFERP (buf
)) continue;
930 if (! PER_BUFFER_VALUE_P (b
, idx
))
931 PER_BUFFER_VALUE (b
, offset
) = newval
;
936 case Lisp_Fwd_Buffer_Obj
:
938 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
939 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
941 if (!(NILP (type
) || NILP (newval
)
942 || (XINT (type
) == LISP_INT_TAG
944 : XTYPE (newval
) == XINT (type
))))
945 buffer_slot_type_mismatch (newval
, XINT (type
));
948 buf
= current_buffer
;
949 PER_BUFFER_VALUE (buf
, offset
) = newval
;
953 case Lisp_Fwd_Kboard_Obj
:
955 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
956 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
957 *(Lisp_Object
*) p
= newval
;
962 abort (); /* goto def; */
966 /* Set up SYMBOL to refer to its global binding.
967 This makes it safe to alter the status of other bindings. */
970 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
972 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
974 /* Unload the previously loaded binding. */
976 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
978 /* Select the global binding in the symbol. */
979 blv
->valcell
= blv
->defcell
;
981 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
983 /* Indicate that the global binding is set up now. */
985 SET_BLV_FOUND (blv
, 0);
988 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
989 VALCONTENTS is the contents of its value cell,
990 which points to a struct Lisp_Buffer_Local_Value.
992 Return the value forwarded one step past the buffer-local stage.
993 This could be another forwarding pointer. */
996 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
998 register Lisp_Object tem1
;
1000 eassert (blv
== SYMBOL_BLV (symbol
));
1005 || (blv
->frame_local
1006 ? !EQ (selected_frame
, tem1
)
1007 : current_buffer
!= XBUFFER (tem1
)))
1010 /* Unload the previously loaded binding. */
1011 tem1
= blv
->valcell
;
1013 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1014 /* Choose the new binding. */
1017 XSETSYMBOL (var
, symbol
);
1018 if (blv
->frame_local
)
1020 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1021 blv
->where
= selected_frame
;
1025 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1026 XSETBUFFER (blv
->where
, current_buffer
);
1029 if (!(blv
->found
= !NILP (tem1
)))
1030 tem1
= blv
->defcell
;
1032 /* Load the new binding. */
1033 blv
->valcell
= tem1
;
1035 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1039 /* Find the value of a symbol, returning Qunbound if it's not bound.
1040 This is helpful for code which just wants to get a variable's value
1041 if it has one, without signaling an error.
1042 Note that it must not be possible to quit
1043 within this function. Great care is required for this. */
1046 find_symbol_value (Lisp_Object symbol
)
1048 struct Lisp_Symbol
*sym
;
1050 CHECK_SYMBOL (symbol
);
1051 sym
= XSYMBOL (symbol
);
1054 switch (sym
->redirect
)
1056 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1057 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1058 case SYMBOL_LOCALIZED
:
1060 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1061 swap_in_symval_forwarding (sym
, blv
);
1062 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1065 case SYMBOL_FORWARDED
:
1066 return do_symval_forwarding (SYMBOL_FWD (sym
));
1071 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1072 doc
: /* Return SYMBOL's value. Error if that is void. */)
1073 (Lisp_Object symbol
)
1077 val
= find_symbol_value (symbol
);
1078 if (!EQ (val
, Qunbound
))
1081 xsignal1 (Qvoid_variable
, symbol
);
1084 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1085 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1086 (register Lisp_Object symbol
, Lisp_Object newval
)
1088 set_internal (symbol
, newval
, Qnil
, 0);
1092 /* Return 1 if SYMBOL currently has a let-binding
1093 which was made in the buffer that is now current. */
1096 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1098 struct specbinding
*p
;
1100 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1102 && CONSP (p
->symbol
))
1104 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1105 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1106 if (symbol
== let_bound_symbol
1107 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1111 return p
>= specpdl
;
1115 let_shadows_global_binding_p (Lisp_Object symbol
)
1117 struct specbinding
*p
;
1119 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1120 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1123 return p
>= specpdl
;
1126 /* Store the value NEWVAL into SYMBOL.
1127 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1128 (nil stands for the current buffer/frame).
1130 If BINDFLAG is zero, then if this symbol is supposed to become
1131 local in every buffer where it is set, then we make it local.
1132 If BINDFLAG is nonzero, we don't do that. */
1135 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1137 int voide
= EQ (newval
, Qunbound
);
1138 struct Lisp_Symbol
*sym
;
1141 /* If restoring in a dead buffer, do nothing. */
1142 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1145 CHECK_SYMBOL (symbol
);
1146 if (SYMBOL_CONSTANT_P (symbol
))
1148 if (NILP (Fkeywordp (symbol
))
1149 || !EQ (newval
, Fsymbol_value (symbol
)))
1150 xsignal1 (Qsetting_constant
, symbol
);
1152 /* Allow setting keywords to their own value. */
1156 sym
= XSYMBOL (symbol
);
1159 switch (sym
->redirect
)
1161 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1162 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1163 case SYMBOL_LOCALIZED
:
1165 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1168 if (blv
->frame_local
)
1169 where
= selected_frame
;
1171 XSETBUFFER (where
, current_buffer
);
1173 /* If the current buffer is not the buffer whose binding is
1174 loaded, or if there may be frame-local bindings and the frame
1175 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1176 the default binding is loaded, the loaded binding may be the
1178 if (!EQ (blv
->where
, where
)
1179 /* Also unload a global binding (if the var is local_if_set). */
1180 || (EQ (blv
->valcell
, blv
->defcell
)))
1182 /* The currently loaded binding is not necessarily valid.
1183 We need to unload it, and choose a new binding. */
1185 /* Write out `realvalue' to the old loaded binding. */
1187 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1189 /* Find the new binding. */
1190 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1191 tem1
= Fassq (symbol
,
1193 ? XFRAME (where
)->param_alist
1194 : XBUFFER (where
)->local_var_alist
));
1200 /* This buffer still sees the default value. */
1202 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1203 or if this is `let' rather than `set',
1204 make CURRENT-ALIST-ELEMENT point to itself,
1205 indicating that we're seeing the default value.
1206 Likewise if the variable has been let-bound
1207 in the current buffer. */
1208 if (bindflag
|| !blv
->local_if_set
1209 || let_shadows_buffer_binding_p (sym
))
1212 tem1
= blv
->defcell
;
1214 /* If it's a local_if_set, being set not bound,
1215 and we're not within a let that was made for this buffer,
1216 create a new buffer-local binding for the variable.
1217 That means, give this buffer a new assoc for a local value
1218 and load that binding. */
1221 /* local_if_set is only supported for buffer-local
1222 bindings, not for frame-local bindings. */
1223 eassert (!blv
->frame_local
);
1224 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1225 XBUFFER (where
)->local_var_alist
1226 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1230 /* Record which binding is now loaded. */
1231 blv
->valcell
= tem1
;
1234 /* Store the new value in the cons cell. */
1235 SET_BLV_VALUE (blv
, newval
);
1240 /* If storing void (making the symbol void), forward only through
1241 buffer-local indicator, not through Lisp_Objfwd, etc. */
1244 store_symval_forwarding (blv
->fwd
, newval
,
1246 ? XBUFFER (where
) : current_buffer
);
1250 case SYMBOL_FORWARDED
:
1253 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1254 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1255 if (BUFFER_OBJFWDP (innercontents
))
1257 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1258 int idx
= PER_BUFFER_IDX (offset
);
1261 && !let_shadows_buffer_binding_p (sym
))
1262 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1266 { /* If storing void (making the symbol void), forward only through
1267 buffer-local indicator, not through Lisp_Objfwd, etc. */
1268 sym
->redirect
= SYMBOL_PLAINVAL
;
1269 SET_SYMBOL_VAL (sym
, newval
);
1272 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1280 /* Access or set a buffer-local symbol's default value. */
1282 /* Return the default value of SYMBOL, but don't check for voidness.
1283 Return Qunbound if it is void. */
1286 default_value (Lisp_Object symbol
)
1288 struct Lisp_Symbol
*sym
;
1290 CHECK_SYMBOL (symbol
);
1291 sym
= XSYMBOL (symbol
);
1294 switch (sym
->redirect
)
1296 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1297 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1298 case SYMBOL_LOCALIZED
:
1300 /* If var is set up for a buffer that lacks a local value for it,
1301 the current value is nominally the default value.
1302 But the `realvalue' slot may be more up to date, since
1303 ordinary setq stores just that slot. So use that. */
1304 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1305 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1306 return do_symval_forwarding (blv
->fwd
);
1308 return XCDR (blv
->defcell
);
1310 case SYMBOL_FORWARDED
:
1312 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1314 /* For a built-in buffer-local variable, get the default value
1315 rather than letting do_symval_forwarding get the current value. */
1316 if (BUFFER_OBJFWDP (valcontents
))
1318 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1319 if (PER_BUFFER_IDX (offset
) != 0)
1320 return PER_BUFFER_DEFAULT (offset
);
1323 /* For other variables, get the current value. */
1324 return do_symval_forwarding (valcontents
);
1330 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1331 doc
: /* Return t if SYMBOL has a non-void default value.
1332 This is the value that is seen in buffers that do not have their own values
1333 for this variable. */)
1334 (Lisp_Object symbol
)
1336 register Lisp_Object value
;
1338 value
= default_value (symbol
);
1339 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1342 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1343 doc
: /* Return SYMBOL's default value.
1344 This is the value that is seen in buffers that do not have their own values
1345 for this variable. The default value is meaningful for variables with
1346 local bindings in certain buffers. */)
1347 (Lisp_Object symbol
)
1349 register Lisp_Object value
;
1351 value
= default_value (symbol
);
1352 if (!EQ (value
, Qunbound
))
1355 xsignal1 (Qvoid_variable
, symbol
);
1358 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1359 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1360 The default value is seen in buffers that do not have their own values
1361 for this variable. */)
1362 (Lisp_Object symbol
, Lisp_Object value
)
1364 struct Lisp_Symbol
*sym
;
1366 CHECK_SYMBOL (symbol
);
1367 if (SYMBOL_CONSTANT_P (symbol
))
1369 if (NILP (Fkeywordp (symbol
))
1370 || !EQ (value
, Fdefault_value (symbol
)))
1371 xsignal1 (Qsetting_constant
, symbol
);
1373 /* Allow setting keywords to their own value. */
1376 sym
= XSYMBOL (symbol
);
1379 switch (sym
->redirect
)
1381 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1382 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1383 case SYMBOL_LOCALIZED
:
1385 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1387 /* Store new value into the DEFAULT-VALUE slot. */
1388 XSETCDR (blv
->defcell
, value
);
1390 /* If the default binding is now loaded, set the REALVALUE slot too. */
1391 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1392 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1395 case SYMBOL_FORWARDED
:
1397 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1399 /* Handle variables like case-fold-search that have special slots
1401 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1402 if (BUFFER_OBJFWDP (valcontents
))
1404 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1405 int idx
= PER_BUFFER_IDX (offset
);
1407 PER_BUFFER_DEFAULT (offset
) = value
;
1409 /* If this variable is not always local in all buffers,
1410 set it in the buffers that don't nominally have a local value. */
1415 for (b
= all_buffers
; b
; b
= b
->next
)
1416 if (!PER_BUFFER_VALUE_P (b
, idx
))
1417 PER_BUFFER_VALUE (b
, offset
) = value
;
1422 return Fset (symbol
, value
);
1428 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1429 doc
: /* Set the default value of variable VAR to VALUE.
1430 VAR, the variable name, is literal (not evaluated);
1431 VALUE is an expression: it is evaluated and its value returned.
1432 The default value of a variable is seen in buffers
1433 that do not have their own values for the variable.
1435 More generally, you can use multiple variables and values, as in
1436 (setq-default VAR VALUE VAR VALUE...)
1437 This sets each VAR's default value to the corresponding VALUE.
1438 The VALUE for the Nth VAR can refer to the new default values
1440 usage: (setq-default [VAR VALUE]...) */)
1443 register Lisp_Object args_left
;
1444 register Lisp_Object val
, symbol
;
1445 struct gcpro gcpro1
;
1455 val
= Feval (Fcar (Fcdr (args_left
)));
1456 symbol
= XCAR (args_left
);
1457 Fset_default (symbol
, val
);
1458 args_left
= Fcdr (XCDR (args_left
));
1460 while (!NILP (args_left
));
1466 /* Lisp functions for creating and removing buffer-local variables. */
1471 union Lisp_Fwd
*fwd
;
1474 static struct Lisp_Buffer_Local_Value
*
1475 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1477 struct Lisp_Buffer_Local_Value
*blv
1478 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1482 XSETSYMBOL (symbol
, sym
);
1483 tem
= Fcons (symbol
, (forwarded
1484 ? do_symval_forwarding (valcontents
.fwd
)
1485 : valcontents
.value
));
1487 /* Buffer_Local_Values cannot have as realval a buffer-local
1488 or keyboard-local forwarding. */
1489 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1490 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1491 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1493 blv
->frame_local
= 0;
1494 blv
->local_if_set
= 0;
1497 SET_BLV_FOUND (blv
, 0);
1501 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1502 1, 1, "vMake Variable Buffer Local: ",
1503 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1504 At any time, the value for the current buffer is in effect,
1505 unless the variable has never been set in this buffer,
1506 in which case the default value is in effect.
1507 Note that binding the variable with `let', or setting it while
1508 a `let'-style binding made in this buffer is in effect,
1509 does not make the variable buffer-local. Return VARIABLE.
1511 In most cases it is better to use `make-local-variable',
1512 which makes a variable local in just one buffer.
1514 The function `default-value' gets the default value and `set-default' sets it. */)
1515 (register Lisp_Object variable
)
1517 struct Lisp_Symbol
*sym
;
1518 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1519 union Lisp_Val_Fwd valcontents
;
1522 CHECK_SYMBOL (variable
);
1523 sym
= XSYMBOL (variable
);
1526 switch (sym
->redirect
)
1528 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1529 case SYMBOL_PLAINVAL
:
1530 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1531 if (EQ (valcontents
.value
, Qunbound
))
1532 valcontents
.value
= Qnil
;
1534 case SYMBOL_LOCALIZED
:
1535 blv
= SYMBOL_BLV (sym
);
1536 if (blv
->frame_local
)
1537 error ("Symbol %s may not be buffer-local",
1538 SDATA (SYMBOL_NAME (variable
)));
1540 case SYMBOL_FORWARDED
:
1541 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1542 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1543 error ("Symbol %s may not be buffer-local",
1544 SDATA (SYMBOL_NAME (variable
)));
1545 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1552 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1556 blv
= make_blv (sym
, forwarded
, valcontents
);
1557 sym
->redirect
= SYMBOL_LOCALIZED
;
1558 SET_SYMBOL_BLV (sym
, blv
);
1561 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1562 if (let_shadows_global_binding_p (symbol
))
1563 message ("Making %s buffer-local while let-bound!",
1564 SDATA (SYMBOL_NAME (variable
)));
1568 blv
->local_if_set
= 1;
1572 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1573 1, 1, "vMake Local Variable: ",
1574 doc
: /* Make VARIABLE have a separate value in the current buffer.
1575 Other buffers will continue to share a common default value.
1576 \(The buffer-local value of VARIABLE starts out as the same value
1577 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1580 If the variable is already arranged to become local when set,
1581 this function causes a local value to exist for this buffer,
1582 just as setting the variable would do.
1584 This function returns VARIABLE, and therefore
1585 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1588 See also `make-variable-buffer-local'.
1590 Do not use `make-local-variable' to make a hook variable buffer-local.
1591 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1592 (register Lisp_Object variable
)
1594 register Lisp_Object tem
;
1596 union Lisp_Val_Fwd valcontents
;
1597 struct Lisp_Symbol
*sym
;
1598 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1600 CHECK_SYMBOL (variable
);
1601 sym
= XSYMBOL (variable
);
1604 switch (sym
->redirect
)
1606 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1607 case SYMBOL_PLAINVAL
:
1608 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1609 case SYMBOL_LOCALIZED
:
1610 blv
= SYMBOL_BLV (sym
);
1611 if (blv
->frame_local
)
1612 error ("Symbol %s may not be buffer-local",
1613 SDATA (SYMBOL_NAME (variable
)));
1615 case SYMBOL_FORWARDED
:
1616 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1617 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1618 error ("Symbol %s may not be buffer-local",
1619 SDATA (SYMBOL_NAME (variable
)));
1625 error ("Symbol %s may not be buffer-local",
1626 SDATA (SYMBOL_NAME (variable
)));
1628 if (blv
? blv
->local_if_set
1629 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1631 tem
= Fboundp (variable
);
1632 /* Make sure the symbol has a local value in this particular buffer,
1633 by setting it to the same value it already has. */
1634 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1639 blv
= make_blv (sym
, forwarded
, valcontents
);
1640 sym
->redirect
= SYMBOL_LOCALIZED
;
1641 SET_SYMBOL_BLV (sym
, blv
);
1644 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1645 if (let_shadows_global_binding_p (symbol
))
1646 message ("Making %s local to %s while let-bound!",
1647 SDATA (SYMBOL_NAME (variable
)),
1648 SDATA (current_buffer
->name
));
1652 /* Make sure this buffer has its own value of symbol. */
1653 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1654 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1657 if (let_shadows_buffer_binding_p (sym
))
1658 message ("Making %s buffer-local while locally let-bound!",
1659 SDATA (SYMBOL_NAME (variable
)));
1661 /* Swap out any local binding for some other buffer, and make
1662 sure the current value is permanently recorded, if it's the
1664 find_symbol_value (variable
);
1666 current_buffer
->local_var_alist
1667 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1668 current_buffer
->local_var_alist
);
1670 /* Make sure symbol does not think it is set up for this buffer;
1671 force it to look once again for this buffer's value. */
1672 if (current_buffer
== XBUFFER (blv
->where
))
1674 /* blv->valcell = blv->defcell;
1675 * SET_BLV_FOUND (blv, 0); */
1679 /* If the symbol forwards into a C variable, then load the binding
1680 for this buffer now. If C code modifies the variable before we
1681 load the binding in, then that new value will clobber the default
1682 binding the next time we unload it. */
1684 swap_in_symval_forwarding (sym
, blv
);
1689 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1690 1, 1, "vKill Local Variable: ",
1691 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1692 From now on the default value will apply in this buffer. Return VARIABLE. */)
1693 (register Lisp_Object variable
)
1695 register Lisp_Object tem
;
1696 struct Lisp_Buffer_Local_Value
*blv
;
1697 struct Lisp_Symbol
*sym
;
1699 CHECK_SYMBOL (variable
);
1700 sym
= XSYMBOL (variable
);
1703 switch (sym
->redirect
)
1705 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1706 case SYMBOL_PLAINVAL
: return variable
;
1707 case SYMBOL_FORWARDED
:
1709 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1710 if (BUFFER_OBJFWDP (valcontents
))
1712 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1713 int idx
= PER_BUFFER_IDX (offset
);
1717 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1718 PER_BUFFER_VALUE (current_buffer
, offset
)
1719 = PER_BUFFER_DEFAULT (offset
);
1724 case SYMBOL_LOCALIZED
:
1725 blv
= SYMBOL_BLV (sym
);
1726 if (blv
->frame_local
)
1732 /* Get rid of this buffer's alist element, if any. */
1733 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1734 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1736 current_buffer
->local_var_alist
1737 = Fdelq (tem
, current_buffer
->local_var_alist
);
1739 /* If the symbol is set up with the current buffer's binding
1740 loaded, recompute its value. We have to do it now, or else
1741 forwarded objects won't work right. */
1743 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1744 if (EQ (buf
, blv
->where
))
1747 /* blv->valcell = blv->defcell;
1748 * SET_BLV_FOUND (blv, 0); */
1750 find_symbol_value (variable
);
1757 /* Lisp functions for creating and removing buffer-local variables. */
1759 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1760 when/if this is removed. */
1762 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1763 1, 1, "vMake Variable Frame Local: ",
1764 doc
: /* Enable VARIABLE to have frame-local bindings.
1765 This does not create any frame-local bindings for VARIABLE,
1766 it just makes them possible.
1768 A frame-local binding is actually a frame parameter value.
1769 If a frame F has a value for the frame parameter named VARIABLE,
1770 that also acts as a frame-local binding for VARIABLE in F--
1771 provided this function has been called to enable VARIABLE
1772 to have frame-local bindings at all.
1774 The only way to create a frame-local binding for VARIABLE in a frame
1775 is to set the VARIABLE frame parameter of that frame. See
1776 `modify-frame-parameters' for how to set frame parameters.
1778 Note that since Emacs 23.1, variables cannot be both buffer-local and
1779 frame-local any more (buffer-local bindings used to take precedence over
1780 frame-local bindings). */)
1781 (register Lisp_Object variable
)
1784 union Lisp_Val_Fwd valcontents
;
1785 struct Lisp_Symbol
*sym
;
1786 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1788 CHECK_SYMBOL (variable
);
1789 sym
= XSYMBOL (variable
);
1792 switch (sym
->redirect
)
1794 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1795 case SYMBOL_PLAINVAL
:
1796 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1797 if (EQ (valcontents
.value
, Qunbound
))
1798 valcontents
.value
= Qnil
;
1800 case SYMBOL_LOCALIZED
:
1801 if (SYMBOL_BLV (sym
)->frame_local
)
1804 error ("Symbol %s may not be frame-local",
1805 SDATA (SYMBOL_NAME (variable
)));
1806 case SYMBOL_FORWARDED
:
1807 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1808 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1809 error ("Symbol %s may not be frame-local",
1810 SDATA (SYMBOL_NAME (variable
)));
1816 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1818 blv
= make_blv (sym
, forwarded
, valcontents
);
1819 blv
->frame_local
= 1;
1820 sym
->redirect
= SYMBOL_LOCALIZED
;
1821 SET_SYMBOL_BLV (sym
, blv
);
1824 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1825 if (let_shadows_global_binding_p (symbol
))
1826 message ("Making %s frame-local while let-bound!",
1827 SDATA (SYMBOL_NAME (variable
)));
1832 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1834 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1835 BUFFER defaults to the current buffer. */)
1836 (register Lisp_Object variable
, Lisp_Object buffer
)
1838 register struct buffer
*buf
;
1839 struct Lisp_Symbol
*sym
;
1842 buf
= current_buffer
;
1845 CHECK_BUFFER (buffer
);
1846 buf
= XBUFFER (buffer
);
1849 CHECK_SYMBOL (variable
);
1850 sym
= XSYMBOL (variable
);
1853 switch (sym
->redirect
)
1855 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1856 case SYMBOL_PLAINVAL
: return Qnil
;
1857 case SYMBOL_LOCALIZED
:
1859 Lisp_Object tail
, elt
, tmp
;
1860 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1861 XSETBUFFER (tmp
, buf
);
1862 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1864 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1867 if (EQ (variable
, XCAR (elt
)))
1869 eassert (!blv
->frame_local
);
1870 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1874 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1877 case SYMBOL_FORWARDED
:
1879 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1880 if (BUFFER_OBJFWDP (valcontents
))
1882 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1883 int idx
= PER_BUFFER_IDX (offset
);
1884 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1893 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1895 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1896 More precisely, this means that setting the variable \(with `set' or`setq'),
1897 while it does not have a `let'-style binding that was made in BUFFER,
1898 will produce a buffer local binding. See Info node
1899 `(elisp)Creating Buffer-Local'.
1900 BUFFER defaults to the current buffer. */)
1901 (register Lisp_Object variable
, Lisp_Object buffer
)
1903 struct Lisp_Symbol
*sym
;
1905 CHECK_SYMBOL (variable
);
1906 sym
= XSYMBOL (variable
);
1909 switch (sym
->redirect
)
1911 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1912 case SYMBOL_PLAINVAL
: return Qnil
;
1913 case SYMBOL_LOCALIZED
:
1915 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1916 if (blv
->local_if_set
)
1918 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1919 return Flocal_variable_p (variable
, buffer
);
1921 case SYMBOL_FORWARDED
:
1922 /* All BUFFER_OBJFWD slots become local if they are set. */
1923 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1928 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1930 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1931 If the current binding is buffer-local, the value is the current buffer.
1932 If the current binding is frame-local, the value is the selected frame.
1933 If the current binding is global (the default), the value is nil. */)
1934 (register Lisp_Object variable
)
1936 struct Lisp_Symbol
*sym
;
1938 CHECK_SYMBOL (variable
);
1939 sym
= XSYMBOL (variable
);
1941 /* Make sure the current binding is actually swapped in. */
1942 find_symbol_value (variable
);
1945 switch (sym
->redirect
)
1947 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1948 case SYMBOL_PLAINVAL
: return Qnil
;
1949 case SYMBOL_FORWARDED
:
1951 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1952 if (KBOARD_OBJFWDP (valcontents
))
1953 return Fframe_terminal (Fselected_frame ());
1954 else if (!BUFFER_OBJFWDP (valcontents
))
1958 case SYMBOL_LOCALIZED
:
1959 /* For a local variable, record both the symbol and which
1960 buffer's or frame's value we are saving. */
1961 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1962 return Fcurrent_buffer ();
1963 else if (sym
->redirect
== SYMBOL_LOCALIZED
1964 && BLV_FOUND (SYMBOL_BLV (sym
)))
1965 return SYMBOL_BLV (sym
)->where
;
1972 /* This code is disabled now that we use the selected frame to return
1973 keyboard-local-values. */
1975 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1977 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1978 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1979 If SYMBOL is not a terminal-local variable, then return its normal
1980 value, like `symbol-value'.
1982 TERMINAL may be a terminal object, a frame, or nil (meaning the
1983 selected frame's terminal device). */)
1984 (Lisp_Object symbol
, Lisp_Object terminal
)
1987 struct terminal
*t
= get_terminal (terminal
, 1);
1988 push_kboard (t
->kboard
);
1989 result
= Fsymbol_value (symbol
);
1994 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1995 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1996 If VARIABLE is not a terminal-local variable, then set its normal
1997 binding, like `set'.
1999 TERMINAL may be a terminal object, a frame, or nil (meaning the
2000 selected frame's terminal device). */)
2001 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2004 struct terminal
*t
= get_terminal (terminal
, 1);
2005 push_kboard (d
->kboard
);
2006 result
= Fset (symbol
, value
);
2012 /* Find the function at the end of a chain of symbol function indirections. */
2014 /* If OBJECT is a symbol, find the end of its function chain and
2015 return the value found there. If OBJECT is not a symbol, just
2016 return it. If there is a cycle in the function chain, signal a
2017 cyclic-function-indirection error.
2019 This is like Findirect_function, except that it doesn't signal an
2020 error if the chain ends up unbound. */
2022 indirect_function (register Lisp_Object object
)
2024 Lisp_Object tortoise
, hare
;
2026 hare
= tortoise
= object
;
2030 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2032 hare
= XSYMBOL (hare
)->function
;
2033 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2035 hare
= XSYMBOL (hare
)->function
;
2037 tortoise
= XSYMBOL (tortoise
)->function
;
2039 if (EQ (hare
, tortoise
))
2040 xsignal1 (Qcyclic_function_indirection
, object
);
2046 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2047 doc
: /* Return the function at the end of OBJECT's function chain.
2048 If OBJECT is not a symbol, just return it. Otherwise, follow all
2049 function indirections to find the final function binding and return it.
2050 If the final symbol in the chain is unbound, signal a void-function error.
2051 Optional arg NOERROR non-nil means to return nil instead of signalling.
2052 Signal a cyclic-function-indirection error if there is a loop in the
2053 function chain of symbols. */)
2054 (register Lisp_Object object
, Lisp_Object noerror
)
2058 /* Optimize for no indirection. */
2060 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2061 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2062 result
= indirect_function (result
);
2063 if (!EQ (result
, Qunbound
))
2067 xsignal1 (Qvoid_function
, object
);
2072 /* Extract and set vector and string elements */
2074 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2075 doc
: /* Return the element of ARRAY at index IDX.
2076 ARRAY may be a vector, a string, a char-table, a bool-vector,
2077 or a byte-code object. IDX starts at 0. */)
2078 (register Lisp_Object array
, Lisp_Object idx
)
2080 register EMACS_INT idxval
;
2083 idxval
= XINT (idx
);
2084 if (STRINGP (array
))
2087 EMACS_INT idxval_byte
;
2089 if (idxval
< 0 || idxval
>= SCHARS (array
))
2090 args_out_of_range (array
, idx
);
2091 if (! STRING_MULTIBYTE (array
))
2092 return make_number ((unsigned char) SREF (array
, idxval
));
2093 idxval_byte
= string_char_to_byte (array
, idxval
);
2095 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2096 return make_number (c
);
2098 else if (BOOL_VECTOR_P (array
))
2102 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2103 args_out_of_range (array
, idx
);
2105 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2106 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2108 else if (CHAR_TABLE_P (array
))
2110 CHECK_CHARACTER (idx
);
2111 return CHAR_TABLE_REF (array
, idxval
);
2116 if (VECTORP (array
))
2117 size
= ASIZE (array
);
2118 else if (FUNVECP (array
))
2119 size
= FUNVEC_SIZE (array
);
2121 wrong_type_argument (Qarrayp
, array
);
2123 if (idxval
< 0 || idxval
>= size
)
2124 args_out_of_range (array
, idx
);
2125 return AREF (array
, idxval
);
2129 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2130 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2131 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2132 bool-vector. IDX starts at 0. */)
2133 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2135 register EMACS_INT idxval
;
2138 idxval
= XINT (idx
);
2139 CHECK_ARRAY (array
, Qarrayp
);
2140 CHECK_IMPURE (array
);
2142 if (VECTORP (array
))
2144 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2145 args_out_of_range (array
, idx
);
2146 XVECTOR (array
)->contents
[idxval
] = newelt
;
2148 else if (BOOL_VECTOR_P (array
))
2152 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2153 args_out_of_range (array
, idx
);
2155 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2157 if (! NILP (newelt
))
2158 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2160 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2161 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2163 else if (CHAR_TABLE_P (array
))
2165 CHECK_CHARACTER (idx
);
2166 CHAR_TABLE_SET (array
, idxval
, newelt
);
2168 else if (STRING_MULTIBYTE (array
))
2170 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2171 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2173 if (idxval
< 0 || idxval
>= SCHARS (array
))
2174 args_out_of_range (array
, idx
);
2175 CHECK_CHARACTER (newelt
);
2177 nbytes
= SBYTES (array
);
2179 idxval_byte
= string_char_to_byte (array
, idxval
);
2180 p1
= SDATA (array
) + idxval_byte
;
2181 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2182 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2183 if (prev_bytes
!= new_bytes
)
2185 /* We must relocate the string data. */
2186 EMACS_INT nchars
= SCHARS (array
);
2190 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2191 memcpy (str
, SDATA (array
), nbytes
);
2192 allocate_string_data (XSTRING (array
), nchars
,
2193 nbytes
+ new_bytes
- prev_bytes
);
2194 memcpy (SDATA (array
), str
, idxval_byte
);
2195 p1
= SDATA (array
) + idxval_byte
;
2196 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2197 nbytes
- (idxval_byte
+ prev_bytes
));
2199 clear_string_char_byte_cache ();
2206 if (idxval
< 0 || idxval
>= SCHARS (array
))
2207 args_out_of_range (array
, idx
);
2208 CHECK_NUMBER (newelt
);
2210 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2214 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2215 if (SREF (array
, i
) >= 0x80)
2216 args_out_of_range (array
, newelt
);
2217 /* ARRAY is an ASCII string. Convert it to a multibyte
2218 string, and try `aset' again. */
2219 STRING_SET_MULTIBYTE (array
);
2220 return Faset (array
, idx
, newelt
);
2222 SSET (array
, idxval
, XINT (newelt
));
2228 /* Arithmetic functions */
2230 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2233 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2235 double f1
= 0, f2
= 0;
2238 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2239 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2241 if (FLOATP (num1
) || FLOATP (num2
))
2244 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2245 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2251 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2256 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2261 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2266 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2271 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2276 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2285 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2286 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2287 (register Lisp_Object num1
, Lisp_Object num2
)
2289 return arithcompare (num1
, num2
, equal
);
2292 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2293 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2294 (register Lisp_Object num1
, Lisp_Object num2
)
2296 return arithcompare (num1
, num2
, less
);
2299 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2300 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2301 (register Lisp_Object num1
, Lisp_Object num2
)
2303 return arithcompare (num1
, num2
, grtr
);
2306 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2307 doc
: /* Return t if first arg is less than or equal to second arg.
2308 Both must be numbers or markers. */)
2309 (register Lisp_Object num1
, Lisp_Object num2
)
2311 return arithcompare (num1
, num2
, less_or_equal
);
2314 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2315 doc
: /* Return t if first arg is greater than or equal to second arg.
2316 Both must be numbers or markers. */)
2317 (register Lisp_Object num1
, Lisp_Object num2
)
2319 return arithcompare (num1
, num2
, grtr_or_equal
);
2322 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2323 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2324 (register Lisp_Object num1
, Lisp_Object num2
)
2326 return arithcompare (num1
, num2
, notequal
);
2329 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2330 doc
: /* Return t if NUMBER is zero. */)
2331 (register Lisp_Object number
)
2333 CHECK_NUMBER_OR_FLOAT (number
);
2335 if (FLOATP (number
))
2337 if (XFLOAT_DATA (number
) == 0.0)
2347 /* Convert between long values and pairs of Lisp integers.
2348 Note that long_to_cons returns a single Lisp integer
2349 when the value fits in one. */
2352 long_to_cons (long unsigned int i
)
2354 unsigned long top
= i
>> 16;
2355 unsigned int bot
= i
& 0xFFFF;
2357 return make_number (bot
);
2358 if (top
== (unsigned long)-1 >> 16)
2359 return Fcons (make_number (-1), make_number (bot
));
2360 return Fcons (make_number (top
), make_number (bot
));
2364 cons_to_long (Lisp_Object c
)
2366 Lisp_Object top
, bot
;
2373 return ((XINT (top
) << 16) | XINT (bot
));
2376 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2377 doc
: /* Return the decimal representation of NUMBER as a string.
2378 Uses a minus sign if negative.
2379 NUMBER may be an integer or a floating point number. */)
2380 (Lisp_Object number
)
2382 char buffer
[VALBITS
];
2384 CHECK_NUMBER_OR_FLOAT (number
);
2386 if (FLOATP (number
))
2388 char pigbuf
[350]; /* see comments in float_to_string */
2390 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2391 return build_string (pigbuf
);
2394 if (sizeof (int) == sizeof (EMACS_INT
))
2395 sprintf (buffer
, "%d", (int) XINT (number
));
2396 else if (sizeof (long) == sizeof (EMACS_INT
))
2397 sprintf (buffer
, "%ld", (long) XINT (number
));
2400 return build_string (buffer
);
2404 digit_to_number (int character
, int base
)
2408 if (character
>= '0' && character
<= '9')
2409 digit
= character
- '0';
2410 else if (character
>= 'a' && character
<= 'z')
2411 digit
= character
- 'a' + 10;
2412 else if (character
>= 'A' && character
<= 'Z')
2413 digit
= character
- 'A' + 10;
2423 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2424 doc
: /* Parse STRING as a decimal number and return the number.
2425 This parses both integers and floating point numbers.
2426 It ignores leading spaces and tabs, and all trailing chars.
2428 If BASE, interpret STRING as a number in that base. If BASE isn't
2429 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2430 If the base used is not 10, STRING is always parsed as integer. */)
2431 (register Lisp_Object string
, Lisp_Object base
)
2433 register unsigned char *p
;
2438 CHECK_STRING (string
);
2444 CHECK_NUMBER (base
);
2446 if (b
< 2 || b
> 16)
2447 xsignal1 (Qargs_out_of_range
, base
);
2450 /* Skip any whitespace at the front of the number. Some versions of
2451 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2453 while (*p
== ' ' || *p
== '\t')
2464 if (isfloat_string (p
, 1) && b
== 10)
2465 val
= make_float (sign
* atof (p
));
2472 int digit
= digit_to_number (*p
++, b
);
2478 val
= make_fixnum_or_float (sign
* v
);
2498 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2499 int, Lisp_Object
*);
2501 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2503 register Lisp_Object val
;
2504 register int argnum
;
2505 register EMACS_INT accum
= 0;
2506 register EMACS_INT next
;
2508 switch (SWITCH_ENUM_CAST (code
))
2526 for (argnum
= 0; argnum
< nargs
; argnum
++)
2528 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2530 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2533 return float_arith_driver ((double) accum
, argnum
, code
,
2536 next
= XINT (args
[argnum
]);
2537 switch (SWITCH_ENUM_CAST (code
))
2543 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2554 xsignal0 (Qarith_error
);
2568 if (!argnum
|| next
> accum
)
2572 if (!argnum
|| next
< accum
)
2578 XSETINT (val
, accum
);
2583 #define isnan(x) ((x) != (x))
2586 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2588 register Lisp_Object val
;
2591 for (; argnum
< nargs
; argnum
++)
2593 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2594 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2598 next
= XFLOAT_DATA (val
);
2602 args
[argnum
] = val
; /* runs into a compiler bug. */
2603 next
= XINT (args
[argnum
]);
2605 switch (SWITCH_ENUM_CAST (code
))
2611 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2621 if (! IEEE_FLOATING_POINT
&& next
== 0)
2622 xsignal0 (Qarith_error
);
2629 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2631 if (!argnum
|| isnan (next
) || next
> accum
)
2635 if (!argnum
|| isnan (next
) || next
< accum
)
2641 return make_float (accum
);
2645 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2646 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2647 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2648 (int nargs
, Lisp_Object
*args
)
2650 return arith_driver (Aadd
, nargs
, args
);
2653 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2654 doc
: /* Negate number or subtract numbers or markers and return the result.
2655 With one arg, negates it. With more than one arg,
2656 subtracts all but the first from the first.
2657 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2658 (int nargs
, Lisp_Object
*args
)
2660 return arith_driver (Asub
, nargs
, args
);
2663 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2664 doc
: /* Return product of any number of arguments, which are numbers or markers.
2665 usage: (* &rest NUMBERS-OR-MARKERS) */)
2666 (int nargs
, Lisp_Object
*args
)
2668 return arith_driver (Amult
, nargs
, args
);
2671 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2672 doc
: /* Return first argument divided by all the remaining arguments.
2673 The arguments must be numbers or markers.
2674 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2675 (int nargs
, Lisp_Object
*args
)
2678 for (argnum
= 2; argnum
< nargs
; argnum
++)
2679 if (FLOATP (args
[argnum
]))
2680 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2681 return arith_driver (Adiv
, nargs
, args
);
2684 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2685 doc
: /* Return remainder of X divided by Y.
2686 Both must be integers or markers. */)
2687 (register Lisp_Object x
, Lisp_Object y
)
2691 CHECK_NUMBER_COERCE_MARKER (x
);
2692 CHECK_NUMBER_COERCE_MARKER (y
);
2694 if (XFASTINT (y
) == 0)
2695 xsignal0 (Qarith_error
);
2697 XSETINT (val
, XINT (x
) % XINT (y
));
2711 /* If the magnitude of the result exceeds that of the divisor, or
2712 the sign of the result does not agree with that of the dividend,
2713 iterate with the reduced value. This does not yield a
2714 particularly accurate result, but at least it will be in the
2715 range promised by fmod. */
2717 r
-= f2
* floor (r
/ f2
);
2718 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2722 #endif /* ! HAVE_FMOD */
2724 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2725 doc
: /* Return X modulo Y.
2726 The result falls between zero (inclusive) and Y (exclusive).
2727 Both X and Y must be numbers or markers. */)
2728 (register Lisp_Object x
, Lisp_Object y
)
2733 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2734 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2736 if (FLOATP (x
) || FLOATP (y
))
2737 return fmod_float (x
, y
);
2743 xsignal0 (Qarith_error
);
2747 /* If the "remainder" comes out with the wrong sign, fix it. */
2748 if (i2
< 0 ? i1
> 0 : i1
< 0)
2755 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2756 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2757 The value is always a number; markers are converted to numbers.
2758 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2759 (int nargs
, Lisp_Object
*args
)
2761 return arith_driver (Amax
, nargs
, args
);
2764 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2765 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2766 The value is always a number; markers are converted to numbers.
2767 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2768 (int nargs
, Lisp_Object
*args
)
2770 return arith_driver (Amin
, nargs
, args
);
2773 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2774 doc
: /* Return bitwise-and of all the arguments.
2775 Arguments may be integers, or markers converted to integers.
2776 usage: (logand &rest INTS-OR-MARKERS) */)
2777 (int nargs
, Lisp_Object
*args
)
2779 return arith_driver (Alogand
, nargs
, args
);
2782 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2783 doc
: /* Return bitwise-or of all the arguments.
2784 Arguments may be integers, or markers converted to integers.
2785 usage: (logior &rest INTS-OR-MARKERS) */)
2786 (int nargs
, Lisp_Object
*args
)
2788 return arith_driver (Alogior
, nargs
, args
);
2791 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2792 doc
: /* Return bitwise-exclusive-or of all the arguments.
2793 Arguments may be integers, or markers converted to integers.
2794 usage: (logxor &rest INTS-OR-MARKERS) */)
2795 (int nargs
, Lisp_Object
*args
)
2797 return arith_driver (Alogxor
, nargs
, args
);
2800 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2801 doc
: /* Return VALUE with its bits shifted left by COUNT.
2802 If COUNT is negative, shifting is actually to the right.
2803 In this case, the sign bit is duplicated. */)
2804 (register Lisp_Object value
, Lisp_Object count
)
2806 register Lisp_Object val
;
2808 CHECK_NUMBER (value
);
2809 CHECK_NUMBER (count
);
2811 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2813 else if (XINT (count
) > 0)
2814 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2815 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2816 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2818 XSETINT (val
, XINT (value
) >> -XINT (count
));
2822 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2823 doc
: /* Return VALUE with its bits shifted left by COUNT.
2824 If COUNT is negative, shifting is actually to the right.
2825 In this case, zeros are shifted in on the left. */)
2826 (register Lisp_Object value
, Lisp_Object count
)
2828 register Lisp_Object val
;
2830 CHECK_NUMBER (value
);
2831 CHECK_NUMBER (count
);
2833 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2835 else if (XINT (count
) > 0)
2836 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2837 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2840 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2844 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2845 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2846 Markers are converted to integers. */)
2847 (register Lisp_Object number
)
2849 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2851 if (FLOATP (number
))
2852 return (make_float (1.0 + XFLOAT_DATA (number
)));
2854 XSETINT (number
, XINT (number
) + 1);
2858 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2859 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2860 Markers are converted to integers. */)
2861 (register Lisp_Object number
)
2863 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2865 if (FLOATP (number
))
2866 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2868 XSETINT (number
, XINT (number
) - 1);
2872 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2873 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2874 (register Lisp_Object number
)
2876 CHECK_NUMBER (number
);
2877 XSETINT (number
, ~XINT (number
));
2881 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2882 doc
: /* Return the byteorder for the machine.
2883 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2884 lowercase l) for small endian machines. */)
2887 unsigned i
= 0x04030201;
2888 int order
= *(char *)&i
== 1 ? 108 : 66;
2890 return make_number (order
);
2898 Lisp_Object error_tail
, arith_tail
;
2900 Qquote
= intern_c_string ("quote");
2901 Qlambda
= intern_c_string ("lambda");
2902 Qsubr
= intern_c_string ("subr");
2903 Qerror_conditions
= intern_c_string ("error-conditions");
2904 Qerror_message
= intern_c_string ("error-message");
2905 Qtop_level
= intern_c_string ("top-level");
2907 Qerror
= intern_c_string ("error");
2908 Qquit
= intern_c_string ("quit");
2909 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2910 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2911 Qvoid_function
= intern_c_string ("void-function");
2912 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2913 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2914 Qvoid_variable
= intern_c_string ("void-variable");
2915 Qsetting_constant
= intern_c_string ("setting-constant");
2916 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2918 Qinvalid_function
= intern_c_string ("invalid-function");
2919 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2920 Qno_catch
= intern_c_string ("no-catch");
2921 Qend_of_file
= intern_c_string ("end-of-file");
2922 Qarith_error
= intern_c_string ("arith-error");
2923 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2924 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2925 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2926 Qtext_read_only
= intern_c_string ("text-read-only");
2927 Qmark_inactive
= intern_c_string ("mark-inactive");
2929 Qlistp
= intern_c_string ("listp");
2930 Qconsp
= intern_c_string ("consp");
2931 Qsymbolp
= intern_c_string ("symbolp");
2932 Qkeywordp
= intern_c_string ("keywordp");
2933 Qintegerp
= intern_c_string ("integerp");
2934 Qnatnump
= intern_c_string ("natnump");
2935 Qwholenump
= intern_c_string ("wholenump");
2936 Qstringp
= intern_c_string ("stringp");
2937 Qarrayp
= intern_c_string ("arrayp");
2938 Qsequencep
= intern_c_string ("sequencep");
2939 Qbufferp
= intern_c_string ("bufferp");
2940 Qvectorp
= intern_c_string ("vectorp");
2941 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2942 Qmarkerp
= intern_c_string ("markerp");
2943 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2944 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2945 Qboundp
= intern_c_string ("boundp");
2946 Qfboundp
= intern_c_string ("fboundp");
2948 Qfloatp
= intern_c_string ("floatp");
2949 Qnumberp
= intern_c_string ("numberp");
2950 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2952 Qchar_table_p
= intern_c_string ("char-table-p");
2953 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2955 Qsubrp
= intern_c_string ("subrp");
2956 Qunevalled
= intern_c_string ("unevalled");
2957 Qmany
= intern_c_string ("many");
2959 Qcdr
= intern_c_string ("cdr");
2961 /* Handle automatic advice activation */
2962 Qad_advice_info
= intern_c_string ("ad-advice-info");
2963 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2965 error_tail
= pure_cons (Qerror
, Qnil
);
2967 /* ERROR is used as a signaler for random errors for which nothing else is right */
2969 Fput (Qerror
, Qerror_conditions
,
2971 Fput (Qerror
, Qerror_message
,
2972 make_pure_c_string ("error"));
2974 Fput (Qquit
, Qerror_conditions
,
2975 pure_cons (Qquit
, Qnil
));
2976 Fput (Qquit
, Qerror_message
,
2977 make_pure_c_string ("Quit"));
2979 Fput (Qwrong_type_argument
, Qerror_conditions
,
2980 pure_cons (Qwrong_type_argument
, error_tail
));
2981 Fput (Qwrong_type_argument
, Qerror_message
,
2982 make_pure_c_string ("Wrong type argument"));
2984 Fput (Qargs_out_of_range
, Qerror_conditions
,
2985 pure_cons (Qargs_out_of_range
, error_tail
));
2986 Fput (Qargs_out_of_range
, Qerror_message
,
2987 make_pure_c_string ("Args out of range"));
2989 Fput (Qvoid_function
, Qerror_conditions
,
2990 pure_cons (Qvoid_function
, error_tail
));
2991 Fput (Qvoid_function
, Qerror_message
,
2992 make_pure_c_string ("Symbol's function definition is void"));
2994 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2995 pure_cons (Qcyclic_function_indirection
, error_tail
));
2996 Fput (Qcyclic_function_indirection
, Qerror_message
,
2997 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2999 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3000 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3001 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3002 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3004 Qcircular_list
= intern_c_string ("circular-list");
3005 staticpro (&Qcircular_list
);
3006 Fput (Qcircular_list
, Qerror_conditions
,
3007 pure_cons (Qcircular_list
, error_tail
));
3008 Fput (Qcircular_list
, Qerror_message
,
3009 make_pure_c_string ("List contains a loop"));
3011 Fput (Qvoid_variable
, Qerror_conditions
,
3012 pure_cons (Qvoid_variable
, error_tail
));
3013 Fput (Qvoid_variable
, Qerror_message
,
3014 make_pure_c_string ("Symbol's value as variable is void"));
3016 Fput (Qsetting_constant
, Qerror_conditions
,
3017 pure_cons (Qsetting_constant
, error_tail
));
3018 Fput (Qsetting_constant
, Qerror_message
,
3019 make_pure_c_string ("Attempt to set a constant symbol"));
3021 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3022 pure_cons (Qinvalid_read_syntax
, error_tail
));
3023 Fput (Qinvalid_read_syntax
, Qerror_message
,
3024 make_pure_c_string ("Invalid read syntax"));
3026 Fput (Qinvalid_function
, Qerror_conditions
,
3027 pure_cons (Qinvalid_function
, error_tail
));
3028 Fput (Qinvalid_function
, Qerror_message
,
3029 make_pure_c_string ("Invalid function"));
3031 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3032 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3033 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3034 make_pure_c_string ("Wrong number of arguments"));
3036 Fput (Qno_catch
, Qerror_conditions
,
3037 pure_cons (Qno_catch
, error_tail
));
3038 Fput (Qno_catch
, Qerror_message
,
3039 make_pure_c_string ("No catch for tag"));
3041 Fput (Qend_of_file
, Qerror_conditions
,
3042 pure_cons (Qend_of_file
, error_tail
));
3043 Fput (Qend_of_file
, Qerror_message
,
3044 make_pure_c_string ("End of file during parsing"));
3046 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3047 Fput (Qarith_error
, Qerror_conditions
,
3049 Fput (Qarith_error
, Qerror_message
,
3050 make_pure_c_string ("Arithmetic error"));
3052 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3053 pure_cons (Qbeginning_of_buffer
, error_tail
));
3054 Fput (Qbeginning_of_buffer
, Qerror_message
,
3055 make_pure_c_string ("Beginning of buffer"));
3057 Fput (Qend_of_buffer
, Qerror_conditions
,
3058 pure_cons (Qend_of_buffer
, error_tail
));
3059 Fput (Qend_of_buffer
, Qerror_message
,
3060 make_pure_c_string ("End of buffer"));
3062 Fput (Qbuffer_read_only
, Qerror_conditions
,
3063 pure_cons (Qbuffer_read_only
, error_tail
));
3064 Fput (Qbuffer_read_only
, Qerror_message
,
3065 make_pure_c_string ("Buffer is read-only"));
3067 Fput (Qtext_read_only
, Qerror_conditions
,
3068 pure_cons (Qtext_read_only
, error_tail
));
3069 Fput (Qtext_read_only
, Qerror_message
,
3070 make_pure_c_string ("Text is read-only"));
3072 Qrange_error
= intern_c_string ("range-error");
3073 Qdomain_error
= intern_c_string ("domain-error");
3074 Qsingularity_error
= intern_c_string ("singularity-error");
3075 Qoverflow_error
= intern_c_string ("overflow-error");
3076 Qunderflow_error
= intern_c_string ("underflow-error");
3078 Fput (Qdomain_error
, Qerror_conditions
,
3079 pure_cons (Qdomain_error
, arith_tail
));
3080 Fput (Qdomain_error
, Qerror_message
,
3081 make_pure_c_string ("Arithmetic domain error"));
3083 Fput (Qrange_error
, Qerror_conditions
,
3084 pure_cons (Qrange_error
, arith_tail
));
3085 Fput (Qrange_error
, Qerror_message
,
3086 make_pure_c_string ("Arithmetic range error"));
3088 Fput (Qsingularity_error
, Qerror_conditions
,
3089 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3090 Fput (Qsingularity_error
, Qerror_message
,
3091 make_pure_c_string ("Arithmetic singularity error"));
3093 Fput (Qoverflow_error
, Qerror_conditions
,
3094 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3095 Fput (Qoverflow_error
, Qerror_message
,
3096 make_pure_c_string ("Arithmetic overflow error"));
3098 Fput (Qunderflow_error
, Qerror_conditions
,
3099 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3100 Fput (Qunderflow_error
, Qerror_message
,
3101 make_pure_c_string ("Arithmetic underflow error"));
3103 staticpro (&Qrange_error
);
3104 staticpro (&Qdomain_error
);
3105 staticpro (&Qsingularity_error
);
3106 staticpro (&Qoverflow_error
);
3107 staticpro (&Qunderflow_error
);
3111 staticpro (&Qquote
);
3112 staticpro (&Qlambda
);
3114 staticpro (&Qunbound
);
3115 staticpro (&Qerror_conditions
);
3116 staticpro (&Qerror_message
);
3117 staticpro (&Qtop_level
);
3119 staticpro (&Qerror
);
3121 staticpro (&Qwrong_type_argument
);
3122 staticpro (&Qargs_out_of_range
);
3123 staticpro (&Qvoid_function
);
3124 staticpro (&Qcyclic_function_indirection
);
3125 staticpro (&Qcyclic_variable_indirection
);
3126 staticpro (&Qvoid_variable
);
3127 staticpro (&Qsetting_constant
);
3128 staticpro (&Qinvalid_read_syntax
);
3129 staticpro (&Qwrong_number_of_arguments
);
3130 staticpro (&Qinvalid_function
);
3131 staticpro (&Qno_catch
);
3132 staticpro (&Qend_of_file
);
3133 staticpro (&Qarith_error
);
3134 staticpro (&Qbeginning_of_buffer
);
3135 staticpro (&Qend_of_buffer
);
3136 staticpro (&Qbuffer_read_only
);
3137 staticpro (&Qtext_read_only
);
3138 staticpro (&Qmark_inactive
);
3140 staticpro (&Qlistp
);
3141 staticpro (&Qconsp
);
3142 staticpro (&Qsymbolp
);
3143 staticpro (&Qkeywordp
);
3144 staticpro (&Qintegerp
);
3145 staticpro (&Qnatnump
);
3146 staticpro (&Qwholenump
);
3147 staticpro (&Qstringp
);
3148 staticpro (&Qarrayp
);
3149 staticpro (&Qsequencep
);
3150 staticpro (&Qbufferp
);
3151 staticpro (&Qvectorp
);
3152 staticpro (&Qchar_or_string_p
);
3153 staticpro (&Qmarkerp
);
3154 staticpro (&Qbuffer_or_string_p
);
3155 staticpro (&Qinteger_or_marker_p
);
3156 staticpro (&Qfloatp
);
3157 staticpro (&Qnumberp
);
3158 staticpro (&Qnumber_or_marker_p
);
3159 staticpro (&Qchar_table_p
);
3160 staticpro (&Qvector_or_char_table_p
);
3161 staticpro (&Qsubrp
);
3163 staticpro (&Qunevalled
);
3165 staticpro (&Qboundp
);
3166 staticpro (&Qfboundp
);
3168 staticpro (&Qad_advice_info
);
3169 staticpro (&Qad_activate_internal
);
3171 /* Types that type-of returns. */
3172 Qinteger
= intern_c_string ("integer");
3173 Qsymbol
= intern_c_string ("symbol");
3174 Qstring
= intern_c_string ("string");
3175 Qcons
= intern_c_string ("cons");
3176 Qmarker
= intern_c_string ("marker");
3177 Qoverlay
= intern_c_string ("overlay");
3178 Qfloat
= intern_c_string ("float");
3179 Qwindow_configuration
= intern_c_string ("window-configuration");
3180 Qprocess
= intern_c_string ("process");
3181 Qwindow
= intern_c_string ("window");
3182 /* Qsubr = intern_c_string ("subr"); */
3183 Qcompiled_function
= intern_c_string ("compiled-function");
3184 Qfunction_vector
= intern_c_string ("function-vector");
3185 Qbuffer
= intern_c_string ("buffer");
3186 Qframe
= intern_c_string ("frame");
3187 Qvector
= intern_c_string ("vector");
3188 Qchar_table
= intern_c_string ("char-table");
3189 Qbool_vector
= intern_c_string ("bool-vector");
3190 Qhash_table
= intern_c_string ("hash-table");
3192 DEFSYM (Qfont_spec
, "font-spec");
3193 DEFSYM (Qfont_entity
, "font-entity");
3194 DEFSYM (Qfont_object
, "font-object");
3196 DEFSYM (Qinteractive_form
, "interactive-form");
3198 staticpro (&Qinteger
);
3199 staticpro (&Qsymbol
);
3200 staticpro (&Qstring
);
3202 staticpro (&Qmarker
);
3203 staticpro (&Qoverlay
);
3204 staticpro (&Qfloat
);
3205 staticpro (&Qwindow_configuration
);
3206 staticpro (&Qprocess
);
3207 staticpro (&Qwindow
);
3208 /* staticpro (&Qsubr); */
3209 staticpro (&Qcompiled_function
);
3210 staticpro (&Qfunction_vector
);
3211 staticpro (&Qbuffer
);
3212 staticpro (&Qframe
);
3213 staticpro (&Qvector
);
3214 staticpro (&Qchar_table
);
3215 staticpro (&Qbool_vector
);
3216 staticpro (&Qhash_table
);
3218 defsubr (&Sindirect_variable
);
3219 defsubr (&Sinteractive_form
);
3222 defsubr (&Stype_of
);
3227 defsubr (&Sintegerp
);
3228 defsubr (&Sinteger_or_marker_p
);
3229 defsubr (&Snumberp
);
3230 defsubr (&Snumber_or_marker_p
);
3232 defsubr (&Snatnump
);
3233 defsubr (&Ssymbolp
);
3234 defsubr (&Skeywordp
);
3235 defsubr (&Sstringp
);
3236 defsubr (&Smultibyte_string_p
);
3237 defsubr (&Svectorp
);
3238 defsubr (&Schar_table_p
);
3239 defsubr (&Svector_or_char_table_p
);
3240 defsubr (&Sbool_vector_p
);
3242 defsubr (&Ssequencep
);
3243 defsubr (&Sbufferp
);
3244 defsubr (&Smarkerp
);
3246 defsubr (&Sbyte_code_function_p
);
3247 defsubr (&Sfunvecp
);
3248 defsubr (&Schar_or_string_p
);
3251 defsubr (&Scar_safe
);
3252 defsubr (&Scdr_safe
);
3255 defsubr (&Ssymbol_function
);
3256 defsubr (&Sindirect_function
);
3257 defsubr (&Ssymbol_plist
);
3258 defsubr (&Ssymbol_name
);
3259 defsubr (&Smakunbound
);
3260 defsubr (&Sfmakunbound
);
3262 defsubr (&Sfboundp
);
3264 defsubr (&Sdefalias
);
3265 defsubr (&Ssetplist
);
3266 defsubr (&Ssymbol_value
);
3268 defsubr (&Sdefault_boundp
);
3269 defsubr (&Sdefault_value
);
3270 defsubr (&Sset_default
);
3271 defsubr (&Ssetq_default
);
3272 defsubr (&Smake_variable_buffer_local
);
3273 defsubr (&Smake_local_variable
);
3274 defsubr (&Skill_local_variable
);
3275 defsubr (&Smake_variable_frame_local
);
3276 defsubr (&Slocal_variable_p
);
3277 defsubr (&Slocal_variable_if_set_p
);
3278 defsubr (&Svariable_binding_locus
);
3279 #if 0 /* XXX Remove this. --lorentey */
3280 defsubr (&Sterminal_local_value
);
3281 defsubr (&Sset_terminal_local_value
);
3285 defsubr (&Snumber_to_string
);
3286 defsubr (&Sstring_to_number
);
3287 defsubr (&Seqlsign
);
3310 defsubr (&Sbyteorder
);
3311 defsubr (&Ssubr_arity
);
3312 defsubr (&Ssubr_name
);
3314 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3316 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3317 doc
: /* The largest value that is representable in a Lisp integer. */);
3318 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3319 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3321 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3322 doc
: /* The smallest value that is representable in a Lisp integer. */);
3323 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3324 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3328 arith_error (int signo
)
3330 sigsetmask (SIGEMPTYMASK
);
3332 SIGNAL_THREAD_CHECK (signo
);
3333 xsignal0 (Qarith_error
);
3339 /* Don't do this if just dumping out.
3340 We don't want to call `signal' in this case
3341 so that we don't have trouble with dumping
3342 signal-delivering routines in an inconsistent state. */
3346 #endif /* CANNOT_DUMP */
3347 signal (SIGFPE
, arith_error
);
3350 signal (SIGEMT
, arith_error
);
3354 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3355 (do not change this comment) */