1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
53 extern double atof ();
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
87 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static Lisp_Object swap_in_symval_forwarding
P_ ((Lisp_Object
, Lisp_Object
));
96 Lisp_Object impl_Vmost_positive_fixnum
, impl_Vmost_negative_fixnum
;
100 circular_list_error (list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (predicate
, value
)
109 register Lisp_Object predicate
, value
;
111 /* If VALUE is not even a valid Lisp object, we'd want to abort here
112 where we can get a backtrace showing where it came from. We used
113 to try and do that by checking the tagbits, but nowadays all
114 tagbits are potentially valid. */
115 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
118 xsignal2 (Qwrong_type_argument
, predicate
, value
);
124 error ("Attempt to modify read-only object");
128 args_out_of_range (a1
, a2
)
131 xsignal2 (Qargs_out_of_range
, a1
, a2
);
135 args_out_of_range_3 (a1
, a2
, a3
)
136 Lisp_Object a1
, a2
, a3
;
138 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
141 /* On some machines, XINT needs a temporary location.
142 Here it is, in case it is needed. */
144 int sign_extend_temp
;
146 /* On a few machines, XINT can only be done by calling this. */
149 sign_extend_lisp_int (num
)
152 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
153 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
155 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
158 /* Data type predicates */
160 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
161 doc
: /* Return t if the two args are the same Lisp object. */)
163 Lisp_Object obj1
, obj2
;
170 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
171 doc
: /* Return t if OBJECT is nil. */)
180 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
181 doc
: /* Return a symbol representing the type of OBJECT.
182 The symbol returned names the object's basic type;
183 for example, (type-of 1) returns `integer'. */)
187 switch (XTYPE (object
))
202 switch (XMISCTYPE (object
))
204 case Lisp_Misc_Marker
:
206 case Lisp_Misc_Overlay
:
208 case Lisp_Misc_Float
:
213 case Lisp_Vectorlike
:
214 if (WINDOW_CONFIGURATIONP (object
))
215 return Qwindow_configuration
;
216 if (PROCESSP (object
))
218 if (WINDOWP (object
))
222 if (COMPILEDP (object
))
223 return Qcompiled_function
;
224 if (BUFFERP (object
))
226 if (CHAR_TABLE_P (object
))
228 if (BOOL_VECTOR_P (object
))
232 if (HASH_TABLE_P (object
))
234 if (FONT_SPEC_P (object
))
236 if (FONT_ENTITY_P (object
))
238 if (FONT_OBJECT_P (object
))
250 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
251 doc
: /* Return t if OBJECT is a cons cell. */)
260 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
261 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
270 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
271 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
272 Otherwise, return nil. */)
276 if (CONSP (object
) || NILP (object
))
281 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
282 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
286 if (CONSP (object
) || NILP (object
))
291 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
292 doc
: /* Return t if OBJECT is a symbol. */)
296 if (SYMBOLP (object
))
301 /* Define this in C to avoid unnecessarily consing up the symbol
303 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
304 doc
: /* Return t if OBJECT is a keyword.
305 This means that it is a symbol with a print name beginning with `:'
306 interned in the initial obarray. */)
311 && SREF (SYMBOL_NAME (object
), 0) == ':'
312 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
317 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
318 doc
: /* Return t if OBJECT is a vector. */)
322 if (VECTORP (object
))
327 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
328 doc
: /* Return t if OBJECT is a string. */)
332 if (STRINGP (object
))
337 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
339 doc
: /* Return t if OBJECT is a multibyte string. */)
343 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
348 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
349 doc
: /* Return t if OBJECT is a char-table. */)
353 if (CHAR_TABLE_P (object
))
358 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
359 Svector_or_char_table_p
, 1, 1, 0,
360 doc
: /* Return t if OBJECT is a char-table or vector. */)
364 if (VECTORP (object
) || CHAR_TABLE_P (object
))
369 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a bool-vector. */)
374 if (BOOL_VECTOR_P (object
))
379 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
380 doc
: /* Return t if OBJECT is an array (string or vector). */)
389 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
390 doc
: /* Return t if OBJECT is a sequence (list or array). */)
392 register Lisp_Object object
;
394 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
399 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
400 doc
: /* Return t if OBJECT is an editor buffer. */)
404 if (BUFFERP (object
))
409 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
410 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
414 if (MARKERP (object
))
419 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
420 doc
: /* Return t if OBJECT is a built-in function. */)
429 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
431 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
435 if (COMPILEDP (object
))
440 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
441 doc
: /* Return t if OBJECT is a character or a string. */)
443 register Lisp_Object object
;
445 if (CHARACTERP (object
) || STRINGP (object
))
450 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
451 doc
: /* Return t if OBJECT is an integer. */)
455 if (INTEGERP (object
))
460 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
461 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
463 register Lisp_Object object
;
465 if (MARKERP (object
) || INTEGERP (object
))
470 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
471 doc
: /* Return t if OBJECT is a nonnegative integer. */)
475 if (NATNUMP (object
))
480 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
481 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
485 if (NUMBERP (object
))
491 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
492 Snumber_or_marker_p
, 1, 1, 0,
493 doc
: /* Return t if OBJECT is a number or a marker. */)
497 if (NUMBERP (object
) || MARKERP (object
))
502 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
503 doc
: /* Return t if OBJECT is a floating point number. */)
513 /* Extract and set components of lists */
515 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
516 doc
: /* Return the car of LIST. If arg is nil, return nil.
517 Error if arg is not nil and not a cons cell. See also `car-safe'.
519 See Info node `(elisp)Cons Cells' for a discussion of related basic
520 Lisp concepts such as car, cdr, cons cell and list. */)
522 register Lisp_Object list
;
527 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
528 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
532 return CAR_SAFE (object
);
535 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
536 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
537 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
539 See Info node `(elisp)Cons Cells' for a discussion of related basic
540 Lisp concepts such as cdr, car, cons cell and list. */)
542 register Lisp_Object list
;
547 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
548 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
552 return CDR_SAFE (object
);
555 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
556 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
558 register Lisp_Object cell
, newcar
;
562 XSETCAR (cell
, newcar
);
566 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
567 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
569 register Lisp_Object cell
, newcdr
;
573 XSETCDR (cell
, newcdr
);
577 /* Extract and set components of symbols */
579 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
580 doc
: /* Return t if SYMBOL's value is not void. */)
582 register Lisp_Object symbol
;
584 Lisp_Object valcontents
;
585 CHECK_SYMBOL (symbol
);
587 valcontents
= SYMBOL_VALUE (symbol
);
589 if (BUFFER_LOCAL_VALUEP (valcontents
))
590 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
592 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
595 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
596 doc
: /* Return t if SYMBOL's function definition is not void. */)
598 register Lisp_Object symbol
;
600 CHECK_SYMBOL (symbol
);
601 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
604 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
605 doc
: /* Make SYMBOL's value be void.
608 register Lisp_Object symbol
;
610 CHECK_SYMBOL (symbol
);
611 if (SYMBOL_CONSTANT_P (symbol
))
612 xsignal1 (Qsetting_constant
, symbol
);
613 Fset (symbol
, Qunbound
);
617 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
618 doc
: /* Make SYMBOL's function definition be void.
621 register Lisp_Object symbol
;
623 CHECK_SYMBOL (symbol
);
624 if (NILP (symbol
) || EQ (symbol
, Qt
))
625 xsignal1 (Qsetting_constant
, symbol
);
626 XSYMBOL (symbol
)->function
= Qunbound
;
630 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
631 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
633 register Lisp_Object symbol
;
635 CHECK_SYMBOL (symbol
);
636 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
637 return XSYMBOL (symbol
)->function
;
638 xsignal1 (Qvoid_function
, symbol
);
641 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
642 doc
: /* Return SYMBOL's property list. */)
644 register Lisp_Object symbol
;
646 CHECK_SYMBOL (symbol
);
647 return XSYMBOL (symbol
)->plist
;
650 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
651 doc
: /* Return SYMBOL's name, a string. */)
653 register Lisp_Object symbol
;
655 register Lisp_Object name
;
657 CHECK_SYMBOL (symbol
);
658 name
= SYMBOL_NAME (symbol
);
662 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
663 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
665 register Lisp_Object symbol
, definition
;
667 register Lisp_Object function
;
669 CHECK_SYMBOL (symbol
);
670 if (NILP (symbol
) || EQ (symbol
, Qt
))
671 xsignal1 (Qsetting_constant
, symbol
);
673 function
= XSYMBOL (symbol
)->function
;
675 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
676 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
678 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
679 Fput (symbol
, Qautoload
, XCDR (function
));
681 XSYMBOL (symbol
)->function
= definition
;
682 /* Handle automatic advice activation */
683 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
685 call2 (Qad_activate_internal
, symbol
, Qnil
);
686 definition
= XSYMBOL (symbol
)->function
;
691 extern Lisp_Object Qfunction_documentation
;
693 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
694 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
695 Associates the function with the current load file, if any.
696 The optional third argument DOCSTRING specifies the documentation string
697 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
698 determined by DEFINITION. */)
699 (symbol
, definition
, docstring
)
700 register Lisp_Object symbol
, definition
, docstring
;
702 CHECK_SYMBOL (symbol
);
703 if (CONSP (XSYMBOL (symbol
)->function
)
704 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
705 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
706 definition
= Ffset (symbol
, definition
);
707 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
708 if (!NILP (docstring
))
709 Fput (symbol
, Qfunction_documentation
, docstring
);
713 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
714 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
716 register Lisp_Object symbol
, newplist
;
718 CHECK_SYMBOL (symbol
);
719 XSYMBOL (symbol
)->plist
= newplist
;
723 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
724 doc
: /* Return minimum and maximum number of args allowed for SUBR.
725 SUBR must be a built-in function.
726 The returned value is a pair (MIN . MAX). MIN is the minimum number
727 of args. MAX is the maximum number or the symbol `many', for a
728 function with `&rest' args, or `unevalled' for a special form. */)
732 short minargs
, maxargs
;
734 minargs
= XSUBR (subr
)->min_args
;
735 maxargs
= XSUBR (subr
)->max_args
;
737 return Fcons (make_number (minargs
), Qmany
);
738 else if (maxargs
== UNEVALLED
)
739 return Fcons (make_number (minargs
), Qunevalled
);
741 return Fcons (make_number (minargs
), make_number (maxargs
));
744 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
745 doc
: /* Return name of subroutine SUBR.
746 SUBR must be a built-in function. */)
752 name
= XSUBR (subr
)->symbol_name
;
753 return make_string (name
, strlen (name
));
756 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
757 doc
: /* Return the interactive form of CMD or nil if none.
758 If CMD is not a command, the return value is nil.
759 Value, if non-nil, is a list \(interactive SPEC). */)
763 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
765 if (NILP (fun
) || EQ (fun
, Qunbound
))
768 /* Use an `interactive-form' property if present, analogous to the
769 function-documentation property. */
771 while (SYMBOLP (fun
))
773 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
777 fun
= Fsymbol_function (fun
);
782 char *spec
= XSUBR (fun
)->intspec
;
784 return list2 (Qinteractive
,
785 (*spec
!= '(') ? build_string (spec
) :
786 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
788 else if (COMPILEDP (fun
))
790 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
791 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
793 else if (CONSP (fun
))
795 Lisp_Object funcar
= XCAR (fun
);
796 if (EQ (funcar
, Qlambda
))
797 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
798 else if (EQ (funcar
, Qautoload
))
802 do_autoload (fun
, cmd
);
804 return Finteractive_form (cmd
);
811 /***********************************************************************
812 Getting and Setting Values of Symbols
813 ***********************************************************************/
816 find_variable_location (Lisp_Object
*root
)
818 if (THREADLOCALP (*root
))
820 struct Lisp_ThreadLocal
*thr
= XTHREADLOCAL (*root
);
827 /* Return the symbol holding SYMBOL's value. Signal
828 `cyclic-variable-indirection' if SYMBOL's chain of variable
829 indirections contains a loop. */
832 indirect_variable (symbol
)
833 struct Lisp_Symbol
*symbol
;
835 struct Lisp_Symbol
*tortoise
, *hare
;
837 hare
= tortoise
= symbol
;
839 while (hare
->indirect_variable
)
841 hare
= XSYMBOL (hare
->value
);
842 if (!hare
->indirect_variable
)
845 hare
= XSYMBOL (hare
->value
);
846 tortoise
= XSYMBOL (tortoise
->value
);
848 if (hare
== tortoise
)
851 XSETSYMBOL (tem
, symbol
);
852 xsignal1 (Qcyclic_variable_indirection
, tem
);
860 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
861 doc
: /* Return the variable at the end of OBJECT's variable chain.
862 If OBJECT is a symbol, follow all variable indirections and return the final
863 variable. If OBJECT is not a symbol, just return it.
864 Signal a cyclic-variable-indirection error if there is a loop in the
865 variable chain of symbols. */)
869 if (SYMBOLP (object
))
870 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
875 /* Given the raw contents of a symbol value cell,
876 return the Lisp value of the symbol.
877 This does not handle buffer-local variables; use
878 swap_in_symval_forwarding for that. */
881 do_symval_forwarding (valcontents
)
882 register Lisp_Object valcontents
;
884 register Lisp_Object val
;
885 if (MISCP (valcontents
))
886 switch (XMISCTYPE (valcontents
))
888 case Lisp_Misc_Intfwd
:
889 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
892 case Lisp_Misc_Boolfwd
:
893 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
895 case Lisp_Misc_Objfwd
:
896 return *XOBJFWD (valcontents
)->objvar
;
898 case Lisp_Misc_Buffer_Objfwd
:
899 return PER_BUFFER_VALUE (current_buffer
,
900 XBUFFER_OBJFWD (valcontents
)->offset
);
902 case Lisp_Misc_Kboard_Objfwd
:
903 /* We used to simply use current_kboard here, but from Lisp
904 code, it's value is often unexpected. It seems nicer to
905 allow constructions like this to work as intuitively expected:
907 (with-selected-frame frame
908 (define-key local-function-map "\eOP" [f1]))
910 On the other hand, this affects the semantics of
911 last-command and real-last-command, and people may rely on
912 that. I took a quick look at the Lisp codebase, and I
913 don't think anything will break. --lorentey */
914 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
915 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
920 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
921 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
922 buffer-independent contents of the value cell: forwarded just one
923 step past the buffer-localness.
925 BUF non-zero means set the value in buffer BUF instead of the
926 current buffer. This only plays a role for per-buffer variables. */
929 store_symval_forwarding (symbol
, valcontents
, newval
, buf
)
931 register Lisp_Object valcontents
, newval
;
934 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
937 switch (XMISCTYPE (valcontents
))
939 case Lisp_Misc_Intfwd
:
940 CHECK_NUMBER (newval
);
941 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
942 /* This can never happen since intvar points to an EMACS_INT
943 which is at least large enough to hold a Lisp_Object.
944 if (*XINTFWD (valcontents)->intvar != XINT (newval))
945 error ("Value out of range for variable `%s'",
946 SDATA (SYMBOL_NAME (symbol))); */
949 case Lisp_Misc_Boolfwd
:
950 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
953 case Lisp_Misc_Objfwd
:
954 *XOBJFWD (valcontents
)->objvar
= newval
;
956 /* If this variable is a default for something stored
957 in the buffer itself, such as default-fill-column,
958 find the buffers that don't have local values for it
960 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
961 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
963 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
964 - (char *) &buffer_defaults
);
965 int idx
= PER_BUFFER_IDX (offset
);
972 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
977 buf
= Fcdr (XCAR (tail
));
978 if (!BUFFERP (buf
)) continue;
981 if (! PER_BUFFER_VALUE_P (b
, idx
))
982 PER_BUFFER_VALUE (b
, offset
) = newval
;
987 case Lisp_Misc_Buffer_Objfwd
:
989 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
990 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
992 if (!(NILP (type
) || NILP (newval
)
993 || (XINT (type
) == LISP_INT_TAG
995 : XTYPE (newval
) == XINT (type
))))
996 buffer_slot_type_mismatch (newval
, XINT (type
));
999 buf
= current_buffer
;
1000 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1004 case Lisp_Misc_Kboard_Objfwd
:
1006 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1007 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1008 *(Lisp_Object
*) p
= newval
;
1019 valcontents
= SYMBOL_VALUE (symbol
);
1020 if (BUFFER_LOCAL_VALUEP (valcontents
))
1021 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
= newval
;
1023 SET_SYMBOL_VALUE (symbol
, newval
);
1027 /* Set up SYMBOL to refer to its global binding.
1028 This makes it safe to alter the status of other bindings. */
1031 swap_in_global_binding (symbol
)
1034 Lisp_Object valcontents
= SYMBOL_VALUE (symbol
);
1035 struct Lisp_Buffer_Local_Value
*blv
= XBUFFER_LOCAL_VALUE (valcontents
);
1036 Lisp_Object cdr
= blv
->cdr
;
1038 /* Unload the previously loaded binding. */
1039 Fsetcdr (XCAR (cdr
),
1040 do_symval_forwarding (blv
->realvalue
));
1042 /* Select the global binding in the symbol. */
1044 store_symval_forwarding (symbol
, blv
->realvalue
, XCDR (cdr
), NULL
);
1046 /* Indicate that the global binding is set up now. */
1049 blv
->found_for_frame
= 0;
1050 blv
->found_for_buffer
= 0;
1053 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1054 VALCONTENTS is the contents of its value cell,
1055 which points to a struct Lisp_Buffer_Local_Value.
1057 Return the value forwarded one step past the buffer-local stage.
1058 This could be another forwarding pointer. */
1061 swap_in_symval_forwarding (symbol
, valcontents
)
1062 Lisp_Object symbol
, valcontents
;
1064 register Lisp_Object tem1
;
1066 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1069 || current_buffer
!= XBUFFER (tem1
)
1070 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1071 && ! EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
)))
1073 struct Lisp_Symbol
*sym
= XSYMBOL (symbol
);
1074 if (sym
->indirect_variable
)
1076 sym
= indirect_variable (sym
);
1077 XSETSYMBOL (symbol
, sym
);
1080 /* Unload the previously loaded binding. */
1081 tem1
= XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1083 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1084 /* Choose the new binding. */
1085 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
1086 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1087 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1090 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1091 tem1
= assq_no_quit (symbol
, XFRAME (selected_frame
)->param_alist
);
1093 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1095 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1098 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1100 /* Load the new binding. */
1101 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1102 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, current_buffer
);
1103 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1104 store_symval_forwarding (symbol
,
1105 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1108 return XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1111 /* Find the value of a symbol, returning Qunbound if it's not bound.
1112 This is helpful for code which just wants to get a variable's value
1113 if it has one, without signaling an error.
1114 Note that it must not be possible to quit
1115 within this function. Great care is required for this. */
1118 find_symbol_value (symbol
)
1121 register Lisp_Object valcontents
;
1122 register Lisp_Object val
;
1124 CHECK_SYMBOL (symbol
);
1125 valcontents
= SYMBOL_VALUE (symbol
);
1127 if (BUFFER_LOCAL_VALUEP (valcontents
))
1128 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
1130 return do_symval_forwarding (valcontents
);
1133 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1134 doc
: /* Return SYMBOL's value. Error if that is void. */)
1140 val
= find_symbol_value (symbol
);
1141 if (!EQ (val
, Qunbound
))
1144 xsignal1 (Qvoid_variable
, symbol
);
1147 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1148 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1150 register Lisp_Object symbol
, newval
;
1152 return set_internal (symbol
, newval
, current_buffer
, 0);
1155 /* Return 1 if SYMBOL currently has a let-binding
1156 which was made in the buffer that is now current. */
1159 let_shadows_buffer_binding_p (symbol
)
1160 struct Lisp_Symbol
*symbol
;
1162 volatile struct specbinding
*p
;
1164 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1166 && CONSP (p
->symbol
))
1168 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1169 if ((symbol
== let_bound_symbol
1170 || (let_bound_symbol
->indirect_variable
1171 && symbol
== indirect_variable (let_bound_symbol
)))
1172 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1176 return p
>= specpdl
;
1179 /* Store the value NEWVAL into SYMBOL.
1180 If buffer-locality is an issue, BUF specifies which buffer to use.
1181 (0 stands for the current buffer.)
1183 If BINDFLAG is zero, then if this symbol is supposed to become
1184 local in every buffer where it is set, then we make it local.
1185 If BINDFLAG is nonzero, we don't do that. */
1188 set_internal (symbol
, newval
, buf
, bindflag
)
1189 register Lisp_Object symbol
, newval
;
1193 int voide
= EQ (newval
, Qunbound
);
1195 register Lisp_Object valcontents
, innercontents
, tem1
, current_alist_element
;
1198 buf
= current_buffer
;
1200 /* If restoring in a dead buffer, do nothing. */
1201 if (NILP (buf
->name
))
1204 CHECK_SYMBOL (symbol
);
1205 if (SYMBOL_CONSTANT_P (symbol
)
1206 && (NILP (Fkeywordp (symbol
))
1207 || !EQ (newval
, SYMBOL_VALUE (symbol
))))
1208 xsignal1 (Qsetting_constant
, symbol
);
1210 innercontents
= valcontents
= SYMBOL_VALUE (symbol
);
1212 if (BUFFER_OBJFWDP (valcontents
))
1214 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1215 int idx
= PER_BUFFER_IDX (offset
);
1218 && !let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1219 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1221 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1223 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1224 if (XSYMBOL (symbol
)->indirect_variable
)
1225 XSETSYMBOL (symbol
, indirect_variable (XSYMBOL (symbol
)));
1227 /* What binding is loaded right now? */
1228 current_alist_element
1229 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1231 /* If the current buffer is not the buffer whose binding is
1232 loaded, or if there may be frame-local bindings and the frame
1233 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1234 the default binding is loaded, the loaded binding may be the
1236 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1237 || buf
!= XBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
)
1238 || (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
1239 && !EQ (selected_frame
, XBUFFER_LOCAL_VALUE (valcontents
)->frame
))
1240 /* Also unload a global binding (if the var is local_if_set). */
1241 || (EQ (XCAR (current_alist_element
),
1242 current_alist_element
)))
1244 /* The currently loaded binding is not necessarily valid.
1245 We need to unload it, and choose a new binding. */
1247 /* Write out `realvalue' to the old loaded binding. */
1248 Fsetcdr (current_alist_element
,
1249 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
));
1251 /* Find the new binding. */
1252 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1253 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 1;
1254 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 0;
1258 /* This buffer still sees the default value. */
1260 /* If the variable is not local_if_set,
1261 or if this is `let' rather than `set',
1262 make CURRENT-ALIST-ELEMENT point to itself,
1263 indicating that we're seeing the default value.
1264 Likewise if the variable has been let-bound
1265 in the current buffer. */
1266 if (bindflag
|| !XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
1267 || let_shadows_buffer_binding_p (XSYMBOL (symbol
)))
1269 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1271 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1272 tem1
= Fassq (symbol
,
1273 XFRAME (selected_frame
)->param_alist
);
1276 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
= 1;
1278 tem1
= XBUFFER_LOCAL_VALUE (valcontents
)->cdr
;
1280 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1281 and we're not within a let that was made for this buffer,
1282 create a new buffer-local binding for the variable.
1283 That means, give this buffer a new assoc for a local value
1284 and load that binding. */
1287 tem1
= Fcons (symbol
, XCDR (current_alist_element
));
1288 buf
->local_var_alist
1289 = Fcons (tem1
, buf
->local_var_alist
);
1293 /* Record which binding is now loaded. */
1294 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, tem1
);
1296 /* Set `buffer' and `frame' slots for the binding now loaded. */
1297 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents
)->buffer
, buf
);
1298 XBUFFER_LOCAL_VALUE (valcontents
)->frame
= selected_frame
;
1300 innercontents
= XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
;
1302 /* Store the new value in the cons-cell. */
1303 XSETCDR (XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
), newval
);
1306 /* If storing void (making the symbol void), forward only through
1307 buffer-local indicator, not through Lisp_Objfwd, etc. */
1309 store_symval_forwarding (symbol
, Qnil
, newval
, buf
);
1311 store_symval_forwarding (symbol
, innercontents
, newval
, buf
);
1316 /* Access or set a buffer-local symbol's default value. */
1318 /* Return the default value of SYMBOL, but don't check for voidness.
1319 Return Qunbound if it is void. */
1322 default_value (symbol
)
1325 register Lisp_Object valcontents
;
1327 CHECK_SYMBOL (symbol
);
1328 valcontents
= SYMBOL_VALUE (symbol
);
1330 /* For a built-in buffer-local variable, get the default value
1331 rather than letting do_symval_forwarding get the current value. */
1332 if (BUFFER_OBJFWDP (valcontents
))
1334 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1335 if (PER_BUFFER_IDX (offset
) != 0)
1336 return PER_BUFFER_DEFAULT (offset
);
1339 /* Handle user-created local variables. */
1340 if (BUFFER_LOCAL_VALUEP (valcontents
))
1342 /* If var is set up for a buffer that lacks a local value for it,
1343 the current value is nominally the default value.
1344 But the `realvalue' slot may be more up to date, since
1345 ordinary setq stores just that slot. So use that. */
1346 Lisp_Object current_alist_element
, alist_element_car
;
1347 current_alist_element
1348 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1349 alist_element_car
= XCAR (current_alist_element
);
1350 if (EQ (alist_element_car
, current_alist_element
))
1351 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
);
1353 return XCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1355 /* For other variables, get the current value. */
1356 return do_symval_forwarding (valcontents
);
1359 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1360 doc
: /* Return t if SYMBOL has a non-void default value.
1361 This is the value that is seen in buffers that do not have their own values
1362 for this variable. */)
1366 register Lisp_Object value
;
1368 value
= default_value (symbol
);
1369 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1372 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1373 doc
: /* Return SYMBOL's default value.
1374 This is the value that is seen in buffers that do not have their own values
1375 for this variable. The default value is meaningful for variables with
1376 local bindings in certain buffers. */)
1380 register Lisp_Object value
;
1382 value
= default_value (symbol
);
1383 if (!EQ (value
, Qunbound
))
1386 xsignal1 (Qvoid_variable
, symbol
);
1389 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1390 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1391 The default value is seen in buffers that do not have their own values
1392 for this variable. */)
1394 Lisp_Object symbol
, value
;
1396 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1398 CHECK_SYMBOL (symbol
);
1399 valcontents
= SYMBOL_VALUE (symbol
);
1401 /* Handle variables like case-fold-search that have special slots
1402 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1404 if (BUFFER_OBJFWDP (valcontents
))
1406 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1407 int idx
= PER_BUFFER_IDX (offset
);
1409 PER_BUFFER_DEFAULT (offset
) = value
;
1411 /* If this variable is not always local in all buffers,
1412 set it in the buffers that don't nominally have a local value. */
1417 for (b
= all_buffers
; b
; b
= b
->next
)
1418 if (!PER_BUFFER_VALUE_P (b
, idx
))
1419 PER_BUFFER_VALUE (b
, offset
) = value
;
1424 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1425 return Fset (symbol
, value
);
1427 /* Store new value into the DEFAULT-VALUE slot. */
1428 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
, value
);
1430 /* If the default binding is now loaded, set the REALVALUE slot too. */
1431 current_alist_element
1432 = XCAR (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
);
1433 alist_element_buffer
= Fcar (current_alist_element
);
1434 if (EQ (alist_element_buffer
, current_alist_element
))
1435 store_symval_forwarding (symbol
,
1436 XBUFFER_LOCAL_VALUE (valcontents
)->realvalue
,
1442 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1443 doc
: /* Set the default value of variable VAR to VALUE.
1444 VAR, the variable name, is literal (not evaluated);
1445 VALUE is an expression: it is evaluated and its value returned.
1446 The default value of a variable is seen in buffers
1447 that do not have their own values for the variable.
1449 More generally, you can use multiple variables and values, as in
1450 (setq-default VAR VALUE VAR VALUE...)
1451 This sets each VAR's default value to the corresponding VALUE.
1452 The VALUE for the Nth VAR can refer to the new default values
1454 usage: (setq-default [VAR VALUE]...) */)
1458 register Lisp_Object args_left
;
1459 register Lisp_Object val
, symbol
;
1460 struct gcpro gcpro1
;
1470 val
= Feval (Fcar (Fcdr (args_left
)));
1471 symbol
= XCAR (args_left
);
1472 Fset_default (symbol
, val
);
1473 args_left
= Fcdr (XCDR (args_left
));
1475 while (!NILP (args_left
));
1481 /* Lisp functions for creating and removing buffer-local variables. */
1483 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1484 1, 1, "vMake Variable Buffer Local: ",
1485 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1486 At any time, the value for the current buffer is in effect,
1487 unless the variable has never been set in this buffer,
1488 in which case the default value is in effect.
1489 Note that binding the variable with `let', or setting it while
1490 a `let'-style binding made in this buffer is in effect,
1491 does not make the variable buffer-local. Return VARIABLE.
1493 In most cases it is better to use `make-local-variable',
1494 which makes a variable local in just one buffer.
1496 The function `default-value' gets the default value and `set-default' sets it. */)
1498 register Lisp_Object variable
;
1500 register Lisp_Object tem
, valcontents
, newval
;
1501 struct Lisp_Symbol
*sym
;
1503 CHECK_SYMBOL (variable
);
1504 sym
= indirect_variable (XSYMBOL (variable
));
1506 valcontents
= sym
->value
;
1507 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
))
1508 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1510 if (BUFFER_OBJFWDP (valcontents
))
1512 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1514 if (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1515 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1516 newval
= valcontents
;
1520 if (EQ (valcontents
, Qunbound
))
1522 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1524 newval
= allocate_misc ();
1525 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1526 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1527 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Fcurrent_buffer ();
1528 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1529 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1530 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1531 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1532 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1533 sym
->value
= newval
;
1535 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 1;
1539 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1540 1, 1, "vMake Local Variable: ",
1541 doc
: /* Make VARIABLE have a separate value in the current buffer.
1542 Other buffers will continue to share a common default value.
1543 \(The buffer-local value of VARIABLE starts out as the same value
1544 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1547 If the variable is already arranged to become local when set,
1548 this function causes a local value to exist for this buffer,
1549 just as setting the variable would do.
1551 This function returns VARIABLE, and therefore
1552 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1555 See also `make-variable-buffer-local'.
1557 Do not use `make-local-variable' to make a hook variable buffer-local.
1558 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1560 register Lisp_Object variable
;
1562 register Lisp_Object tem
, valcontents
;
1563 struct Lisp_Symbol
*sym
;
1565 CHECK_SYMBOL (variable
);
1566 sym
= indirect_variable (XSYMBOL (variable
));
1568 valcontents
= sym
->value
;
1569 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1570 || (BUFFER_LOCAL_VALUEP (valcontents
)
1571 && (XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)))
1572 error ("Symbol %s may not be buffer-local", SDATA (sym
->xname
));
1574 if ((BUFFER_LOCAL_VALUEP (valcontents
)
1575 && XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1576 || BUFFER_OBJFWDP (valcontents
))
1578 tem
= Fboundp (variable
);
1580 /* Make sure the symbol has a local value in this particular buffer,
1581 by setting it to the same value it already has. */
1582 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1585 /* Make sure symbol is set up to hold per-buffer values. */
1586 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1589 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1591 newval
= allocate_misc ();
1592 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1593 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1594 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1595 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1596 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1597 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1598 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1599 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 0;
1600 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1601 sym
->value
= newval
;
1603 /* Make sure this buffer has its own value of symbol. */
1604 XSETSYMBOL (variable
, sym
); /* Propagate variable indirections. */
1605 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1608 /* Swap out any local binding for some other buffer, and make
1609 sure the current value is permanently recorded, if it's the
1611 find_symbol_value (variable
);
1613 current_buffer
->local_var_alist
1614 = Fcons (Fcons (variable
, XCDR (XBUFFER_LOCAL_VALUE (sym
->value
)->cdr
)),
1615 current_buffer
->local_var_alist
);
1617 /* Make sure symbol does not think it is set up for this buffer;
1618 force it to look once again for this buffer's value. */
1620 Lisp_Object
*pvalbuf
;
1622 valcontents
= sym
->value
;
1624 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1625 if (current_buffer
== XBUFFER (*pvalbuf
))
1627 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1631 /* If the symbol forwards into a C variable, then load the binding
1632 for this buffer now. If C code modifies the variable before we
1633 load the binding in, then that new value will clobber the default
1634 binding the next time we unload it. */
1635 valcontents
= XBUFFER_LOCAL_VALUE (sym
->value
)->realvalue
;
1636 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1637 swap_in_symval_forwarding (variable
, sym
->value
);
1642 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1643 1, 1, "vKill Local Variable: ",
1644 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1645 From now on the default value will apply in this buffer. Return VARIABLE. */)
1647 register Lisp_Object variable
;
1649 register Lisp_Object tem
, valcontents
;
1650 struct Lisp_Symbol
*sym
;
1652 CHECK_SYMBOL (variable
);
1653 sym
= indirect_variable (XSYMBOL (variable
));
1655 valcontents
= sym
->value
;
1657 if (BUFFER_OBJFWDP (valcontents
))
1659 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1660 int idx
= PER_BUFFER_IDX (offset
);
1664 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1665 PER_BUFFER_VALUE (current_buffer
, offset
)
1666 = PER_BUFFER_DEFAULT (offset
);
1671 if (!BUFFER_LOCAL_VALUEP (valcontents
))
1674 /* Get rid of this buffer's alist element, if any. */
1675 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1676 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1678 current_buffer
->local_var_alist
1679 = Fdelq (tem
, current_buffer
->local_var_alist
);
1681 /* If the symbol is set up with the current buffer's binding
1682 loaded, recompute its value. We have to do it now, or else
1683 forwarded objects won't work right. */
1685 Lisp_Object
*pvalbuf
, buf
;
1686 valcontents
= sym
->value
;
1687 pvalbuf
= &XBUFFER_LOCAL_VALUE (valcontents
)->buffer
;
1688 XSETBUFFER (buf
, current_buffer
);
1689 if (EQ (buf
, *pvalbuf
))
1692 XBUFFER_LOCAL_VALUE (valcontents
)->found_for_buffer
= 0;
1693 find_symbol_value (variable
);
1700 /* Lisp functions for creating and removing buffer-local variables. */
1702 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1703 when/if this is removed. */
1705 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1706 1, 1, "vMake Variable Frame Local: ",
1707 doc
: /* Enable VARIABLE to have frame-local bindings.
1708 This does not create any frame-local bindings for VARIABLE,
1709 it just makes them possible.
1711 A frame-local binding is actually a frame parameter value.
1712 If a frame F has a value for the frame parameter named VARIABLE,
1713 that also acts as a frame-local binding for VARIABLE in F--
1714 provided this function has been called to enable VARIABLE
1715 to have frame-local bindings at all.
1717 The only way to create a frame-local binding for VARIABLE in a frame
1718 is to set the VARIABLE frame parameter of that frame. See
1719 `modify-frame-parameters' for how to set frame parameters.
1721 Note that since Emacs 23.1, variables cannot be both buffer-local and
1722 frame-local any more (buffer-local bindings used to take precedence over
1723 frame-local bindings). */)
1725 register Lisp_Object variable
;
1727 register Lisp_Object tem
, valcontents
, newval
;
1728 struct Lisp_Symbol
*sym
;
1730 CHECK_SYMBOL (variable
);
1731 sym
= indirect_variable (XSYMBOL (variable
));
1733 valcontents
= sym
->value
;
1734 if (sym
->constant
|| KBOARD_OBJFWDP (valcontents
)
1735 || BUFFER_OBJFWDP (valcontents
))
1736 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1738 if (BUFFER_LOCAL_VALUEP (valcontents
))
1740 if (!XBUFFER_LOCAL_VALUE (valcontents
)->check_frame
)
1741 error ("Symbol %s may not be frame-local", SDATA (sym
->xname
));
1745 if (EQ (valcontents
, Qunbound
))
1747 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1749 newval
= allocate_misc ();
1750 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1751 XBUFFER_LOCAL_VALUE (newval
)->realvalue
= sym
->value
;
1752 XBUFFER_LOCAL_VALUE (newval
)->buffer
= Qnil
;
1753 XBUFFER_LOCAL_VALUE (newval
)->frame
= Qnil
;
1754 XBUFFER_LOCAL_VALUE (newval
)->local_if_set
= 0;
1755 XBUFFER_LOCAL_VALUE (newval
)->found_for_buffer
= 0;
1756 XBUFFER_LOCAL_VALUE (newval
)->found_for_frame
= 0;
1757 XBUFFER_LOCAL_VALUE (newval
)->check_frame
= 1;
1758 XBUFFER_LOCAL_VALUE (newval
)->cdr
= tem
;
1759 sym
->value
= newval
;
1763 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1765 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1766 BUFFER defaults to the current buffer. */)
1768 register Lisp_Object variable
, buffer
;
1770 Lisp_Object valcontents
;
1771 register struct buffer
*buf
;
1772 struct Lisp_Symbol
*sym
;
1775 buf
= current_buffer
;
1778 CHECK_BUFFER (buffer
);
1779 buf
= XBUFFER (buffer
);
1782 CHECK_SYMBOL (variable
);
1783 sym
= indirect_variable (XSYMBOL (variable
));
1784 XSETSYMBOL (variable
, sym
);
1786 valcontents
= sym
->value
;
1787 if (BUFFER_LOCAL_VALUEP (valcontents
))
1789 Lisp_Object tail
, elt
;
1791 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1794 if (EQ (variable
, XCAR (elt
)))
1798 if (BUFFER_OBJFWDP (valcontents
))
1800 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1801 int idx
= PER_BUFFER_IDX (offset
);
1802 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1808 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1810 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1811 More precisely, this means that setting the variable \(with `set' or`setq'),
1812 while it does not have a `let'-style binding that was made in BUFFER,
1813 will produce a buffer local binding. See Info node
1814 `(elisp)Creating Buffer-Local'.
1815 BUFFER defaults to the current buffer. */)
1817 register Lisp_Object variable
, buffer
;
1819 Lisp_Object valcontents
;
1820 register struct buffer
*buf
;
1821 struct Lisp_Symbol
*sym
;
1824 buf
= current_buffer
;
1827 CHECK_BUFFER (buffer
);
1828 buf
= XBUFFER (buffer
);
1831 CHECK_SYMBOL (variable
);
1832 sym
= indirect_variable (XSYMBOL (variable
));
1833 XSETSYMBOL (variable
, sym
);
1835 valcontents
= sym
->value
;
1837 if (BUFFER_OBJFWDP (valcontents
))
1838 /* All these slots become local if they are set. */
1840 else if (BUFFER_LOCAL_VALUEP (valcontents
))
1842 Lisp_Object tail
, elt
;
1843 if (XBUFFER_LOCAL_VALUE (valcontents
)->local_if_set
)
1845 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1848 if (EQ (variable
, XCAR (elt
)))
1855 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1857 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1858 If the current binding is buffer-local, the value is the current buffer.
1859 If the current binding is frame-local, the value is the selected frame.
1860 If the current binding is global (the default), the value is nil. */)
1862 register Lisp_Object variable
;
1864 Lisp_Object valcontents
;
1865 struct Lisp_Symbol
*sym
;
1867 CHECK_SYMBOL (variable
);
1868 sym
= indirect_variable (XSYMBOL (variable
));
1870 /* Make sure the current binding is actually swapped in. */
1871 find_symbol_value (variable
);
1873 valcontents
= sym
->value
;
1875 if (BUFFER_LOCAL_VALUEP (valcontents
)
1876 || BUFFER_OBJFWDP (valcontents
))
1878 /* For a local variable, record both the symbol and which
1879 buffer's or frame's value we are saving. */
1880 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1881 return Fcurrent_buffer ();
1882 else if (BUFFER_LOCAL_VALUEP (valcontents
)
1883 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
1884 return XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
1890 /* This code is disabled now that we use the selected frame to return
1891 keyboard-local-values. */
1893 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
1895 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1896 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1897 If SYMBOL is not a terminal-local variable, then return its normal
1898 value, like `symbol-value'.
1900 TERMINAL may be a terminal object, a frame, or nil (meaning the
1901 selected frame's terminal device). */)
1904 Lisp_Object terminal
;
1907 struct terminal
*t
= get_terminal (terminal
, 1);
1908 push_kboard (t
->kboard
);
1909 result
= Fsymbol_value (symbol
);
1914 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1915 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1916 If VARIABLE is not a terminal-local variable, then set its normal
1917 binding, like `set'.
1919 TERMINAL may be a terminal object, a frame, or nil (meaning the
1920 selected frame's terminal device). */)
1921 (symbol
, terminal
, value
)
1923 Lisp_Object terminal
;
1927 struct terminal
*t
= get_terminal (terminal
, 1);
1928 push_kboard (d
->kboard
);
1929 result
= Fset (symbol
, value
);
1935 /* Find the function at the end of a chain of symbol function indirections. */
1937 /* If OBJECT is a symbol, find the end of its function chain and
1938 return the value found there. If OBJECT is not a symbol, just
1939 return it. If there is a cycle in the function chain, signal a
1940 cyclic-function-indirection error.
1942 This is like Findirect_function, except that it doesn't signal an
1943 error if the chain ends up unbound. */
1945 indirect_function (object
)
1946 register Lisp_Object object
;
1948 Lisp_Object tortoise
, hare
;
1950 hare
= tortoise
= object
;
1954 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1956 hare
= XSYMBOL (hare
)->function
;
1957 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1959 hare
= XSYMBOL (hare
)->function
;
1961 tortoise
= XSYMBOL (tortoise
)->function
;
1963 if (EQ (hare
, tortoise
))
1964 xsignal1 (Qcyclic_function_indirection
, object
);
1970 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
1971 doc
: /* Return the function at the end of OBJECT's function chain.
1972 If OBJECT is not a symbol, just return it. Otherwise, follow all
1973 function indirections to find the final function binding and return it.
1974 If the final symbol in the chain is unbound, signal a void-function error.
1975 Optional arg NOERROR non-nil means to return nil instead of signalling.
1976 Signal a cyclic-function-indirection error if there is a loop in the
1977 function chain of symbols. */)
1979 register Lisp_Object object
;
1980 Lisp_Object noerror
;
1984 /* Optimize for no indirection. */
1986 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
1987 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
1988 result
= indirect_function (result
);
1989 if (!EQ (result
, Qunbound
))
1993 xsignal1 (Qvoid_function
, object
);
1998 /* Extract and set vector and string elements */
2000 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2001 doc
: /* Return the element of ARRAY at index IDX.
2002 ARRAY may be a vector, a string, a char-table, a bool-vector,
2003 or a byte-code object. IDX starts at 0. */)
2005 register Lisp_Object array
;
2008 register int idxval
;
2011 idxval
= XINT (idx
);
2012 if (STRINGP (array
))
2016 if (idxval
< 0 || idxval
>= SCHARS (array
))
2017 args_out_of_range (array
, idx
);
2018 if (! STRING_MULTIBYTE (array
))
2019 return make_number ((unsigned char) SREF (array
, idxval
));
2020 idxval_byte
= string_char_to_byte (array
, idxval
);
2022 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2023 return make_number (c
);
2025 else if (BOOL_VECTOR_P (array
))
2029 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2030 args_out_of_range (array
, idx
);
2032 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2033 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2035 else if (CHAR_TABLE_P (array
))
2037 CHECK_CHARACTER (idx
);
2038 return CHAR_TABLE_REF (array
, idxval
);
2043 if (VECTORP (array
))
2044 size
= XVECTOR (array
)->size
;
2045 else if (COMPILEDP (array
))
2046 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2048 wrong_type_argument (Qarrayp
, array
);
2050 if (idxval
< 0 || idxval
>= size
)
2051 args_out_of_range (array
, idx
);
2052 return XVECTOR (array
)->contents
[idxval
];
2056 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2057 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2058 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2059 bool-vector. IDX starts at 0. */)
2060 (array
, idx
, newelt
)
2061 register Lisp_Object array
;
2062 Lisp_Object idx
, newelt
;
2064 register int idxval
;
2067 idxval
= XINT (idx
);
2068 CHECK_ARRAY (array
, Qarrayp
);
2069 CHECK_IMPURE (array
);
2071 if (VECTORP (array
))
2073 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2074 args_out_of_range (array
, idx
);
2075 XVECTOR (array
)->contents
[idxval
] = newelt
;
2077 else if (BOOL_VECTOR_P (array
))
2081 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2082 args_out_of_range (array
, idx
);
2084 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2086 if (! NILP (newelt
))
2087 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2089 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2090 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2092 else if (CHAR_TABLE_P (array
))
2094 CHECK_CHARACTER (idx
);
2095 CHAR_TABLE_SET (array
, idxval
, newelt
);
2097 else if (STRING_MULTIBYTE (array
))
2099 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2100 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2102 if (idxval
< 0 || idxval
>= SCHARS (array
))
2103 args_out_of_range (array
, idx
);
2104 CHECK_CHARACTER (newelt
);
2106 nbytes
= SBYTES (array
);
2108 idxval_byte
= string_char_to_byte (array
, idxval
);
2109 p1
= SDATA (array
) + idxval_byte
;
2110 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2111 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2112 if (prev_bytes
!= new_bytes
)
2114 /* We must relocate the string data. */
2115 int nchars
= SCHARS (array
);
2119 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2120 bcopy (SDATA (array
), str
, nbytes
);
2121 allocate_string_data (XSTRING (array
), nchars
,
2122 nbytes
+ new_bytes
- prev_bytes
);
2123 bcopy (str
, SDATA (array
), idxval_byte
);
2124 p1
= SDATA (array
) + idxval_byte
;
2125 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2126 nbytes
- (idxval_byte
+ prev_bytes
));
2128 clear_string_char_byte_cache ();
2135 if (idxval
< 0 || idxval
>= SCHARS (array
))
2136 args_out_of_range (array
, idx
);
2137 CHECK_NUMBER (newelt
);
2139 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2143 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2144 if (SREF (array
, i
) >= 0x80)
2145 args_out_of_range (array
, newelt
);
2146 /* ARRAY is an ASCII string. Convert it to a multibyte
2147 string, and try `aset' again. */
2148 STRING_SET_MULTIBYTE (array
);
2149 return Faset (array
, idx
, newelt
);
2151 SSET (array
, idxval
, XINT (newelt
));
2157 /* Arithmetic functions */
2159 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2162 arithcompare (num1
, num2
, comparison
)
2163 Lisp_Object num1
, num2
;
2164 enum comparison comparison
;
2166 double f1
= 0, f2
= 0;
2169 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2170 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2172 if (FLOATP (num1
) || FLOATP (num2
))
2175 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2176 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2182 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2187 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2192 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2197 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2202 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2207 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2216 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2217 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2219 register Lisp_Object num1
, num2
;
2221 return arithcompare (num1
, num2
, equal
);
2224 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2225 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2227 register Lisp_Object num1
, num2
;
2229 return arithcompare (num1
, num2
, less
);
2232 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2233 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2235 register Lisp_Object num1
, num2
;
2237 return arithcompare (num1
, num2
, grtr
);
2240 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2241 doc
: /* Return t if first arg is less than or equal to second arg.
2242 Both must be numbers or markers. */)
2244 register Lisp_Object num1
, num2
;
2246 return arithcompare (num1
, num2
, less_or_equal
);
2249 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2250 doc
: /* Return t if first arg is greater than or equal to second arg.
2251 Both must be numbers or markers. */)
2253 register Lisp_Object num1
, num2
;
2255 return arithcompare (num1
, num2
, grtr_or_equal
);
2258 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2259 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2261 register Lisp_Object num1
, num2
;
2263 return arithcompare (num1
, num2
, notequal
);
2266 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2267 doc
: /* Return t if NUMBER is zero. */)
2269 register Lisp_Object number
;
2271 CHECK_NUMBER_OR_FLOAT (number
);
2273 if (FLOATP (number
))
2275 if (XFLOAT_DATA (number
) == 0.0)
2285 /* Convert between long values and pairs of Lisp integers.
2286 Note that long_to_cons returns a single Lisp integer
2287 when the value fits in one. */
2293 unsigned long top
= i
>> 16;
2294 unsigned int bot
= i
& 0xFFFF;
2296 return make_number (bot
);
2297 if (top
== (unsigned long)-1 >> 16)
2298 return Fcons (make_number (-1), make_number (bot
));
2299 return Fcons (make_number (top
), make_number (bot
));
2306 Lisp_Object top
, bot
;
2313 return ((XINT (top
) << 16) | XINT (bot
));
2316 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2317 doc
: /* Return the decimal representation of NUMBER as a string.
2318 Uses a minus sign if negative.
2319 NUMBER may be an integer or a floating point number. */)
2323 char buffer
[VALBITS
];
2325 CHECK_NUMBER_OR_FLOAT (number
);
2327 if (FLOATP (number
))
2329 char pigbuf
[350]; /* see comments in float_to_string */
2331 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2332 return build_string (pigbuf
);
2335 if (sizeof (int) == sizeof (EMACS_INT
))
2336 sprintf (buffer
, "%d", (int) XINT (number
));
2337 else if (sizeof (long) == sizeof (EMACS_INT
))
2338 sprintf (buffer
, "%ld", (long) XINT (number
));
2341 return build_string (buffer
);
2345 digit_to_number (character
, base
)
2346 int character
, base
;
2350 if (character
>= '0' && character
<= '9')
2351 digit
= character
- '0';
2352 else if (character
>= 'a' && character
<= 'z')
2353 digit
= character
- 'a' + 10;
2354 else if (character
>= 'A' && character
<= 'Z')
2355 digit
= character
- 'A' + 10;
2365 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2366 doc
: /* Parse STRING as a decimal number and return the number.
2367 This parses both integers and floating point numbers.
2368 It ignores leading spaces and tabs, and all trailing chars.
2370 If BASE, interpret STRING as a number in that base. If BASE isn't
2371 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2372 If the base used is not 10, STRING is always parsed as integer. */)
2374 register Lisp_Object string
, base
;
2376 register unsigned char *p
;
2381 CHECK_STRING (string
);
2387 CHECK_NUMBER (base
);
2389 if (b
< 2 || b
> 16)
2390 xsignal1 (Qargs_out_of_range
, base
);
2393 /* Skip any whitespace at the front of the number. Some versions of
2394 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2396 while (*p
== ' ' || *p
== '\t')
2407 if (isfloat_string (p
, 1) && b
== 10)
2408 val
= make_float (sign
* atof (p
));
2415 int digit
= digit_to_number (*p
++, b
);
2421 val
= make_fixnum_or_float (sign
* v
);
2441 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2442 int, Lisp_Object
*));
2443 extern Lisp_Object
fmod_float ();
2446 arith_driver (code
, nargs
, args
)
2449 register Lisp_Object
*args
;
2451 register Lisp_Object val
;
2452 register int argnum
;
2453 register EMACS_INT accum
= 0;
2454 register EMACS_INT next
;
2456 switch (SWITCH_ENUM_CAST (code
))
2474 for (argnum
= 0; argnum
< nargs
; argnum
++)
2476 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2478 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2481 return float_arith_driver ((double) accum
, argnum
, code
,
2484 next
= XINT (args
[argnum
]);
2485 switch (SWITCH_ENUM_CAST (code
))
2491 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2502 xsignal0 (Qarith_error
);
2516 if (!argnum
|| next
> accum
)
2520 if (!argnum
|| next
< accum
)
2526 XSETINT (val
, accum
);
2531 #define isnan(x) ((x) != (x))
2534 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2536 register int argnum
;
2539 register Lisp_Object
*args
;
2541 register Lisp_Object val
;
2544 for (; argnum
< nargs
; argnum
++)
2546 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2547 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2551 next
= XFLOAT_DATA (val
);
2555 args
[argnum
] = val
; /* runs into a compiler bug. */
2556 next
= XINT (args
[argnum
]);
2558 switch (SWITCH_ENUM_CAST (code
))
2564 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2574 if (! IEEE_FLOATING_POINT
&& next
== 0)
2575 xsignal0 (Qarith_error
);
2582 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2584 if (!argnum
|| isnan (next
) || next
> accum
)
2588 if (!argnum
|| isnan (next
) || next
< accum
)
2594 return make_float (accum
);
2598 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2599 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2600 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2605 return arith_driver (Aadd
, nargs
, args
);
2608 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2609 doc
: /* Negate number or subtract numbers or markers and return the result.
2610 With one arg, negates it. With more than one arg,
2611 subtracts all but the first from the first.
2612 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2617 return arith_driver (Asub
, nargs
, args
);
2620 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2621 doc
: /* Return product of any number of arguments, which are numbers or markers.
2622 usage: (* &rest NUMBERS-OR-MARKERS) */)
2627 return arith_driver (Amult
, nargs
, args
);
2630 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2631 doc
: /* Return first argument divided by all the remaining arguments.
2632 The arguments must be numbers or markers.
2633 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2639 for (argnum
= 2; argnum
< nargs
; argnum
++)
2640 if (FLOATP (args
[argnum
]))
2641 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2642 return arith_driver (Adiv
, nargs
, args
);
2645 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2646 doc
: /* Return remainder of X divided by Y.
2647 Both must be integers or markers. */)
2649 register Lisp_Object x
, y
;
2653 CHECK_NUMBER_COERCE_MARKER (x
);
2654 CHECK_NUMBER_COERCE_MARKER (y
);
2656 if (XFASTINT (y
) == 0)
2657 xsignal0 (Qarith_error
);
2659 XSETINT (val
, XINT (x
) % XINT (y
));
2673 /* If the magnitude of the result exceeds that of the divisor, or
2674 the sign of the result does not agree with that of the dividend,
2675 iterate with the reduced value. This does not yield a
2676 particularly accurate result, but at least it will be in the
2677 range promised by fmod. */
2679 r
-= f2
* floor (r
/ f2
);
2680 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2684 #endif /* ! HAVE_FMOD */
2686 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2687 doc
: /* Return X modulo Y.
2688 The result falls between zero (inclusive) and Y (exclusive).
2689 Both X and Y must be numbers or markers. */)
2691 register Lisp_Object x
, y
;
2696 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2697 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2699 if (FLOATP (x
) || FLOATP (y
))
2700 return fmod_float (x
, y
);
2706 xsignal0 (Qarith_error
);
2710 /* If the "remainder" comes out with the wrong sign, fix it. */
2711 if (i2
< 0 ? i1
> 0 : i1
< 0)
2718 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2719 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2720 The value is always a number; markers are converted to numbers.
2721 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2726 return arith_driver (Amax
, nargs
, args
);
2729 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2730 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2731 The value is always a number; markers are converted to numbers.
2732 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2737 return arith_driver (Amin
, nargs
, args
);
2740 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2741 doc
: /* Return bitwise-and of all the arguments.
2742 Arguments may be integers, or markers converted to integers.
2743 usage: (logand &rest INTS-OR-MARKERS) */)
2748 return arith_driver (Alogand
, nargs
, args
);
2751 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2752 doc
: /* Return bitwise-or of all the arguments.
2753 Arguments may be integers, or markers converted to integers.
2754 usage: (logior &rest INTS-OR-MARKERS) */)
2759 return arith_driver (Alogior
, nargs
, args
);
2762 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2763 doc
: /* Return bitwise-exclusive-or of all the arguments.
2764 Arguments may be integers, or markers converted to integers.
2765 usage: (logxor &rest INTS-OR-MARKERS) */)
2770 return arith_driver (Alogxor
, nargs
, args
);
2773 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2774 doc
: /* Return VALUE with its bits shifted left by COUNT.
2775 If COUNT is negative, shifting is actually to the right.
2776 In this case, the sign bit is duplicated. */)
2778 register Lisp_Object value
, count
;
2780 register Lisp_Object val
;
2782 CHECK_NUMBER (value
);
2783 CHECK_NUMBER (count
);
2785 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2787 else if (XINT (count
) > 0)
2788 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2789 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2790 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2792 XSETINT (val
, XINT (value
) >> -XINT (count
));
2796 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2797 doc
: /* Return VALUE with its bits shifted left by COUNT.
2798 If COUNT is negative, shifting is actually to the right.
2799 In this case, zeros are shifted in on the left. */)
2801 register Lisp_Object value
, count
;
2803 register Lisp_Object val
;
2805 CHECK_NUMBER (value
);
2806 CHECK_NUMBER (count
);
2808 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2810 else if (XINT (count
) > 0)
2811 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2812 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2815 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2819 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2820 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2821 Markers are converted to integers. */)
2823 register Lisp_Object number
;
2825 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2827 if (FLOATP (number
))
2828 return (make_float (1.0 + XFLOAT_DATA (number
)));
2830 XSETINT (number
, XINT (number
) + 1);
2834 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2835 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2836 Markers are converted to integers. */)
2838 register Lisp_Object number
;
2840 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2842 if (FLOATP (number
))
2843 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2845 XSETINT (number
, XINT (number
) - 1);
2849 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2850 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2852 register Lisp_Object number
;
2854 CHECK_NUMBER (number
);
2855 XSETINT (number
, ~XINT (number
));
2859 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2860 doc
: /* Return the byteorder for the machine.
2861 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2862 lowercase l) for small endian machines. */)
2865 unsigned i
= 0x04030201;
2866 int order
= *(char *)&i
== 1 ? 108 : 66;
2868 return make_number (order
);
2876 Lisp_Object error_tail
, arith_tail
;
2878 Qquote
= intern_c_string ("quote");
2879 Qlambda
= intern_c_string ("lambda");
2880 Qsubr
= intern_c_string ("subr");
2881 Qerror_conditions
= intern_c_string ("error-conditions");
2882 Qerror_message
= intern_c_string ("error-message");
2883 Qtop_level
= intern_c_string ("top-level");
2885 Qerror
= intern_c_string ("error");
2886 Qquit
= intern_c_string ("quit");
2887 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2888 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2889 Qvoid_function
= intern_c_string ("void-function");
2890 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2891 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2892 Qvoid_variable
= intern_c_string ("void-variable");
2893 Qsetting_constant
= intern_c_string ("setting-constant");
2894 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2896 Qinvalid_function
= intern_c_string ("invalid-function");
2897 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2898 Qno_catch
= intern_c_string ("no-catch");
2899 Qend_of_file
= intern_c_string ("end-of-file");
2900 Qarith_error
= intern_c_string ("arith-error");
2901 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2902 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2903 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2904 Qtext_read_only
= intern_c_string ("text-read-only");
2905 Qmark_inactive
= intern_c_string ("mark-inactive");
2907 Qlistp
= intern_c_string ("listp");
2908 Qconsp
= intern_c_string ("consp");
2909 Qsymbolp
= intern_c_string ("symbolp");
2910 Qkeywordp
= intern_c_string ("keywordp");
2911 Qintegerp
= intern_c_string ("integerp");
2912 Qnatnump
= intern_c_string ("natnump");
2913 Qwholenump
= intern_c_string ("wholenump");
2914 Qstringp
= intern_c_string ("stringp");
2915 Qarrayp
= intern_c_string ("arrayp");
2916 Qsequencep
= intern_c_string ("sequencep");
2917 Qbufferp
= intern_c_string ("bufferp");
2918 Qvectorp
= intern_c_string ("vectorp");
2919 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2920 Qmarkerp
= intern_c_string ("markerp");
2921 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2922 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2923 Qboundp
= intern_c_string ("boundp");
2924 Qfboundp
= intern_c_string ("fboundp");
2926 Qfloatp
= intern_c_string ("floatp");
2927 Qnumberp
= intern_c_string ("numberp");
2928 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2930 Qchar_table_p
= intern_c_string ("char-table-p");
2931 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2933 Qsubrp
= intern_c_string ("subrp");
2934 Qunevalled
= intern_c_string ("unevalled");
2935 Qmany
= intern_c_string ("many");
2937 Qcdr
= intern_c_string ("cdr");
2939 /* Handle automatic advice activation */
2940 Qad_advice_info
= intern_c_string ("ad-advice-info");
2941 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2943 error_tail
= pure_cons (Qerror
, Qnil
);
2945 /* ERROR is used as a signaler for random errors for which nothing else is right */
2947 Fput (Qerror
, Qerror_conditions
,
2949 Fput (Qerror
, Qerror_message
,
2950 make_pure_c_string ("error"));
2952 Fput (Qquit
, Qerror_conditions
,
2953 pure_cons (Qquit
, Qnil
));
2954 Fput (Qquit
, Qerror_message
,
2955 make_pure_c_string ("Quit"));
2957 Fput (Qwrong_type_argument
, Qerror_conditions
,
2958 pure_cons (Qwrong_type_argument
, error_tail
));
2959 Fput (Qwrong_type_argument
, Qerror_message
,
2960 make_pure_c_string ("Wrong type argument"));
2962 Fput (Qargs_out_of_range
, Qerror_conditions
,
2963 pure_cons (Qargs_out_of_range
, error_tail
));
2964 Fput (Qargs_out_of_range
, Qerror_message
,
2965 make_pure_c_string ("Args out of range"));
2967 Fput (Qvoid_function
, Qerror_conditions
,
2968 pure_cons (Qvoid_function
, error_tail
));
2969 Fput (Qvoid_function
, Qerror_message
,
2970 make_pure_c_string ("Symbol's function definition is void"));
2972 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2973 pure_cons (Qcyclic_function_indirection
, error_tail
));
2974 Fput (Qcyclic_function_indirection
, Qerror_message
,
2975 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2977 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2978 pure_cons (Qcyclic_variable_indirection
, error_tail
));
2979 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2980 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
2982 Qcircular_list
= intern_c_string ("circular-list");
2983 staticpro (&Qcircular_list
);
2984 Fput (Qcircular_list
, Qerror_conditions
,
2985 pure_cons (Qcircular_list
, error_tail
));
2986 Fput (Qcircular_list
, Qerror_message
,
2987 make_pure_c_string ("List contains a loop"));
2989 Fput (Qvoid_variable
, Qerror_conditions
,
2990 pure_cons (Qvoid_variable
, error_tail
));
2991 Fput (Qvoid_variable
, Qerror_message
,
2992 make_pure_c_string ("Symbol's value as variable is void"));
2994 Fput (Qsetting_constant
, Qerror_conditions
,
2995 pure_cons (Qsetting_constant
, error_tail
));
2996 Fput (Qsetting_constant
, Qerror_message
,
2997 make_pure_c_string ("Attempt to set a constant symbol"));
2999 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3000 pure_cons (Qinvalid_read_syntax
, error_tail
));
3001 Fput (Qinvalid_read_syntax
, Qerror_message
,
3002 make_pure_c_string ("Invalid read syntax"));
3004 Fput (Qinvalid_function
, Qerror_conditions
,
3005 pure_cons (Qinvalid_function
, error_tail
));
3006 Fput (Qinvalid_function
, Qerror_message
,
3007 make_pure_c_string ("Invalid function"));
3009 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3010 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3011 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3012 make_pure_c_string ("Wrong number of arguments"));
3014 Fput (Qno_catch
, Qerror_conditions
,
3015 pure_cons (Qno_catch
, error_tail
));
3016 Fput (Qno_catch
, Qerror_message
,
3017 make_pure_c_string ("No catch for tag"));
3019 Fput (Qend_of_file
, Qerror_conditions
,
3020 pure_cons (Qend_of_file
, error_tail
));
3021 Fput (Qend_of_file
, Qerror_message
,
3022 make_pure_c_string ("End of file during parsing"));
3024 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3025 Fput (Qarith_error
, Qerror_conditions
,
3027 Fput (Qarith_error
, Qerror_message
,
3028 make_pure_c_string ("Arithmetic error"));
3030 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3031 pure_cons (Qbeginning_of_buffer
, error_tail
));
3032 Fput (Qbeginning_of_buffer
, Qerror_message
,
3033 make_pure_c_string ("Beginning of buffer"));
3035 Fput (Qend_of_buffer
, Qerror_conditions
,
3036 pure_cons (Qend_of_buffer
, error_tail
));
3037 Fput (Qend_of_buffer
, Qerror_message
,
3038 make_pure_c_string ("End of buffer"));
3040 Fput (Qbuffer_read_only
, Qerror_conditions
,
3041 pure_cons (Qbuffer_read_only
, error_tail
));
3042 Fput (Qbuffer_read_only
, Qerror_message
,
3043 make_pure_c_string ("Buffer is read-only"));
3045 Fput (Qtext_read_only
, Qerror_conditions
,
3046 pure_cons (Qtext_read_only
, error_tail
));
3047 Fput (Qtext_read_only
, Qerror_message
,
3048 make_pure_c_string ("Text is read-only"));
3050 Qrange_error
= intern_c_string ("range-error");
3051 Qdomain_error
= intern_c_string ("domain-error");
3052 Qsingularity_error
= intern_c_string ("singularity-error");
3053 Qoverflow_error
= intern_c_string ("overflow-error");
3054 Qunderflow_error
= intern_c_string ("underflow-error");
3056 Fput (Qdomain_error
, Qerror_conditions
,
3057 pure_cons (Qdomain_error
, arith_tail
));
3058 Fput (Qdomain_error
, Qerror_message
,
3059 make_pure_c_string ("Arithmetic domain error"));
3061 Fput (Qrange_error
, Qerror_conditions
,
3062 pure_cons (Qrange_error
, arith_tail
));
3063 Fput (Qrange_error
, Qerror_message
,
3064 make_pure_c_string ("Arithmetic range error"));
3066 Fput (Qsingularity_error
, Qerror_conditions
,
3067 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3068 Fput (Qsingularity_error
, Qerror_message
,
3069 make_pure_c_string ("Arithmetic singularity error"));
3071 Fput (Qoverflow_error
, Qerror_conditions
,
3072 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3073 Fput (Qoverflow_error
, Qerror_message
,
3074 make_pure_c_string ("Arithmetic overflow error"));
3076 Fput (Qunderflow_error
, Qerror_conditions
,
3077 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3078 Fput (Qunderflow_error
, Qerror_message
,
3079 make_pure_c_string ("Arithmetic underflow error"));
3081 staticpro (&Qrange_error
);
3082 staticpro (&Qdomain_error
);
3083 staticpro (&Qsingularity_error
);
3084 staticpro (&Qoverflow_error
);
3085 staticpro (&Qunderflow_error
);
3089 staticpro (&Qquote
);
3090 staticpro (&Qlambda
);
3092 staticpro (&Qunbound
);
3093 staticpro (&Qerror_conditions
);
3094 staticpro (&Qerror_message
);
3095 staticpro (&Qtop_level
);
3097 staticpro (&Qerror
);
3099 staticpro (&Qwrong_type_argument
);
3100 staticpro (&Qargs_out_of_range
);
3101 staticpro (&Qvoid_function
);
3102 staticpro (&Qcyclic_function_indirection
);
3103 staticpro (&Qcyclic_variable_indirection
);
3104 staticpro (&Qvoid_variable
);
3105 staticpro (&Qsetting_constant
);
3106 staticpro (&Qinvalid_read_syntax
);
3107 staticpro (&Qwrong_number_of_arguments
);
3108 staticpro (&Qinvalid_function
);
3109 staticpro (&Qno_catch
);
3110 staticpro (&Qend_of_file
);
3111 staticpro (&Qarith_error
);
3112 staticpro (&Qbeginning_of_buffer
);
3113 staticpro (&Qend_of_buffer
);
3114 staticpro (&Qbuffer_read_only
);
3115 staticpro (&Qtext_read_only
);
3116 staticpro (&Qmark_inactive
);
3118 staticpro (&Qlistp
);
3119 staticpro (&Qconsp
);
3120 staticpro (&Qsymbolp
);
3121 staticpro (&Qkeywordp
);
3122 staticpro (&Qintegerp
);
3123 staticpro (&Qnatnump
);
3124 staticpro (&Qwholenump
);
3125 staticpro (&Qstringp
);
3126 staticpro (&Qarrayp
);
3127 staticpro (&Qsequencep
);
3128 staticpro (&Qbufferp
);
3129 staticpro (&Qvectorp
);
3130 staticpro (&Qchar_or_string_p
);
3131 staticpro (&Qmarkerp
);
3132 staticpro (&Qbuffer_or_string_p
);
3133 staticpro (&Qinteger_or_marker_p
);
3134 staticpro (&Qfloatp
);
3135 staticpro (&Qnumberp
);
3136 staticpro (&Qnumber_or_marker_p
);
3137 staticpro (&Qchar_table_p
);
3138 staticpro (&Qvector_or_char_table_p
);
3139 staticpro (&Qsubrp
);
3141 staticpro (&Qunevalled
);
3143 staticpro (&Qboundp
);
3144 staticpro (&Qfboundp
);
3146 staticpro (&Qad_advice_info
);
3147 staticpro (&Qad_activate_internal
);
3149 /* Types that type-of returns. */
3150 Qinteger
= intern_c_string ("integer");
3151 Qsymbol
= intern_c_string ("symbol");
3152 Qstring
= intern_c_string ("string");
3153 Qcons
= intern_c_string ("cons");
3154 Qmarker
= intern_c_string ("marker");
3155 Qoverlay
= intern_c_string ("overlay");
3156 Qfloat
= intern_c_string ("float");
3157 Qwindow_configuration
= intern_c_string ("window-configuration");
3158 Qprocess
= intern_c_string ("process");
3159 Qwindow
= intern_c_string ("window");
3160 /* Qsubr = intern_c_string ("subr"); */
3161 Qcompiled_function
= intern_c_string ("compiled-function");
3162 Qbuffer
= intern_c_string ("buffer");
3163 Qframe
= intern_c_string ("frame");
3164 Qvector
= intern_c_string ("vector");
3165 Qchar_table
= intern_c_string ("char-table");
3166 Qbool_vector
= intern_c_string ("bool-vector");
3167 Qhash_table
= intern_c_string ("hash-table");
3169 DEFSYM (Qfont_spec
, "font-spec");
3170 DEFSYM (Qfont_entity
, "font-entity");
3171 DEFSYM (Qfont_object
, "font-object");
3173 DEFSYM (Qinteractive_form
, "interactive-form");
3175 staticpro (&Qinteger
);
3176 staticpro (&Qsymbol
);
3177 staticpro (&Qstring
);
3179 staticpro (&Qmarker
);
3180 staticpro (&Qoverlay
);
3181 staticpro (&Qfloat
);
3182 staticpro (&Qwindow_configuration
);
3183 staticpro (&Qprocess
);
3184 staticpro (&Qwindow
);
3185 /* staticpro (&Qsubr); */
3186 staticpro (&Qcompiled_function
);
3187 staticpro (&Qbuffer
);
3188 staticpro (&Qframe
);
3189 staticpro (&Qvector
);
3190 staticpro (&Qchar_table
);
3191 staticpro (&Qbool_vector
);
3192 staticpro (&Qhash_table
);
3194 defsubr (&Sindirect_variable
);
3195 defsubr (&Sinteractive_form
);
3198 defsubr (&Stype_of
);
3203 defsubr (&Sintegerp
);
3204 defsubr (&Sinteger_or_marker_p
);
3205 defsubr (&Snumberp
);
3206 defsubr (&Snumber_or_marker_p
);
3208 defsubr (&Snatnump
);
3209 defsubr (&Ssymbolp
);
3210 defsubr (&Skeywordp
);
3211 defsubr (&Sstringp
);
3212 defsubr (&Smultibyte_string_p
);
3213 defsubr (&Svectorp
);
3214 defsubr (&Schar_table_p
);
3215 defsubr (&Svector_or_char_table_p
);
3216 defsubr (&Sbool_vector_p
);
3218 defsubr (&Ssequencep
);
3219 defsubr (&Sbufferp
);
3220 defsubr (&Smarkerp
);
3222 defsubr (&Sbyte_code_function_p
);
3223 defsubr (&Schar_or_string_p
);
3226 defsubr (&Scar_safe
);
3227 defsubr (&Scdr_safe
);
3230 defsubr (&Ssymbol_function
);
3231 defsubr (&Sindirect_function
);
3232 defsubr (&Ssymbol_plist
);
3233 defsubr (&Ssymbol_name
);
3234 defsubr (&Smakunbound
);
3235 defsubr (&Sfmakunbound
);
3237 defsubr (&Sfboundp
);
3239 defsubr (&Sdefalias
);
3240 defsubr (&Ssetplist
);
3241 defsubr (&Ssymbol_value
);
3243 defsubr (&Sdefault_boundp
);
3244 defsubr (&Sdefault_value
);
3245 defsubr (&Sset_default
);
3246 defsubr (&Ssetq_default
);
3247 defsubr (&Smake_variable_buffer_local
);
3248 defsubr (&Smake_local_variable
);
3249 defsubr (&Skill_local_variable
);
3250 defsubr (&Smake_variable_frame_local
);
3251 defsubr (&Slocal_variable_p
);
3252 defsubr (&Slocal_variable_if_set_p
);
3253 defsubr (&Svariable_binding_locus
);
3254 #if 0 /* XXX Remove this. --lorentey */
3255 defsubr (&Sterminal_local_value
);
3256 defsubr (&Sset_terminal_local_value
);
3260 defsubr (&Snumber_to_string
);
3261 defsubr (&Sstring_to_number
);
3262 defsubr (&Seqlsign
);
3285 defsubr (&Sbyteorder
);
3286 defsubr (&Ssubr_arity
);
3287 defsubr (&Ssubr_name
);
3289 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3291 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3292 doc
: /* The largest value that is representable in a Lisp integer. */);
3293 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3294 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3296 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3297 doc
: /* The smallest value that is representable in a Lisp integer. */);
3298 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3299 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3306 sigsetmask (SIGEMPTYMASK
);
3308 SIGNAL_THREAD_CHECK (signo
);
3309 xsignal0 (Qarith_error
);
3315 /* Don't do this if just dumping out.
3316 We don't want to call `signal' in this case
3317 so that we don't have trouble with dumping
3318 signal-delivering routines in an inconsistent state. */
3322 #endif /* CANNOT_DUMP */
3323 signal (SIGFPE
, arith_error
);
3326 signal (SIGEMT
, arith_error
);
3330 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3331 (do not change this comment) */