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
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/>. */
27 #include "character.h"
31 #include "syssignal.h"
32 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
38 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
39 #ifndef IEEE_FLOATING_POINT
40 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
42 #define IEEE_FLOATING_POINT 1
44 #define IEEE_FLOATING_POINT 0
51 extern double atof ();
54 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
55 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
56 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
57 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
58 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
59 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
60 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
61 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
62 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
63 Lisp_Object Qtext_read_only
;
65 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
66 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
67 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
68 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
69 Lisp_Object Qboundp
, Qfboundp
;
70 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
73 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
75 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
76 Lisp_Object Qoverflow_error
, Qunderflow_error
;
79 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
82 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
83 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
85 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
86 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
87 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
89 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
91 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
95 circular_list_error (list
)
98 xsignal (Qcircular_list
, list
);
103 wrong_type_argument (predicate
, value
)
104 register Lisp_Object predicate
, value
;
106 /* If VALUE is not even a valid Lisp object, abort here
107 where we can get a backtrace showing where it came from. */
108 if ((unsigned int) XTYPE (value
) >= Lisp_Type_Limit
)
111 xsignal2 (Qwrong_type_argument
, predicate
, value
);
117 error ("Attempt to modify read-only object");
121 args_out_of_range (a1
, a2
)
124 xsignal2 (Qargs_out_of_range
, a1
, a2
);
128 args_out_of_range_3 (a1
, a2
, a3
)
129 Lisp_Object a1
, a2
, a3
;
131 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
134 /* On some machines, XINT needs a temporary location.
135 Here it is, in case it is needed. */
137 int sign_extend_temp
;
139 /* On a few machines, XINT can only be done by calling this. */
142 sign_extend_lisp_int (num
)
145 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
146 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
148 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
151 /* Data type predicates */
153 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
154 doc
: /* Return t if the two args are the same Lisp object. */)
156 Lisp_Object obj1
, obj2
;
163 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
164 doc
: /* Return t if OBJECT is nil. */)
173 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
174 doc
: /* Return a symbol representing the type of OBJECT.
175 The symbol returned names the object's basic type;
176 for example, (type-of 1) returns `integer'. */)
180 switch (XTYPE (object
))
195 switch (XMISCTYPE (object
))
197 case Lisp_Misc_Marker
:
199 case Lisp_Misc_Overlay
:
201 case Lisp_Misc_Float
:
206 case Lisp_Vectorlike
:
207 if (WINDOW_CONFIGURATIONP (object
))
208 return Qwindow_configuration
;
209 if (PROCESSP (object
))
211 if (WINDOWP (object
))
215 if (COMPILEDP (object
))
216 return Qcompiled_function
;
217 if (BUFFERP (object
))
219 if (CHAR_TABLE_P (object
))
221 if (BOOL_VECTOR_P (object
))
225 if (HASH_TABLE_P (object
))
237 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
238 doc
: /* Return t if OBJECT is a cons cell. */)
247 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
248 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
257 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
258 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
259 Otherwise, return nil. */)
263 if (CONSP (object
) || NILP (object
))
268 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
269 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
273 if (CONSP (object
) || NILP (object
))
278 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
279 doc
: /* Return t if OBJECT is a symbol. */)
283 if (SYMBOLP (object
))
288 /* Define this in C to avoid unnecessarily consing up the symbol
290 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
291 doc
: /* Return t if OBJECT is a keyword.
292 This means that it is a symbol with a print name beginning with `:'
293 interned in the initial obarray. */)
298 && SREF (SYMBOL_NAME (object
), 0) == ':'
299 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
304 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
305 doc
: /* Return t if OBJECT is a vector. */)
309 if (VECTORP (object
))
314 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
315 doc
: /* Return t if OBJECT is a string. */)
319 if (STRINGP (object
))
324 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
326 doc
: /* Return t if OBJECT is a multibyte string. */)
330 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
335 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
336 doc
: /* Return t if OBJECT is a char-table. */)
340 if (CHAR_TABLE_P (object
))
345 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
346 Svector_or_char_table_p
, 1, 1, 0,
347 doc
: /* Return t if OBJECT is a char-table or vector. */)
351 if (VECTORP (object
) || CHAR_TABLE_P (object
))
356 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
357 doc
: /* Return t if OBJECT is a bool-vector. */)
361 if (BOOL_VECTOR_P (object
))
366 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
367 doc
: /* Return t if OBJECT is an array (string or vector). */)
376 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
377 doc
: /* Return t if OBJECT is a sequence (list or array). */)
379 register Lisp_Object object
;
381 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
386 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is an editor buffer. */)
391 if (BUFFERP (object
))
396 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
401 if (MARKERP (object
))
406 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is a built-in function. */)
416 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
418 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
422 if (COMPILEDP (object
))
427 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
428 doc
: /* Return t if OBJECT is a character or a string. */)
430 register Lisp_Object object
;
432 if (CHARACTERP (object
) || STRINGP (object
))
437 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
438 doc
: /* Return t if OBJECT is an integer. */)
442 if (INTEGERP (object
))
447 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
448 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
450 register Lisp_Object object
;
452 if (MARKERP (object
) || INTEGERP (object
))
457 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
458 doc
: /* Return t if OBJECT is a nonnegative integer. */)
462 if (NATNUMP (object
))
467 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
468 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
472 if (NUMBERP (object
))
478 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
479 Snumber_or_marker_p
, 1, 1, 0,
480 doc
: /* Return t if OBJECT is a number or a marker. */)
484 if (NUMBERP (object
) || MARKERP (object
))
489 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
490 doc
: /* Return t if OBJECT is a floating point number. */)
500 /* Extract and set components of lists */
502 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
503 doc
: /* Return the car of LIST. If arg is nil, return nil.
504 Error if arg is not nil and not a cons cell. See also `car-safe'.
506 See Info node `(elisp)Cons Cells' for a discussion of related basic
507 Lisp concepts such as car, cdr, cons cell and list. */)
509 register Lisp_Object list
;
514 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
515 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
519 return CAR_SAFE (object
);
522 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
523 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
524 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
526 See Info node `(elisp)Cons Cells' for a discussion of related basic
527 Lisp concepts such as cdr, car, cons cell and list. */)
529 register Lisp_Object list
;
534 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
535 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
539 return CDR_SAFE (object
);
542 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
543 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
545 register Lisp_Object cell
, newcar
;
549 XSETCAR (cell
, newcar
);
553 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
554 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
556 register Lisp_Object cell
, newcdr
;
560 XSETCDR (cell
, newcdr
);
564 /* Extract and set components of symbols */
566 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
567 doc
: /* Return t if SYMBOL's value is not void. */)
569 register Lisp_Object symbol
;
571 Lisp_Object valcontents
;
572 CHECK_SYMBOL (symbol
);
574 valcontents
= SYMBOL_VALUE (symbol
);
576 if (BUFFER_LOCAL_VALUEP (valcontents
))
577 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
579 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
582 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
583 doc
: /* Return t if SYMBOL's function definition is not void. */)
585 register Lisp_Object symbol
;
587 CHECK_SYMBOL (symbol
);
588 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
591 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
592 doc
: /* Make SYMBOL's value be void.
595 register Lisp_Object symbol
;
597 CHECK_SYMBOL (symbol
);
598 if (SYMBOL_CONSTANT_P (symbol
))
599 xsignal1 (Qsetting_constant
, symbol
);
600 Fset (symbol
, Qunbound
);
604 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
605 doc
: /* Make SYMBOL's function definition be void.
608 register Lisp_Object symbol
;
610 CHECK_SYMBOL (symbol
);
611 if (NILP (symbol
) || EQ (symbol
, Qt
))
612 xsignal1 (Qsetting_constant
, symbol
);
613 XSYMBOL (symbol
)->function
= Qunbound
;
617 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
618 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
620 register Lisp_Object symbol
;
622 CHECK_SYMBOL (symbol
);
623 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
624 return XSYMBOL (symbol
)->function
;
625 xsignal1 (Qvoid_function
, symbol
);
628 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
629 doc
: /* Return SYMBOL's property list. */)
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
);
634 return XSYMBOL (symbol
)->plist
;
637 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
638 doc
: /* Return SYMBOL's name, a string. */)
640 register Lisp_Object symbol
;
642 register Lisp_Object name
;
644 CHECK_SYMBOL (symbol
);
645 name
= SYMBOL_NAME (symbol
);
649 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
650 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
652 register Lisp_Object symbol
, definition
;
654 register Lisp_Object function
;
656 CHECK_SYMBOL (symbol
);
657 if (NILP (symbol
) || EQ (symbol
, Qt
))
658 xsignal1 (Qsetting_constant
, symbol
);
660 function
= XSYMBOL (symbol
)->function
;
662 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
663 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
665 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
666 Fput (symbol
, Qautoload
, XCDR (function
));
668 XSYMBOL (symbol
)->function
= definition
;
669 /* Handle automatic advice activation */
670 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
672 call2 (Qad_activate_internal
, symbol
, Qnil
);
673 definition
= XSYMBOL (symbol
)->function
;
678 extern Lisp_Object Qfunction_documentation
;
680 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
681 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
682 Associates the function with the current load file, if any.
683 The optional third argument DOCSTRING specifies the documentation string
684 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
685 determined by DEFINITION. */)
686 (symbol
, definition
, docstring
)
687 register Lisp_Object symbol
, definition
, docstring
;
689 CHECK_SYMBOL (symbol
);
690 if (CONSP (XSYMBOL (symbol
)->function
)
691 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
692 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
693 definition
= Ffset (symbol
, definition
);
694 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
695 if (!NILP (docstring
))
696 Fput (symbol
, Qfunction_documentation
, docstring
);
700 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
701 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
703 register Lisp_Object symbol
, newplist
;
705 CHECK_SYMBOL (symbol
);
706 XSYMBOL (symbol
)->plist
= newplist
;
710 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
711 doc
: /* Return minimum and maximum number of args allowed for SUBR.
712 SUBR must be a built-in function.
713 The returned value is a pair (MIN . MAX). MIN is the minimum number
714 of args. MAX is the maximum number or the symbol `many', for a
715 function with `&rest' args, or `unevalled' for a special form. */)
719 short minargs
, maxargs
;
721 minargs
= XSUBR (subr
)->min_args
;
722 maxargs
= XSUBR (subr
)->max_args
;
724 return Fcons (make_number (minargs
), Qmany
);
725 else if (maxargs
== UNEVALLED
)
726 return Fcons (make_number (minargs
), Qunevalled
);
728 return Fcons (make_number (minargs
), make_number (maxargs
));
731 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
732 doc
: /* Return name of subroutine SUBR.
733 SUBR must be a built-in function. */)
739 name
= XSUBR (subr
)->symbol_name
;
740 return make_string (name
, strlen (name
));
743 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
744 doc
: /* Return the interactive form of CMD or nil if none.
745 If CMD is not a command, the return value is nil.
746 Value, if non-nil, is a list \(interactive SPEC). */)
750 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
752 if (NILP (fun
) || EQ (fun
, Qunbound
))
755 /* Use an `interactive-form' property if present, analogous to the
756 function-documentation property. */
758 while (SYMBOLP (fun
))
760 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
764 fun
= Fsymbol_function (fun
);
769 char *spec
= XSUBR (fun
)->intspec
;
771 return list2 (Qinteractive
,
772 (*spec
!= '(') ? build_string (spec
) :
773 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
775 else if (COMPILEDP (fun
))
777 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
778 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
780 else if (CONSP (fun
))
782 Lisp_Object funcar
= XCAR (fun
);
783 if (EQ (funcar
, Qlambda
))
784 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
785 else if (EQ (funcar
, Qautoload
))
789 do_autoload (fun
, cmd
);
791 return Finteractive_form (cmd
);
798 /***********************************************************************
799 Getting and Setting Values of Symbols
800 ***********************************************************************/
802 /* Return the symbol holding SYMBOL's value. Signal
803 `cyclic-variable-indirection' if SYMBOL's chain of variable
804 indirections contains a loop. */
807 indirect_variable (symbol
)
808 struct Lisp_Symbol
*symbol
;
810 struct Lisp_Symbol
*tortoise
, *hare
;
812 hare
= tortoise
= symbol
;
814 while (hare
->indirect_variable
)
816 hare
= XSYMBOL (hare
->value
);
817 if (!hare
->indirect_variable
)
820 hare
= XSYMBOL (hare
->value
);
821 tortoise
= XSYMBOL (tortoise
->value
);
823 if (hare
== tortoise
)
826 XSETSYMBOL (tem
, symbol
);
827 xsignal1 (Qcyclic_variable_indirection
, tem
);
835 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
836 doc
: /* Return the variable at the end of OBJECT's variable chain.
837 If OBJECT is a symbol, follow all variable indirections and return the final
838 variable. If OBJECT is not a symbol, just return it.
839 Signal a cyclic-variable-indirection error if there is a loop in the
840 variable chain of symbols. */)
844 if (SYMBOLP (object
))
845 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
850 /* Given the raw contents of a symbol value cell,
851 return the Lisp value of the symbol.
852 This does not handle buffer-local variables; use
853 swap_in_symval_forwarding for that. */
856 do_symval_forwarding (valcontents
)
857 register Lisp_Object valcontents
;
859 register Lisp_Object val
;
860 if (MISCP (valcontents
))
861 switch (XMISCTYPE (valcontents
))
863 case Lisp_Misc_Intfwd
:
864 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
867 case Lisp_Misc_Boolfwd
:
868 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
870 case Lisp_Misc_Objfwd
:
871 return *XOBJFWD (valcontents
)->objvar
;
873 case Lisp_Misc_Buffer_Objfwd
:
874 return PER_BUFFER_VALUE (current_buffer
,
875 XBUFFER_OBJFWD (valcontents
)->offset
);
877 case Lisp_Misc_Kboard_Objfwd
:
878 /* We used to simply use current_kboard here, but from Lisp
879 code, it's value is often unexpected. It seems nicer to
880 allow constructions like this to work as intuitively expected:
882 (with-selected-frame frame
883 (define-key local-function-map "\eOP" [f1]))
885 On the other hand, this affects the semantics of
886 last-command and real-last-command, and people may rely on
887 that. I took a quick look at the Lisp codebase, and I
888 don't think anything will break. --lorentey */
889 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
890 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
895 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
896 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
897 buffer-independent contents of the value cell: forwarded just one
898 step past the buffer-localness.
900 BUF non-zero means set the value in buffer BUF instead of the
901 current buffer. This only plays a role for per-buffer variables. */
904 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
906 register Lisp_Object valcontents
, newval
;
909 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
912 switch (XMISCTYPE (valcontents
))
914 case Lisp_Misc_Intfwd
:
915 CHECK_NUMBER (newval
);
916 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
917 /* This can never happen since intvar points to an EMACS_INT
918 which is at least large enough to hold a Lisp_Object.
919 if (*XINTFWD (valcontents)->intvar != XINT (newval))
920 error ("Value out of range for variable `%s'",
921 SDATA (SYMBOL_NAME (symbol))); */
924 case Lisp_Misc_Boolfwd
:
925 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
928 case Lisp_Misc_Objfwd
:
929 *XOBJFWD (valcontents
)->objvar
= newval
;
931 /* If this variable is a default for something stored
932 in the buffer itself, such as default-fill-column,
933 find the buffers that don't have local values for it
935 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
936 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
938 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
939 - (char *) &buffer_defaults
);
940 int idx
= PER_BUFFER_IDX (offset
);
947 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
952 buf
= Fcdr (XCAR (tail
));
953 if (!BUFFERP (buf
)) continue;
956 if (! PER_BUFFER_VALUE_P (b
, idx
))
957 PER_BUFFER_VALUE (b
, offset
) = newval
;
962 case Lisp_Misc_Buffer_Objfwd
:
964 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
965 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
967 if (! NILP (type
) && ! NILP (newval
)
968 && XTYPE (newval
) != XINT (type
))
969 buffer_slot_type_mismatch (newval
, XINT (type
));
972 buf
= current_buffer
;
973 PER_BUFFER_VALUE (buf
, offset
) = newval
;
977 case Lisp_Misc_Kboard_Objfwd
:
979 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
980 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
981 *(Lisp_Object
*) p
= newval
;
992 valcontents
= SYMBOL_VALUE (symbol
);
993 if (BUFFER_LOCAL_VALUEP (valcontents
))
994 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
996 SET_SYMBOL_VALUE (symbol
, newval
);
1000 /* Set up SYMBOL to refer to its global binding.
1001 This makes it safe to alter the status of other bindings. */
1004 swap_in_global_binding (symbol
)
1007 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1008 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1009 Lisp_Object cdr
= blv
->cdr
;
1011 /* Unload the previously loaded binding. */
1012 Fsetcdr (XCAR (cdr
),
1013 do_symval_forwarding (blv
->realvalue
));
1015 /* Select the global binding in the symbol. */
1017 store_symval_forwarding (symbol
, blv
->realvalue
, XCDR (cdr
), NULL
);
1019 /* Indicate that the global binding is set up now. */
1022 blv
->found_for_frame
= 0;
1023 blv
->found_for_buffer
= 0;
1026 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1027 VALCONTENTS is the contents of its value cell,
1028 which points to a struct Lisp_Buffer_Local_Value.
1030 Return the value forwarded one step past the buffer-local stage.
1031 This could be another forwarding pointer. */
1034 swap_in_symval_forwarding (symbol
, valcontents
)
1035 Lisp_Object symbol
, valcontents
;
1037 register Lisp_Object tem1
;
1039 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1042 || current_buffer
!= XBUFFER (tem1
)
1043 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1044 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1046 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1047 if (sym
->indirect_variable
)
1049 sym
= indirect_variable (sym
);
1050 XSETSYMBOL (symbol
, sym
);
1053 /* Unload the previously loaded binding. */
1054 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1056 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1057 /* Choose the new binding. */
1058 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1059 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1060 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1063 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1064 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1066 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1068 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1071 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1073 /* Load the new binding. */
1074 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1075 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1076 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1077 store_symval_forwarding (symbol
,
1078 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1081 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1084 /* Find the value of a symbol, returning Qunbound if it's not bound.
1085 This is helpful for code which just wants to get a variable's value
1086 if it has one, without signaling an error.
1087 Note that it must not be possible to quit
1088 within this function. Great care is required for this. */
1091 find_symbol_value (symbol
)
1094 register Lisp_Object valcontents
;
1095 register Lisp_Object val
;
1097 CHECK_SYMBOL (symbol
);
1098 valcontents
= SYMBOL_VALUE (symbol
);
1100 if (BUFFER_LOCAL_VALUEP (valcontents
))
1101 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1103 return do_symval_forwarding (valcontents
);
1106 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1107 doc
: /* Return SYMBOL's value. Error if that is void. */)
1113 val
= find_symbol_value (symbol
);
1114 if (!EQ (val
, Qunbound
))
1117 xsignal1 (Qvoid_variable
, symbol
);
1120 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1121 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1123 register Lisp_Object symbol
, newval
;
1125 return set_internal (symbol
, newval
, current_buffer
, 0);
1128 /* Return 1 if SYMBOL currently has a let-binding
1129 which was made in the buffer that is now current. */
1132 let_shadows_buffer_binding_p (symbol
)
1133 struct Lisp_Symbol
*symbol
;
1135 volatile struct specbinding
*p
;
1137 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1139 && CONSP (p
->symbol
))
1141 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1142 if ((symbol
== let_bound_symbol
1143 || (let_bound_symbol
->indirect_variable
1144 && symbol
== indirect_variable (let_bound_symbol
)))
1145 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1149 return p
>= specpdl
;
1152 /* Store the value NEWVAL into SYMBOL.
1153 If buffer-locality is an issue, BUF specifies which buffer to use.
1154 (0 stands for the current buffer.)
1156 If BINDFLAG is zero, then if this symbol is supposed to become
1157 local in every buffer where it is set, then we make it local.
1158 If BINDFLAG is nonzero, we don't do that. */
1161 set_internal (symbol
, newval
, buf
, bindflag
)
1162 register Lisp_Object symbol
, newval
;
1166 int voide
= EQ (newval
, Qunbound
);
1168 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1171 buf
= current_buffer
;
1173 /* If restoring in a dead buffer, do nothing. */
1174 if (NILP (buf
->name
))
1177 CHECK_SYMBOL (symbol
);
1178 if (SYMBOL_CONSTANT_P (symbol
)
1179 && (NILP (Fkeywordp (symbol
))
1180 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1181 xsignal1 (Qsetting_constant
, symbol
);
1183 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1185 if (BUFFER_OBJFWDP (valcontents
))
1187 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1188 int idx
= PER_BUFFER_IDX (offset
);
1191 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1192 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1194 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1196 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1197 if (XSYMBOL (symbol
)->indirect_variable
)
1198 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1200 /* What binding is loaded right now? */
1201 current_alist_element
1202 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1204 /* If the current buffer is not the buffer whose binding is
1205 loaded, or if there may be frame-local bindings and the frame
1206 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1207 the default binding is loaded, the loaded binding may be the
1209 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1210 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1211 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1212 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1213 /* Also unload a global binding (if the var is local_if_set). */
1214 || (EQ (XCAR (current_alist_element
),
1215 current_alist_element
)))
1217 /* The currently loaded binding is not necessarily valid.
1218 We need to unload it, and choose a new binding. */
1220 /* Write out `realvalue' to the old loaded binding. */
1221 Fsetcdr (current_alist_element
,
1222 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1224 /* Find the new binding. */
1225 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1226 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1227 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1231 /* This buffer still sees the default value. */
1233 /* If the variable is not local_if_set,
1234 or if this is `let' rather than `set',
1235 make CURRENT-ALIST-ELEMENT point to itself,
1236 indicating that we're seeing the default value.
1237 Likewise if the variable has been let-bound
1238 in the current buffer. */
1239 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1240 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1242 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1244 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1245 tem1
= Fassq (symbol
,
1246 XFRAME (selected_frame
)->param_alist
);
1249 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1251 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1253 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1254 and we're not within a let that was made for this buffer,
1255 create a new buffer-local binding for the variable.
1256 That means, give this buffer a new assoc for a local value
1257 and load that binding. */
1260 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1261 buf
->local_var_alist
1262 = Fcons (tem1
, buf
->local_var_alist
);
1266 /* Record which binding is now loaded. */
1267 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1269 /* Set `buffer' and `frame' slots for the binding now loaded. */
1270 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1271 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1273 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1275 /* Store the new value in the cons-cell. */
1276 XSETCDR (XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
), newval
);
1279 /* If storing void (making the symbol void), forward only through
1280 buffer-local indicator, not through Lisp_Objfwd, etc. */
1282 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1284 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1289 /* Access or set a buffer-local symbol's default value. */
1291 /* Return the default value of SYMBOL, but don't check for voidness.
1292 Return Qunbound if it is void. */
1295 default_value (symbol
)
1298 register Lisp_Object valcontents
;
1300 CHECK_SYMBOL (symbol
);
1301 valcontents
= SYMBOL_VALUE (symbol
);
1303 /* For a built-in buffer-local variable, get the default value
1304 rather than letting do_symval_forwarding get the current value. */
1305 if (BUFFER_OBJFWDP (valcontents
))
1307 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1308 if (PER_BUFFER_IDX (offset
) != 0)
1309 return PER_BUFFER_DEFAULT (offset
);
1312 /* Handle user-created local variables. */
1313 if (BUFFER_LOCAL_VALUEP (valcontents
))
1315 /* If var is set up for a buffer that lacks a local value for it,
1316 the current value is nominally the default value.
1317 But the `realvalue' slot may be more up to date, since
1318 ordinary setq stores just that slot. So use that. */
1319 Lisp_Object current_alist_element
, alist_element_car
;
1320 current_alist_element
1321 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1322 alist_element_car
= XCAR (current_alist_element
);
1323 if (EQ (alist_element_car
, current_alist_element
))
1324 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1326 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1328 /* For other variables, get the current value. */
1329 return do_symval_forwarding (valcontents
);
1332 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1333 doc
: /* Return t if SYMBOL has a non-void default value.
1334 This is the value that is seen in buffers that do not have their own values
1335 for this variable. */)
1339 register Lisp_Object value
;
1341 value
= default_value (symbol
);
1342 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1345 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1346 doc
: /* Return SYMBOL's default value.
1347 This is the value that is seen in buffers that do not have their own values
1348 for this variable. The default value is meaningful for variables with
1349 local bindings in certain buffers. */)
1353 register Lisp_Object value
;
1355 value
= default_value (symbol
);
1356 if (!EQ (value
, Qunbound
))
1359 xsignal1 (Qvoid_variable
, symbol
);
1362 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1363 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1364 The default value is seen in buffers that do not have their own values
1365 for this variable. */)
1367 Lisp_Object symbol
, value
;
1369 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1371 CHECK_SYMBOL (symbol
);
1372 valcontents
= SYMBOL_VALUE (symbol
);
1374 /* Handle variables like case-fold-search that have special slots
1375 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1377 if (BUFFER_OBJFWDP (valcontents
))
1379 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1380 int idx
= PER_BUFFER_IDX (offset
);
1382 PER_BUFFER_DEFAULT (offset
) = value
;
1384 /* If this variable is not always local in all buffers,
1385 set it in the buffers that don't nominally have a local value. */
1390 for (b
= all_buffers
; b
; b
= b
->next
)
1391 if (!PER_BUFFER_VALUE_P (b
, idx
))
1392 PER_BUFFER_VALUE (b
, offset
) = value
;
1397 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1398 return Fset (symbol
, value
);
1400 /* Store new value into the DEFAULT-VALUE slot. */
1401 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1403 /* If the default binding is now loaded, set the REALVALUE slot too. */
1404 current_alist_element
1405 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1406 alist_element_buffer
= Fcar (current_alist_element
);
1407 if (EQ (alist_element_buffer
, current_alist_element
))
1408 store_symval_forwarding (symbol
,
1409 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1415 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1416 doc
: /* Set the default value of variable VAR to VALUE.
1417 VAR, the variable name, is literal (not evaluated);
1418 VALUE is an expression: it is evaluated and its value returned.
1419 The default value of a variable is seen in buffers
1420 that do not have their own values for the variable.
1422 More generally, you can use multiple variables and values, as in
1423 (setq-default VAR VALUE VAR VALUE...)
1424 This sets each VAR's default value to the corresponding VALUE.
1425 The VALUE for the Nth VAR can refer to the new default values
1427 usage: (setq-default [VAR VALUE]...) */)
1431 register Lisp_Object args_left
;
1432 register Lisp_Object val
, symbol
;
1433 struct gcpro gcpro1
;
1443 val
= Feval (Fcar (Fcdr (args_left
)));
1444 symbol
= XCAR (args_left
);
1445 Fset_default (symbol
, val
);
1446 args_left
= Fcdr (XCDR (args_left
));
1448 while (!NILP (args_left
));
1454 /* Lisp functions for creating and removing buffer-local variables. */
1456 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1457 1, 1, "vMake Variable Buffer Local: ",
1458 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1459 At any time, the value for the current buffer is in effect,
1460 unless the variable has never been set in this buffer,
1461 in which case the default value is in effect.
1462 Note that binding the variable with `let', or setting it while
1463 a `let'-style binding made in this buffer is in effect,
1464 does not make the variable buffer-local. Return VARIABLE.
1466 In most cases it is better to use `make-local-variable',
1467 which makes a variable local in just one buffer.
1469 The function `default-value' gets the default value and `set-default' sets it. */)
1471 register Lisp_Object variable
;
1473 register Lisp_Object tem
, valcontents
, newval
;
1474 struct Lisp_Symbol
*sym
;
1476 CHECK_SYMBOL (variable
);
1477 sym
= indirect_variable (XSYMBOL (variable
));
1479 valcontents
= sym
->value
;
1480 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1481 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1483 if (BUFFER_OBJFWDP (valcontents
))
1485 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1487 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1488 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1489 newval
= valcontents
;
1493 if (EQ (valcontents
, Qunbound
))
1495 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1497 newval
= allocate_misc ();
1498 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1499 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1500 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1501 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1502 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1503 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1504 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1505 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1506 sym
->value
= newval
;
1508 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1512 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1513 1, 1, "vMake Local Variable: ",
1514 doc
: /* Make VARIABLE have a separate value in the current buffer.
1515 Other buffers will continue to share a common default value.
1516 \(The buffer-local value of VARIABLE starts out as the same value
1517 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1520 If the variable is already arranged to become local when set,
1521 this function causes a local value to exist for this buffer,
1522 just as setting the variable would do.
1524 This function returns VARIABLE, and therefore
1525 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1528 See also `make-variable-buffer-local'.
1530 Do not use `make-local-variable' to make a hook variable buffer-local.
1531 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1533 register Lisp_Object variable
;
1535 register Lisp_Object tem
, valcontents
;
1536 struct Lisp_Symbol
*sym
;
1538 CHECK_SYMBOL (variable
);
1539 sym
= indirect_variable (XSYMBOL (variable
));
1541 valcontents
= sym
->value
;
1542 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1543 || (BUFFER_LOCAL_VALUEP (valcontents
)
1544 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1545 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1547 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1548 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1549 || BUFFER_OBJFWDP (valcontents
))
1551 tem
= Fboundp (variable
);
1553 /* Make sure the symbol has a local value in this particular buffer,
1554 by setting it to the same value it already has. */
1555 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1558 /* Make sure symbol is set up to hold per-buffer values. */
1559 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1562 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1564 newval
= allocate_misc ();
1565 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1566 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1567 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1568 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1569 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1570 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1571 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1572 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1573 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1574 sym
->value
= newval
;
1576 /* Make sure this buffer has its own value of symbol. */
1577 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1578 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1581 /* Swap out any local binding for some other buffer, and make
1582 sure the current value is permanently recorded, if it's the
1584 find_symbol_value (variable
);
1586 current_buffer
->local_var_alist
1587 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (sym
->value
)->cdr
)),
1588 current_buffer
->local_var_alist
);
1590 /* Make sure symbol does not think it is set up for this buffer;
1591 force it to look once again for this buffer's value. */
1593 Lisp_Object
*pvalbuf
;
1595 valcontents
= sym
->value
;
1597 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1598 if (current_buffer
== XBUFFER (*pvalbuf
))
1600 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1604 /* If the symbol forwards into a C variable, then load the binding
1605 for this buffer now. If C code modifies the variable before we
1606 load the binding in, then that new value will clobber the default
1607 binding the next time we unload it. */
1608 valcontents
= XBUFFER_LOCAL_VALUE (sym
->value
)->realvalue
;
1609 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1610 swap_in_symval_forwarding (variable
, sym
->value
);
1615 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1616 1, 1, "vKill Local Variable: ",
1617 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1618 From now on the default value will apply in this buffer. Return VARIABLE. */)
1620 register Lisp_Object variable
;
1622 register Lisp_Object tem
, valcontents
;
1623 struct Lisp_Symbol
*sym
;
1625 CHECK_SYMBOL (variable
);
1626 sym
= indirect_variable (XSYMBOL (variable
));
1628 valcontents
= sym
->value
;
1630 if (BUFFER_OBJFWDP (valcontents
))
1632 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1633 int idx
= PER_BUFFER_IDX (offset
);
1637 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1638 PER_BUFFER_VALUE (current_buffer
, offset
)
1639 = PER_BUFFER_DEFAULT (offset
);
1644 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1647 /* Get rid of this buffer's alist element, if any. */
1648 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1649 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1651 current_buffer
->local_var_alist
1652 = Fdelq (tem
, current_buffer
->local_var_alist
);
1654 /* If the symbol is set up with the current buffer's binding
1655 loaded, recompute its value. We have to do it now, or else
1656 forwarded objects won't work right. */
1658 Lisp_Object
*pvalbuf
, buf
;
1659 valcontents
= sym
->value
;
1660 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1661 XSETBUFFER (buf
, current_buffer
);
1662 if (EQ (buf
, *pvalbuf
))
1665 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1666 find_symbol_value (variable
);
1673 /* Lisp functions for creating and removing buffer-local variables. */
1675 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1676 when/if this is removed. */
1678 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1679 1, 1, "vMake Variable Frame Local: ",
1680 doc
: /* Enable VARIABLE to have frame-local bindings.
1681 This does not create any frame-local bindings for VARIABLE,
1682 it just makes them possible.
1684 A frame-local binding is actually a frame parameter value.
1685 If a frame F has a value for the frame parameter named VARIABLE,
1686 that also acts as a frame-local binding for VARIABLE in F--
1687 provided this function has been called to enable VARIABLE
1688 to have frame-local bindings at all.
1690 The only way to create a frame-local binding for VARIABLE in a frame
1691 is to set the VARIABLE frame parameter of that frame. See
1692 `modify-frame-parameters' for how to set frame parameters.
1694 Buffer-local bindings take precedence over frame-local bindings. */)
1696 register Lisp_Object variable
;
1698 register Lisp_Object tem
, valcontents
, newval
;
1699 struct Lisp_Symbol
*sym
;
1701 CHECK_SYMBOL (variable
);
1702 sym
= indirect_variable (XSYMBOL (variable
));
1704 valcontents
= sym
->value
;
1705 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1706 || BUFFER_OBJFWDP (valcontents
))
1707 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1709 if (BUFFER_LOCAL_VALUEP (valcontents
))
1711 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1712 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1716 if (EQ (valcontents
, Qunbound
))
1718 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1720 newval
= allocate_misc ();
1721 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1722 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1723 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1724 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1725 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1726 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1727 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1728 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1729 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1730 sym
->value
= newval
;
1734 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1736 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1737 BUFFER defaults to the current buffer. */)
1739 register Lisp_Object variable
, buffer
;
1741 Lisp_Object valcontents
;
1742 register struct buffer
*buf
;
1743 struct Lisp_Symbol
*sym
;
1746 buf
= current_buffer
;
1749 CHECK_BUFFER (buffer
);
1750 buf
= XBUFFER (buffer
);
1753 CHECK_SYMBOL (variable
);
1754 sym
= indirect_variable (XSYMBOL (variable
));
1755 XSETSYMBOL (variable
, sym
);
1757 valcontents
= sym
->value
;
1758 if (BUFFER_LOCAL_VALUEP (valcontents
))
1760 Lisp_Object tail
, elt
;
1762 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1765 if (EQ (variable
, XCAR (elt
)))
1769 if (BUFFER_OBJFWDP (valcontents
))
1771 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1772 int idx
= PER_BUFFER_IDX (offset
);
1773 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1779 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1781 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1782 More precisely, this means that setting the variable \(with `set' or`setq'),
1783 while it does not have a `let'-style binding that was made in BUFFER,
1784 will produce a buffer local binding. See Info node
1785 `(elisp)Creating Buffer-Local'.
1786 BUFFER defaults to the current buffer. */)
1788 register Lisp_Object variable
, buffer
;
1790 Lisp_Object valcontents
;
1791 register struct buffer
*buf
;
1792 struct Lisp_Symbol
*sym
;
1795 buf
= current_buffer
;
1798 CHECK_BUFFER (buffer
);
1799 buf
= XBUFFER (buffer
);
1802 CHECK_SYMBOL (variable
);
1803 sym
= indirect_variable (XSYMBOL (variable
));
1804 XSETSYMBOL (variable
, sym
);
1806 valcontents
= sym
->value
;
1808 if (BUFFER_OBJFWDP (valcontents
))
1809 /* All these slots become local if they are set. */
1811 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1813 Lisp_Object tail
, elt
;
1814 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1816 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1819 if (EQ (variable
, XCAR (elt
)))
1826 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1828 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1829 If the current binding is buffer-local, the value is the current buffer.
1830 If the current binding is frame-local, the value is the selected frame.
1831 If the current binding is global (the default), the value is nil. */)
1833 register Lisp_Object variable
;
1835 Lisp_Object valcontents
;
1836 struct Lisp_Symbol
*sym
;
1838 CHECK_SYMBOL (variable
);
1839 sym
= indirect_variable (XSYMBOL (variable
));
1841 /* Make sure the current binding is actually swapped in. */
1842 find_symbol_value (variable
);
1844 valcontents
= sym
->value
;
1846 if (BUFFER_LOCAL_VALUEP (valcontents
)
1847 || BUFFER_OBJFWDP (valcontents
))
1849 /* For a local variable, record both the symbol and which
1850 buffer's or frame's value we are saving. */
1851 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1852 return Fcurrent_buffer ();
1853 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1854 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1855 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1861 /* This code is disabled now that we use the selected frame to return
1862 keyboard-local-values. */
1864 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1866 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1867 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1868 If SYMBOL is not a terminal-local variable, then return its normal
1869 value, like `symbol-value'.
1871 TERMINAL may be a terminal id, a frame, or nil (meaning the
1872 selected frame's terminal device). */)
1875 Lisp_Object terminal
;
1878 struct terminal
*t
= get_terminal (terminal
, 1);
1879 push_kboard (t
->kboard
);
1880 result
= Fsymbol_value (symbol
);
1885 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1886 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1887 If VARIABLE is not a terminal-local variable, then set its normal
1888 binding, like `set'.
1890 TERMINAL may be a terminal id, a frame, or nil (meaning the
1891 selected frame's terminal device). */)
1892 (symbol
, terminal
, value
)
1894 Lisp_Object terminal
;
1898 struct terminal
*t
= get_terminal (terminal
, 1);
1899 push_kboard (d
->kboard
);
1900 result
= Fset (symbol
, value
);
1906 /* Find the function at the end of a chain of symbol function indirections. */
1908 /* If OBJECT is a symbol, find the end of its function chain and
1909 return the value found there. If OBJECT is not a symbol, just
1910 return it. If there is a cycle in the function chain, signal a
1911 cyclic-function-indirection error.
1913 This is like Findirect_function, except that it doesn't signal an
1914 error if the chain ends up unbound. */
1916 indirect_function (object
)
1917 register Lisp_Object object
;
1919 Lisp_Object tortoise
, hare
;
1921 hare
= tortoise
= object
;
1925 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1927 hare
= XSYMBOL (hare
)->function
;
1928 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1930 hare
= XSYMBOL (hare
)->function
;
1932 tortoise
= XSYMBOL (tortoise
)->function
;
1934 if (EQ (hare
, tortoise
))
1935 xsignal1 (Qcyclic_function_indirection
, object
);
1941 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1942 doc
: /* Return the function at the end of OBJECT's function chain.
1943 If OBJECT is not a symbol, just return it. Otherwise, follow all
1944 function indirections to find the final function binding and return it.
1945 If the final symbol in the chain is unbound, signal a void-function error.
1946 Optional arg NOERROR non-nil means to return nil instead of signalling.
1947 Signal a cyclic-function-indirection error if there is a loop in the
1948 function chain of symbols. */)
1950 register Lisp_Object object
;
1951 Lisp_Object noerror
;
1955 /* Optimize for no indirection. */
1957 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1958 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1959 result
= indirect_function (result
);
1960 if (!EQ (result
, Qunbound
))
1964 xsignal1 (Qvoid_function
, object
);
1969 /* Extract and set vector and string elements */
1971 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1972 doc
: /* Return the element of ARRAY at index IDX.
1973 ARRAY may be a vector, a string, a char-table, a bool-vector,
1974 or a byte-code object. IDX starts at 0. */)
1976 register Lisp_Object array
;
1979 register int idxval
;
1982 idxval
= XINT (idx
);
1983 if (STRINGP (array
))
1987 if (idxval
< 0 || idxval
>= SCHARS (array
))
1988 args_out_of_range (array
, idx
);
1989 if (! STRING_MULTIBYTE (array
))
1990 return make_number ((unsigned char) SREF (array
, idxval
));
1991 idxval_byte
= string_char_to_byte (array
, idxval
);
1993 c
= STRING_CHAR (SDATA (array
) + idxval_byte
,
1994 SBYTES (array
) - idxval_byte
);
1995 return make_number (c
);
1997 else if (BOOL_VECTOR_P (array
))
2001 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2002 args_out_of_range (array
, idx
);
2004 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2005 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2007 else if (CHAR_TABLE_P (array
))
2009 CHECK_CHARACTER (idx
);
2010 return CHAR_TABLE_REF (array
, idxval
);
2015 if (VECTORP (array
))
2016 size
= XVECTOR (array
)->size
;
2017 else if (COMPILEDP (array
))
2018 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2020 wrong_type_argument (Qarrayp
, array
);
2022 if (idxval
< 0 || idxval
>= size
)
2023 args_out_of_range (array
, idx
);
2024 return XVECTOR (array
)->contents
[idxval
];
2028 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2029 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2030 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2031 bool-vector. IDX starts at 0. */)
2032 (array
, idx
, newelt
)
2033 register Lisp_Object array
;
2034 Lisp_Object idx
, newelt
;
2036 register int idxval
;
2039 idxval
= XINT (idx
);
2040 CHECK_ARRAY (array
, Qarrayp
);
2041 CHECK_IMPURE (array
);
2043 if (VECTORP (array
))
2045 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2046 args_out_of_range (array
, idx
);
2047 XVECTOR (array
)->contents
[idxval
] = newelt
;
2049 else if (BOOL_VECTOR_P (array
))
2053 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2054 args_out_of_range (array
, idx
);
2056 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2058 if (! NILP (newelt
))
2059 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2061 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2062 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2064 else if (CHAR_TABLE_P (array
))
2066 CHECK_CHARACTER (idx
);
2067 CHAR_TABLE_SET (array
, idxval
, newelt
);
2069 else if (STRING_MULTIBYTE (array
))
2071 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2072 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2074 if (idxval
< 0 || idxval
>= SCHARS (array
))
2075 args_out_of_range (array
, idx
);
2076 CHECK_CHARACTER (newelt
);
2078 nbytes
= SBYTES (array
);
2080 idxval_byte
= string_char_to_byte (array
, idxval
);
2081 p1
= SDATA (array
) + idxval_byte
;
2082 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2083 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2084 if (prev_bytes
!= new_bytes
)
2086 /* We must relocate the string data. */
2087 int nchars
= SCHARS (array
);
2091 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2092 bcopy (SDATA (array
), str
, nbytes
);
2093 allocate_string_data (XSTRING (array
), nchars
,
2094 nbytes
+ new_bytes
- prev_bytes
);
2095 bcopy (str
, SDATA (array
), idxval_byte
);
2096 p1
= SDATA (array
) + idxval_byte
;
2097 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2098 nbytes
- (idxval_byte
+ prev_bytes
));
2100 clear_string_char_byte_cache ();
2107 if (idxval
< 0 || idxval
>= SCHARS (array
))
2108 args_out_of_range (array
, idx
);
2109 CHECK_NUMBER (newelt
);
2111 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2115 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2116 if (SREF (array
, i
) >= 0x80)
2117 args_out_of_range (array
, newelt
);
2118 /* ARRAY is an ASCII string. Convert it to a multibyte
2119 string, and try `aset' again. */
2120 STRING_SET_MULTIBYTE (array
);
2121 return Faset (array
, idx
, newelt
);
2123 SSET (array
, idxval
, XINT (newelt
));
2129 /* Arithmetic functions */
2131 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2134 arithcompare (num1
, num2
, comparison
)
2135 Lisp_Object num1
, num2
;
2136 enum comparison comparison
;
2138 double f1
= 0, f2
= 0;
2141 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2142 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2144 if (FLOATP (num1
) || FLOATP (num2
))
2147 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2148 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2154 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2159 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2164 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2169 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2174 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2179 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2188 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2189 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2191 register Lisp_Object num1
, num2
;
2193 return arithcompare (num1
, num2
, equal
);
2196 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2197 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2199 register Lisp_Object num1
, num2
;
2201 return arithcompare (num1
, num2
, less
);
2204 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2205 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2207 register Lisp_Object num1
, num2
;
2209 return arithcompare (num1
, num2
, grtr
);
2212 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2213 doc
: /* Return t if first arg is less than or equal to second arg.
2214 Both must be numbers or markers. */)
2216 register Lisp_Object num1
, num2
;
2218 return arithcompare (num1
, num2
, less_or_equal
);
2221 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2222 doc
: /* Return t if first arg is greater than or equal to second arg.
2223 Both must be numbers or markers. */)
2225 register Lisp_Object num1
, num2
;
2227 return arithcompare (num1
, num2
, grtr_or_equal
);
2230 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2231 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2233 register Lisp_Object num1
, num2
;
2235 return arithcompare (num1
, num2
, notequal
);
2238 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2239 doc
: /* Return t if NUMBER is zero. */)
2241 register Lisp_Object number
;
2243 CHECK_NUMBER_OR_FLOAT (number
);
2245 if (FLOATP (number
))
2247 if (XFLOAT_DATA (number
) == 0.0)
2257 /* Convert between long values and pairs of Lisp integers.
2258 Note that long_to_cons returns a single Lisp integer
2259 when the value fits in one. */
2265 unsigned long top
= i
>> 16;
2266 unsigned int bot
= i
& 0xFFFF;
2268 return make_number (bot
);
2269 if (top
== (unsigned long)-1 >> 16)
2270 return Fcons (make_number (-1), make_number (bot
));
2271 return Fcons (make_number (top
), make_number (bot
));
2278 Lisp_Object top
, bot
;
2285 return ((XINT (top
) << 16) | XINT (bot
));
2288 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2289 doc
: /* Return the decimal representation of NUMBER as a string.
2290 Uses a minus sign if negative.
2291 NUMBER may be an integer or a floating point number. */)
2295 char buffer
[VALBITS
];
2297 CHECK_NUMBER_OR_FLOAT (number
);
2299 if (FLOATP (number
))
2301 char pigbuf
[350]; /* see comments in float_to_string */
2303 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2304 return build_string (pigbuf
);
2307 if (sizeof (int) == sizeof (EMACS_INT
))
2308 sprintf (buffer
, "%d", (int) XINT (number
));
2309 else if (sizeof (long) == sizeof (EMACS_INT
))
2310 sprintf (buffer
, "%ld", (long) XINT (number
));
2313 return build_string (buffer
);
2317 digit_to_number (character
, base
)
2318 int character
, base
;
2322 if (character
>= '0' && character
<= '9')
2323 digit
= character
- '0';
2324 else if (character
>= 'a' && character
<= 'z')
2325 digit
= character
- 'a' + 10;
2326 else if (character
>= 'A' && character
<= 'Z')
2327 digit
= character
- 'A' + 10;
2337 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2338 doc
: /* Parse STRING as a decimal number and return the number.
2339 This parses both integers and floating point numbers.
2340 It ignores leading spaces and tabs.
2342 If BASE, interpret STRING as a number in that base. If BASE isn't
2343 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2344 If the base used is not 10, floating point is not recognized. */)
2346 register Lisp_Object string
, base
;
2348 register unsigned char *p
;
2353 CHECK_STRING (string
);
2359 CHECK_NUMBER (base
);
2361 if (b
< 2 || b
> 16)
2362 xsignal1 (Qargs_out_of_range
, base
);
2365 /* Skip any whitespace at the front of the number. Some versions of
2366 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2368 while (*p
== ' ' || *p
== '\t')
2379 if (isfloat_string (p
) && b
== 10)
2380 val
= make_float (sign
* atof (p
));
2387 int digit
= digit_to_number (*p
++, b
);
2393 val
= make_fixnum_or_float (sign
* v
);
2413 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2414 int, Lisp_Object
*));
2415 extern Lisp_Object
fmod_float ();
2418 arith_driver (code
, nargs
, args
)
2421 register Lisp_Object
*args
;
2423 register Lisp_Object val
;
2424 register int argnum
;
2425 register EMACS_INT accum
= 0;
2426 register EMACS_INT next
;
2428 switch (SWITCH_ENUM_CAST (code
))
2446 for (argnum
= 0; argnum
< nargs
; argnum
++)
2448 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2450 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2453 return float_arith_driver ((double) accum
, argnum
, code
,
2456 next
= XINT (args
[argnum
]);
2457 switch (SWITCH_ENUM_CAST (code
))
2463 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2474 xsignal0 (Qarith_error
);
2488 if (!argnum
|| next
> accum
)
2492 if (!argnum
|| next
< accum
)
2498 XSETINT (val
, accum
);
2503 #define isnan(x) ((x) != (x))
2506 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2508 register int argnum
;
2511 register Lisp_Object
*args
;
2513 register Lisp_Object val
;
2516 for (; argnum
< nargs
; argnum
++)
2518 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2519 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2523 next
= XFLOAT_DATA (val
);
2527 args
[argnum
] = val
; /* runs into a compiler bug. */
2528 next
= XINT (args
[argnum
]);
2530 switch (SWITCH_ENUM_CAST (code
))
2536 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2546 if (! IEEE_FLOATING_POINT
&& next
== 0)
2547 xsignal0 (Qarith_error
);
2554 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2556 if (!argnum
|| isnan (next
) || next
> accum
)
2560 if (!argnum
|| isnan (next
) || next
< accum
)
2566 return make_float (accum
);
2570 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2571 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2572 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2577 return arith_driver (Aadd
, nargs
, args
);
2580 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2581 doc
: /* Negate number or subtract numbers or markers and return the result.
2582 With one arg, negates it. With more than one arg,
2583 subtracts all but the first from the first.
2584 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2589 return arith_driver (Asub
, nargs
, args
);
2592 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2593 doc
: /* Return product of any number of arguments, which are numbers or markers.
2594 usage: (* &rest NUMBERS-OR-MARKERS) */)
2599 return arith_driver (Amult
, nargs
, args
);
2602 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2603 doc
: /* Return first argument divided by all the remaining arguments.
2604 The arguments must be numbers or markers.
2605 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2611 for (argnum
= 2; argnum
< nargs
; argnum
++)
2612 if (FLOATP (args
[argnum
]))
2613 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2614 return arith_driver (Adiv
, nargs
, args
);
2617 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2618 doc
: /* Return remainder of X divided by Y.
2619 Both must be integers or markers. */)
2621 register Lisp_Object x
, y
;
2625 CHECK_NUMBER_COERCE_MARKER (x
);
2626 CHECK_NUMBER_COERCE_MARKER (y
);
2628 if (XFASTINT (y
) == 0)
2629 xsignal0 (Qarith_error
);
2631 XSETINT (val
, XINT (x
) % XINT (y
));
2645 /* If the magnitude of the result exceeds that of the divisor, or
2646 the sign of the result does not agree with that of the dividend,
2647 iterate with the reduced value. This does not yield a
2648 particularly accurate result, but at least it will be in the
2649 range promised by fmod. */
2651 r
-= f2
* floor (r
/ f2
);
2652 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2656 #endif /* ! HAVE_FMOD */
2658 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2659 doc
: /* Return X modulo Y.
2660 The result falls between zero (inclusive) and Y (exclusive).
2661 Both X and Y must be numbers or markers. */)
2663 register Lisp_Object x
, y
;
2668 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2669 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2671 if (FLOATP (x
) || FLOATP (y
))
2672 return fmod_float (x
, y
);
2678 xsignal0 (Qarith_error
);
2682 /* If the "remainder" comes out with the wrong sign, fix it. */
2683 if (i2
< 0 ? i1
> 0 : i1
< 0)
2690 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2691 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2692 The value is always a number; markers are converted to numbers.
2693 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2698 return arith_driver (Amax
, nargs
, args
);
2701 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2702 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2703 The value is always a number; markers are converted to numbers.
2704 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2709 return arith_driver (Amin
, nargs
, args
);
2712 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2713 doc
: /* Return bitwise-and of all the arguments.
2714 Arguments may be integers, or markers converted to integers.
2715 usage: (logand &rest INTS-OR-MARKERS) */)
2720 return arith_driver (Alogand
, nargs
, args
);
2723 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2724 doc
: /* Return bitwise-or of all the arguments.
2725 Arguments may be integers, or markers converted to integers.
2726 usage: (logior &rest INTS-OR-MARKERS) */)
2731 return arith_driver (Alogior
, nargs
, args
);
2734 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2735 doc
: /* Return bitwise-exclusive-or of all the arguments.
2736 Arguments may be integers, or markers converted to integers.
2737 usage: (logxor &rest INTS-OR-MARKERS) */)
2742 return arith_driver (Alogxor
, nargs
, args
);
2745 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2746 doc
: /* Return VALUE with its bits shifted left by COUNT.
2747 If COUNT is negative, shifting is actually to the right.
2748 In this case, the sign bit is duplicated. */)
2750 register Lisp_Object value
, count
;
2752 register Lisp_Object val
;
2754 CHECK_NUMBER (value
);
2755 CHECK_NUMBER (count
);
2757 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2759 else if (XINT (count
) > 0)
2760 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2761 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2762 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2764 XSETINT (val
, XINT (value
) >> -XINT (count
));
2768 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2769 doc
: /* Return VALUE with its bits shifted left by COUNT.
2770 If COUNT is negative, shifting is actually to the right.
2771 In this case, zeros are shifted in on the left. */)
2773 register Lisp_Object value
, count
;
2775 register Lisp_Object val
;
2777 CHECK_NUMBER (value
);
2778 CHECK_NUMBER (count
);
2780 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2782 else if (XINT (count
) > 0)
2783 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2784 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2787 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2791 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2792 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2793 Markers are converted to integers. */)
2795 register Lisp_Object number
;
2797 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2799 if (FLOATP (number
))
2800 return (make_float (1.0 + XFLOAT_DATA (number
)));
2802 XSETINT (number
, XINT (number
) + 1);
2806 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2807 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2808 Markers are converted to integers. */)
2810 register Lisp_Object number
;
2812 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2814 if (FLOATP (number
))
2815 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2817 XSETINT (number
, XINT (number
) - 1);
2821 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2822 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2824 register Lisp_Object number
;
2826 CHECK_NUMBER (number
);
2827 XSETINT (number
, ~XINT (number
));
2831 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2832 doc
: /* Return the byteorder for the machine.
2833 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2834 lowercase l) for small endian machines. */)
2837 unsigned i
= 0x04030201;
2838 int order
= *(char *)&i
== 1 ? 108 : 66;
2840 return make_number (order
);
2848 Lisp_Object error_tail
, arith_tail
;
2850 Qquote
= intern ("quote");
2851 Qlambda
= intern ("lambda");
2852 Qsubr
= intern ("subr");
2853 Qerror_conditions
= intern ("error-conditions");
2854 Qerror_message
= intern ("error-message");
2855 Qtop_level
= intern ("top-level");
2857 Qerror
= intern ("error");
2858 Qquit
= intern ("quit");
2859 Qwrong_type_argument
= intern ("wrong-type-argument");
2860 Qargs_out_of_range
= intern ("args-out-of-range");
2861 Qvoid_function
= intern ("void-function");
2862 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2863 Qcyclic_variable_indirection
= intern ("cyclic-variable-indirection");
2864 Qvoid_variable
= intern ("void-variable");
2865 Qsetting_constant
= intern ("setting-constant");
2866 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2868 Qinvalid_function
= intern ("invalid-function");
2869 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2870 Qno_catch
= intern ("no-catch");
2871 Qend_of_file
= intern ("end-of-file");
2872 Qarith_error
= intern ("arith-error");
2873 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2874 Qend_of_buffer
= intern ("end-of-buffer");
2875 Qbuffer_read_only
= intern ("buffer-read-only");
2876 Qtext_read_only
= intern ("text-read-only");
2877 Qmark_inactive
= intern ("mark-inactive");
2879 Qlistp
= intern ("listp");
2880 Qconsp
= intern ("consp");
2881 Qsymbolp
= intern ("symbolp");
2882 Qkeywordp
= intern ("keywordp");
2883 Qintegerp
= intern ("integerp");
2884 Qnatnump
= intern ("natnump");
2885 Qwholenump
= intern ("wholenump");
2886 Qstringp
= intern ("stringp");
2887 Qarrayp
= intern ("arrayp");
2888 Qsequencep
= intern ("sequencep");
2889 Qbufferp
= intern ("bufferp");
2890 Qvectorp
= intern ("vectorp");
2891 Qchar_or_string_p
= intern ("char-or-string-p");
2892 Qmarkerp
= intern ("markerp");
2893 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2894 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2895 Qboundp
= intern ("boundp");
2896 Qfboundp
= intern ("fboundp");
2898 Qfloatp
= intern ("floatp");
2899 Qnumberp
= intern ("numberp");
2900 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2902 Qchar_table_p
= intern ("char-table-p");
2903 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2905 Qsubrp
= intern ("subrp");
2906 Qunevalled
= intern ("unevalled");
2907 Qmany
= intern ("many");
2909 Qcdr
= intern ("cdr");
2911 /* Handle automatic advice activation */
2912 Qad_advice_info
= intern ("ad-advice-info");
2913 Qad_activate_internal
= intern ("ad-activate-internal");
2915 error_tail
= Fcons (Qerror
, Qnil
);
2917 /* ERROR is used as a signaler for random errors for which nothing else is right */
2919 Fput (Qerror
, Qerror_conditions
,
2921 Fput (Qerror
, Qerror_message
,
2922 build_string ("error"));
2924 Fput (Qquit
, Qerror_conditions
,
2925 Fcons (Qquit
, Qnil
));
2926 Fput (Qquit
, Qerror_message
,
2927 build_string ("Quit"));
2929 Fput (Qwrong_type_argument
, Qerror_conditions
,
2930 Fcons (Qwrong_type_argument
, error_tail
));
2931 Fput (Qwrong_type_argument
, Qerror_message
,
2932 build_string ("Wrong type argument"));
2934 Fput (Qargs_out_of_range
, Qerror_conditions
,
2935 Fcons (Qargs_out_of_range
, error_tail
));
2936 Fput (Qargs_out_of_range
, Qerror_message
,
2937 build_string ("Args out of range"));
2939 Fput (Qvoid_function
, Qerror_conditions
,
2940 Fcons (Qvoid_function
, error_tail
));
2941 Fput (Qvoid_function
, Qerror_message
,
2942 build_string ("Symbol's function definition is void"));
2944 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2945 Fcons (Qcyclic_function_indirection
, error_tail
));
2946 Fput (Qcyclic_function_indirection
, Qerror_message
,
2947 build_string ("Symbol's chain of function indirections contains a loop"));
2949 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2950 Fcons (Qcyclic_variable_indirection
, error_tail
));
2951 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2952 build_string ("Symbol's chain of variable indirections contains a loop"));
2954 Qcircular_list
= intern ("circular-list");
2955 staticpro (&Qcircular_list
);
2956 Fput (Qcircular_list
, Qerror_conditions
,
2957 Fcons (Qcircular_list
, error_tail
));
2958 Fput (Qcircular_list
, Qerror_message
,
2959 build_string ("List contains a loop"));
2961 Fput (Qvoid_variable
, Qerror_conditions
,
2962 Fcons (Qvoid_variable
, error_tail
));
2963 Fput (Qvoid_variable
, Qerror_message
,
2964 build_string ("Symbol's value as variable is void"));
2966 Fput (Qsetting_constant
, Qerror_conditions
,
2967 Fcons (Qsetting_constant
, error_tail
));
2968 Fput (Qsetting_constant
, Qerror_message
,
2969 build_string ("Attempt to set a constant symbol"));
2971 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2972 Fcons (Qinvalid_read_syntax
, error_tail
));
2973 Fput (Qinvalid_read_syntax
, Qerror_message
,
2974 build_string ("Invalid read syntax"));
2976 Fput (Qinvalid_function
, Qerror_conditions
,
2977 Fcons (Qinvalid_function
, error_tail
));
2978 Fput (Qinvalid_function
, Qerror_message
,
2979 build_string ("Invalid function"));
2981 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2982 Fcons (Qwrong_number_of_arguments
, error_tail
));
2983 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2984 build_string ("Wrong number of arguments"));
2986 Fput (Qno_catch
, Qerror_conditions
,
2987 Fcons (Qno_catch
, error_tail
));
2988 Fput (Qno_catch
, Qerror_message
,
2989 build_string ("No catch for tag"));
2991 Fput (Qend_of_file
, Qerror_conditions
,
2992 Fcons (Qend_of_file
, error_tail
));
2993 Fput (Qend_of_file
, Qerror_message
,
2994 build_string ("End of file during parsing"));
2996 arith_tail
= Fcons (Qarith_error
, error_tail
);
2997 Fput (Qarith_error
, Qerror_conditions
,
2999 Fput (Qarith_error
, Qerror_message
,
3000 build_string ("Arithmetic error"));
3002 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3003 Fcons (Qbeginning_of_buffer
, error_tail
));
3004 Fput (Qbeginning_of_buffer
, Qerror_message
,
3005 build_string ("Beginning of buffer"));
3007 Fput (Qend_of_buffer
, Qerror_conditions
,
3008 Fcons (Qend_of_buffer
, error_tail
));
3009 Fput (Qend_of_buffer
, Qerror_message
,
3010 build_string ("End of buffer"));
3012 Fput (Qbuffer_read_only
, Qerror_conditions
,
3013 Fcons (Qbuffer_read_only
, error_tail
));
3014 Fput (Qbuffer_read_only
, Qerror_message
,
3015 build_string ("Buffer is read-only"));
3017 Fput (Qtext_read_only
, Qerror_conditions
,
3018 Fcons (Qtext_read_only
, error_tail
));
3019 Fput (Qtext_read_only
, Qerror_message
,
3020 build_string ("Text is read-only"));
3022 Qrange_error
= intern ("range-error");
3023 Qdomain_error
= intern ("domain-error");
3024 Qsingularity_error
= intern ("singularity-error");
3025 Qoverflow_error
= intern ("overflow-error");
3026 Qunderflow_error
= intern ("underflow-error");
3028 Fput (Qdomain_error
, Qerror_conditions
,
3029 Fcons (Qdomain_error
, arith_tail
));
3030 Fput (Qdomain_error
, Qerror_message
,
3031 build_string ("Arithmetic domain error"));
3033 Fput (Qrange_error
, Qerror_conditions
,
3034 Fcons (Qrange_error
, arith_tail
));
3035 Fput (Qrange_error
, Qerror_message
,
3036 build_string ("Arithmetic range error"));
3038 Fput (Qsingularity_error
, Qerror_conditions
,
3039 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3040 Fput (Qsingularity_error
, Qerror_message
,
3041 build_string ("Arithmetic singularity error"));
3043 Fput (Qoverflow_error
, Qerror_conditions
,
3044 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3045 Fput (Qoverflow_error
, Qerror_message
,
3046 build_string ("Arithmetic overflow error"));
3048 Fput (Qunderflow_error
, Qerror_conditions
,
3049 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3050 Fput (Qunderflow_error
, Qerror_message
,
3051 build_string ("Arithmetic underflow error"));
3053 staticpro (&Qrange_error
);
3054 staticpro (&Qdomain_error
);
3055 staticpro (&Qsingularity_error
);
3056 staticpro (&Qoverflow_error
);
3057 staticpro (&Qunderflow_error
);
3061 staticpro (&Qquote
);
3062 staticpro (&Qlambda
);
3064 staticpro (&Qunbound
);
3065 staticpro (&Qerror_conditions
);
3066 staticpro (&Qerror_message
);
3067 staticpro (&Qtop_level
);
3069 staticpro (&Qerror
);
3071 staticpro (&Qwrong_type_argument
);
3072 staticpro (&Qargs_out_of_range
);
3073 staticpro (&Qvoid_function
);
3074 staticpro (&Qcyclic_function_indirection
);
3075 staticpro (&Qcyclic_variable_indirection
);
3076 staticpro (&Qvoid_variable
);
3077 staticpro (&Qsetting_constant
);
3078 staticpro (&Qinvalid_read_syntax
);
3079 staticpro (&Qwrong_number_of_arguments
);
3080 staticpro (&Qinvalid_function
);
3081 staticpro (&Qno_catch
);
3082 staticpro (&Qend_of_file
);
3083 staticpro (&Qarith_error
);
3084 staticpro (&Qbeginning_of_buffer
);
3085 staticpro (&Qend_of_buffer
);
3086 staticpro (&Qbuffer_read_only
);
3087 staticpro (&Qtext_read_only
);
3088 staticpro (&Qmark_inactive
);
3090 staticpro (&Qlistp
);
3091 staticpro (&Qconsp
);
3092 staticpro (&Qsymbolp
);
3093 staticpro (&Qkeywordp
);
3094 staticpro (&Qintegerp
);
3095 staticpro (&Qnatnump
);
3096 staticpro (&Qwholenump
);
3097 staticpro (&Qstringp
);
3098 staticpro (&Qarrayp
);
3099 staticpro (&Qsequencep
);
3100 staticpro (&Qbufferp
);
3101 staticpro (&Qvectorp
);
3102 staticpro (&Qchar_or_string_p
);
3103 staticpro (&Qmarkerp
);
3104 staticpro (&Qbuffer_or_string_p
);
3105 staticpro (&Qinteger_or_marker_p
);
3106 staticpro (&Qfloatp
);
3107 staticpro (&Qnumberp
);
3108 staticpro (&Qnumber_or_marker_p
);
3109 staticpro (&Qchar_table_p
);
3110 staticpro (&Qvector_or_char_table_p
);
3111 staticpro (&Qsubrp
);
3113 staticpro (&Qunevalled
);
3115 staticpro (&Qboundp
);
3116 staticpro (&Qfboundp
);
3118 staticpro (&Qad_advice_info
);
3119 staticpro (&Qad_activate_internal
);
3121 /* Types that type-of returns. */
3122 Qinteger
= intern ("integer");
3123 Qsymbol
= intern ("symbol");
3124 Qstring
= intern ("string");
3125 Qcons
= intern ("cons");
3126 Qmarker
= intern ("marker");
3127 Qoverlay
= intern ("overlay");
3128 Qfloat
= intern ("float");
3129 Qwindow_configuration
= intern ("window-configuration");
3130 Qprocess
= intern ("process");
3131 Qwindow
= intern ("window");
3132 /* Qsubr = intern ("subr"); */
3133 Qcompiled_function
= intern ("compiled-function");
3134 Qbuffer
= intern ("buffer");
3135 Qframe
= intern ("frame");
3136 Qvector
= intern ("vector");
3137 Qchar_table
= intern ("char-table");
3138 Qbool_vector
= intern ("bool-vector");
3139 Qhash_table
= intern ("hash-table");
3141 staticpro (&Qinteger
);
3142 staticpro (&Qsymbol
);
3143 staticpro (&Qstring
);
3145 staticpro (&Qmarker
);
3146 staticpro (&Qoverlay
);
3147 staticpro (&Qfloat
);
3148 staticpro (&Qwindow_configuration
);
3149 staticpro (&Qprocess
);
3150 staticpro (&Qwindow
);
3151 /* staticpro (&Qsubr); */
3152 staticpro (&Qcompiled_function
);
3153 staticpro (&Qbuffer
);
3154 staticpro (&Qframe
);
3155 staticpro (&Qvector
);
3156 staticpro (&Qchar_table
);
3157 staticpro (&Qbool_vector
);
3158 staticpro (&Qhash_table
);
3160 defsubr (&Sindirect_variable
);
3161 defsubr (&Sinteractive_form
);
3164 defsubr (&Stype_of
);
3169 defsubr (&Sintegerp
);
3170 defsubr (&Sinteger_or_marker_p
);
3171 defsubr (&Snumberp
);
3172 defsubr (&Snumber_or_marker_p
);
3174 defsubr (&Snatnump
);
3175 defsubr (&Ssymbolp
);
3176 defsubr (&Skeywordp
);
3177 defsubr (&Sstringp
);
3178 defsubr (&Smultibyte_string_p
);
3179 defsubr (&Svectorp
);
3180 defsubr (&Schar_table_p
);
3181 defsubr (&Svector_or_char_table_p
);
3182 defsubr (&Sbool_vector_p
);
3184 defsubr (&Ssequencep
);
3185 defsubr (&Sbufferp
);
3186 defsubr (&Smarkerp
);
3188 defsubr (&Sbyte_code_function_p
);
3189 defsubr (&Schar_or_string_p
);
3192 defsubr (&Scar_safe
);
3193 defsubr (&Scdr_safe
);
3196 defsubr (&Ssymbol_function
);
3197 defsubr (&Sindirect_function
);
3198 defsubr (&Ssymbol_plist
);
3199 defsubr (&Ssymbol_name
);
3200 defsubr (&Smakunbound
);
3201 defsubr (&Sfmakunbound
);
3203 defsubr (&Sfboundp
);
3205 defsubr (&Sdefalias
);
3206 defsubr (&Ssetplist
);
3207 defsubr (&Ssymbol_value
);
3209 defsubr (&Sdefault_boundp
);
3210 defsubr (&Sdefault_value
);
3211 defsubr (&Sset_default
);
3212 defsubr (&Ssetq_default
);
3213 defsubr (&Smake_variable_buffer_local
);
3214 defsubr (&Smake_local_variable
);
3215 defsubr (&Skill_local_variable
);
3216 defsubr (&Smake_variable_frame_local
);
3217 defsubr (&Slocal_variable_p
);
3218 defsubr (&Slocal_variable_if_set_p
);
3219 defsubr (&Svariable_binding_locus
);
3220 #if 0 /* XXX Remove this. --lorentey */
3221 defsubr (&Sterminal_local_value
);
3222 defsubr (&Sset_terminal_local_value
);
3226 defsubr (&Snumber_to_string
);
3227 defsubr (&Sstring_to_number
);
3228 defsubr (&Seqlsign
);
3251 defsubr (&Sbyteorder
);
3252 defsubr (&Ssubr_arity
);
3253 defsubr (&Ssubr_name
);
3255 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3257 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3258 doc
: /* The largest value that is representable in a Lisp integer. */);
3259 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3260 XSYMBOL (intern ("most-positive-fixnum"))->constant
= 1;
3262 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3263 doc
: /* The smallest value that is representable in a Lisp integer. */);
3264 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3265 XSYMBOL (intern ("most-negative-fixnum"))->constant
= 1;
3272 #if defined(USG) && !defined(POSIX_SIGNALS)
3273 /* USG systems forget handlers when they are used;
3274 must reestablish each time */
3275 signal (signo
, arith_error
);
3277 sigsetmask (SIGEMPTYMASK
);
3279 SIGNAL_THREAD_CHECK (signo
);
3280 xsignal0 (Qarith_error
);
3286 /* Don't do this if just dumping out.
3287 We don't want to call `signal' in this case
3288 so that we don't have trouble with dumping
3289 signal-delivering routines in an inconsistent state. */
3293 #endif /* CANNOT_DUMP */
3294 signal (SIGFPE
, arith_error
);
3297 signal (SIGEMT
, arith_error
);
3301 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3302 (do not change this comment) */