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 void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
96 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
100 circular_list_error (list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (predicate
, value
)
109 register Lisp_Object predicate
, value
;
111 /* If VALUE is not even a valid Lisp object, we'd want to abort here
112 where we can get a backtrace showing where it came from. We used
113 to try and do that by checking the tagbits, but nowadays all
114 tagbits are potentially valid. */
115 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
118 xsignal2 (Qwrong_type_argument
, predicate
, value
);
124 error ("Attempt to modify read-only object");
128 args_out_of_range (a1
, a2
)
131 xsignal2 (Qargs_out_of_range
, a1
, a2
);
135 args_out_of_range_3 (a1
, a2
, a3
)
136 Lisp_Object a1
, a2
, a3
;
138 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
141 /* On some machines, XINT needs a temporary location.
142 Here it is, in case it is needed. */
144 int sign_extend_temp
;
146 /* On a few machines, XINT can only be done by calling this. */
149 sign_extend_lisp_int (num
)
152 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
153 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
155 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
158 /* Data type predicates */
160 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
161 doc
: /* Return t if the two args are the same Lisp object. */)
163 Lisp_Object obj1
, obj2
;
170 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
171 doc
: /* Return t if OBJECT is nil. */)
180 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
181 doc
: /* Return a symbol representing the type of OBJECT.
182 The symbol returned names the object's basic type;
183 for example, (type-of 1) returns `integer'. */)
187 switch (XTYPE (object
))
202 switch (XMISCTYPE (object
))
204 case Lisp_Misc_Marker
:
206 case Lisp_Misc_Overlay
:
208 case Lisp_Misc_Float
:
213 case Lisp_Vectorlike
:
214 if (WINDOW_CONFIGURATIONP (object
))
215 return Qwindow_configuration
;
216 if (PROCESSP (object
))
218 if (WINDOWP (object
))
222 if (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 struct Lisp_Symbol
*sym
;
586 CHECK_SYMBOL (symbol
);
587 sym
= XSYMBOL (symbol
);
590 switch (sym
->redirect
)
592 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
593 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
594 case SYMBOL_LOCALIZED
:
596 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
598 /* In set_internal, we un-forward vars when their value is
603 swap_in_symval_forwarding (sym
, blv
);
604 valcontents
= BLV_VALUE (blv
);
608 case SYMBOL_FORWARDED
:
609 /* In set_internal, we un-forward vars when their value is
615 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
618 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
619 doc
: /* Return t if SYMBOL's function definition is not void. */)
621 register Lisp_Object symbol
;
623 CHECK_SYMBOL (symbol
);
624 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
627 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
628 doc
: /* Make SYMBOL's value be void.
631 register Lisp_Object symbol
;
633 CHECK_SYMBOL (symbol
);
634 if (SYMBOL_CONSTANT_P (symbol
))
635 xsignal1 (Qsetting_constant
, symbol
);
636 Fset (symbol
, Qunbound
);
640 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
641 doc
: /* Make SYMBOL's function definition be void.
644 register Lisp_Object symbol
;
646 CHECK_SYMBOL (symbol
);
647 if (NILP (symbol
) || EQ (symbol
, Qt
))
648 xsignal1 (Qsetting_constant
, symbol
);
649 XSYMBOL (symbol
)->function
= Qunbound
;
653 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
654 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
656 register Lisp_Object symbol
;
658 CHECK_SYMBOL (symbol
);
659 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
660 return XSYMBOL (symbol
)->function
;
661 xsignal1 (Qvoid_function
, symbol
);
664 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
665 doc
: /* Return SYMBOL's property list. */)
667 register Lisp_Object symbol
;
669 CHECK_SYMBOL (symbol
);
670 return XSYMBOL (symbol
)->plist
;
673 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
674 doc
: /* Return SYMBOL's name, a string. */)
676 register Lisp_Object symbol
;
678 register Lisp_Object name
;
680 CHECK_SYMBOL (symbol
);
681 name
= SYMBOL_NAME (symbol
);
685 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
686 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
688 register Lisp_Object symbol
, definition
;
690 register Lisp_Object function
;
692 CHECK_SYMBOL (symbol
);
693 if (NILP (symbol
) || EQ (symbol
, Qt
))
694 xsignal1 (Qsetting_constant
, symbol
);
696 function
= XSYMBOL (symbol
)->function
;
698 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
699 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
701 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
702 Fput (symbol
, Qautoload
, XCDR (function
));
704 XSYMBOL (symbol
)->function
= definition
;
705 /* Handle automatic advice activation */
706 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
708 call2 (Qad_activate_internal
, symbol
, Qnil
);
709 definition
= XSYMBOL (symbol
)->function
;
714 extern Lisp_Object Qfunction_documentation
;
716 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
717 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
718 Associates the function with the current load file, if any.
719 The optional third argument DOCSTRING specifies the documentation string
720 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
721 determined by DEFINITION. */)
722 (symbol
, definition
, docstring
)
723 register Lisp_Object symbol
, definition
, docstring
;
725 CHECK_SYMBOL (symbol
);
726 if (CONSP (XSYMBOL (symbol
)->function
)
727 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
728 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
729 definition
= Ffset (symbol
, definition
);
730 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
731 if (!NILP (docstring
))
732 Fput (symbol
, Qfunction_documentation
, docstring
);
736 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
737 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
739 register Lisp_Object symbol
, newplist
;
741 CHECK_SYMBOL (symbol
);
742 XSYMBOL (symbol
)->plist
= newplist
;
746 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
747 doc
: /* Return minimum and maximum number of args allowed for SUBR.
748 SUBR must be a built-in function.
749 The returned value is a pair (MIN . MAX). MIN is the minimum number
750 of args. MAX is the maximum number or the symbol `many', for a
751 function with `&rest' args, or `unevalled' for a special form. */)
755 short minargs
, maxargs
;
757 minargs
= XSUBR (subr
)->min_args
;
758 maxargs
= XSUBR (subr
)->max_args
;
760 return Fcons (make_number (minargs
), Qmany
);
761 else if (maxargs
== UNEVALLED
)
762 return Fcons (make_number (minargs
), Qunevalled
);
764 return Fcons (make_number (minargs
), make_number (maxargs
));
767 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
768 doc
: /* Return name of subroutine SUBR.
769 SUBR must be a built-in function. */)
775 name
= XSUBR (subr
)->symbol_name
;
776 return make_string (name
, strlen (name
));
779 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
780 doc
: /* Return the interactive form of CMD or nil if none.
781 If CMD is not a command, the return value is nil.
782 Value, if non-nil, is a list \(interactive SPEC). */)
786 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
788 if (NILP (fun
) || EQ (fun
, Qunbound
))
791 /* Use an `interactive-form' property if present, analogous to the
792 function-documentation property. */
794 while (SYMBOLP (fun
))
796 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
800 fun
= Fsymbol_function (fun
);
805 char *spec
= XSUBR (fun
)->intspec
;
807 return list2 (Qinteractive
,
808 (*spec
!= '(') ? build_string (spec
) :
809 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
811 else if (COMPILEDP (fun
))
813 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
814 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
816 else if (CONSP (fun
))
818 Lisp_Object funcar
= XCAR (fun
);
819 if (EQ (funcar
, Qlambda
))
820 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
821 else if (EQ (funcar
, Qautoload
))
825 do_autoload (fun
, cmd
);
827 return Finteractive_form (cmd
);
834 /***********************************************************************
835 Getting and Setting Values of Symbols
836 ***********************************************************************/
838 /* Return the symbol holding SYMBOL's value. Signal
839 `cyclic-variable-indirection' if SYMBOL's chain of variable
840 indirections contains a loop. */
843 indirect_variable (symbol
)
844 struct Lisp_Symbol
*symbol
;
846 struct Lisp_Symbol
*tortoise
, *hare
;
848 hare
= tortoise
= symbol
;
850 while (hare
->redirect
== SYMBOL_VARALIAS
)
852 hare
= SYMBOL_ALIAS (hare
);
853 if (hare
->redirect
!= SYMBOL_VARALIAS
)
856 hare
= SYMBOL_ALIAS (hare
);
857 tortoise
= SYMBOL_ALIAS (tortoise
);
859 if (hare
== tortoise
)
862 XSETSYMBOL (tem
, symbol
);
863 xsignal1 (Qcyclic_variable_indirection
, tem
);
871 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
872 doc
: /* Return the variable at the end of OBJECT's variable chain.
873 If OBJECT is a symbol, follow all variable indirections and return the final
874 variable. If OBJECT is not a symbol, just return it.
875 Signal a cyclic-variable-indirection error if there is a loop in the
876 variable chain of symbols. */)
880 if (SYMBOLP (object
))
881 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
886 /* Given the raw contents of a symbol value cell,
887 return the Lisp value of the symbol.
888 This does not handle buffer-local variables; use
889 swap_in_symval_forwarding for that. */
891 #define do_blv_forwarding(blv) \
892 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
895 do_symval_forwarding (valcontents
)
896 register union Lisp_Fwd
*valcontents
;
898 register Lisp_Object val
;
899 switch (XFWDTYPE (valcontents
))
902 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
906 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
909 return *XOBJFWD (valcontents
)->objvar
;
911 case Lisp_Fwd_Buffer_Obj
:
912 return PER_BUFFER_VALUE (current_buffer
,
913 XBUFFER_OBJFWD (valcontents
)->offset
);
915 case Lisp_Fwd_Kboard_Obj
:
916 /* We used to simply use current_kboard here, but from Lisp
917 code, it's value is often unexpected. It seems nicer to
918 allow constructions like this to work as intuitively expected:
920 (with-selected-frame frame
921 (define-key local-function-map "\eOP" [f1]))
923 On the other hand, this affects the semantics of
924 last-command and real-last-command, and people may rely on
925 that. I took a quick look at the Lisp codebase, and I
926 don't think anything will break. --lorentey */
927 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
928 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
933 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
934 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
935 buffer-independent contents of the value cell: forwarded just one
936 step past the buffer-localness.
938 BUF non-zero means set the value in buffer BUF instead of the
939 current buffer. This only plays a role for per-buffer variables. */
941 #define store_blv_forwarding(blv, newval, buf) \
943 if ((blv)->forwarded) \
944 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
946 SET_BLV_VALUE (blv, newval); \
950 store_symval_forwarding (/* symbol, */ valcontents
, newval
, buf
)
951 /* struct Lisp_Symbol *symbol; */
952 union Lisp_Fwd
*valcontents
;
953 register Lisp_Object newval
;
956 switch (XFWDTYPE (valcontents
))
959 CHECK_NUMBER (newval
);
960 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
964 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
968 *XOBJFWD (valcontents
)->objvar
= newval
;
970 /* If this variable is a default for something stored
971 in the buffer itself, such as default-fill-column,
972 find the buffers that don't have local values for it
974 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
975 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
977 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
978 - (char *) &buffer_defaults
);
979 int idx
= PER_BUFFER_IDX (offset
);
986 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
991 buf
= Fcdr (XCAR (tail
));
992 if (!BUFFERP (buf
)) continue;
995 if (! PER_BUFFER_VALUE_P (b
, idx
))
996 PER_BUFFER_VALUE (b
, offset
) = newval
;
1001 case Lisp_Fwd_Buffer_Obj
:
1003 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1004 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
1006 if (!(NILP (type
) || NILP (newval
)
1007 || (XINT (type
) == LISP_INT_TAG
1009 : XTYPE (newval
) == XINT (type
))))
1010 buffer_slot_type_mismatch (newval
, XINT (type
));
1013 buf
= current_buffer
;
1014 PER_BUFFER_VALUE (buf
, offset
) = newval
;
1018 case Lisp_Fwd_Kboard_Obj
:
1020 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
1021 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
1022 *(Lisp_Object
*) p
= newval
;
1027 abort (); /* goto def; */
1031 /* Set up SYMBOL to refer to its global binding.
1032 This makes it safe to alter the status of other bindings. */
1035 swap_in_global_binding (symbol
)
1036 struct Lisp_Symbol
*symbol
;
1038 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
1040 /* Unload the previously loaded binding. */
1042 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1044 /* Select the global binding in the symbol. */
1045 blv
->valcell
= blv
->defcell
;
1047 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1049 /* Indicate that the global binding is set up now. */
1051 SET_BLV_FOUND (blv
, 0);
1054 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1055 VALCONTENTS is the contents of its value cell,
1056 which points to a struct Lisp_Buffer_Local_Value.
1058 Return the value forwarded one step past the buffer-local stage.
1059 This could be another forwarding pointer. */
1062 swap_in_symval_forwarding (symbol
, blv
)
1063 struct Lisp_Symbol
*symbol
;
1064 struct Lisp_Buffer_Local_Value
*blv
;
1066 register Lisp_Object tem1
;
1068 eassert (blv
== SYMBOL_BLV (symbol
));
1073 || (blv
->frame_local
1074 ? !EQ (selected_frame
, tem1
)
1075 : current_buffer
!= XBUFFER (tem1
)))
1078 /* Unload the previously loaded binding. */
1079 tem1
= blv
->valcell
;
1081 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1082 /* Choose the new binding. */
1085 XSETSYMBOL (var
, symbol
);
1086 if (blv
->frame_local
)
1088 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1089 blv
->where
= selected_frame
;
1093 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1094 XSETBUFFER (blv
->where
, current_buffer
);
1097 if (!(blv
->found
= !NILP (tem1
)))
1098 tem1
= blv
->defcell
;
1100 /* Load the new binding. */
1101 blv
->valcell
= tem1
;
1103 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1107 /* Find the value of a symbol, returning Qunbound if it's not bound.
1108 This is helpful for code which just wants to get a variable's value
1109 if it has one, without signaling an error.
1110 Note that it must not be possible to quit
1111 within this function. Great care is required for this. */
1114 find_symbol_value (symbol
)
1117 struct Lisp_Symbol
*sym
;
1119 CHECK_SYMBOL (symbol
);
1120 sym
= XSYMBOL (symbol
);
1123 switch (sym
->redirect
)
1125 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1126 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1127 case SYMBOL_LOCALIZED
:
1129 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1130 swap_in_symval_forwarding (sym
, blv
);
1131 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1134 case SYMBOL_FORWARDED
:
1135 return do_symval_forwarding (SYMBOL_FWD (sym
));
1140 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1141 doc
: /* Return SYMBOL's value. Error if that is void. */)
1147 val
= find_symbol_value (symbol
);
1148 if (!EQ (val
, Qunbound
))
1151 xsignal1 (Qvoid_variable
, symbol
);
1154 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1155 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1157 register Lisp_Object symbol
, newval
;
1159 set_internal (symbol
, newval
, current_buffer
, 0);
1163 /* Return 1 if SYMBOL currently has a let-binding
1164 which was made in the buffer that is now current. */
1167 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1169 struct specbinding
*p
;
1171 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1173 && CONSP (p
->symbol
))
1175 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1176 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1177 if (symbol
== let_bound_symbol
1178 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1182 return p
>= specpdl
;
1186 let_shadows_global_binding_p (symbol
)
1189 struct specbinding
*p
;
1191 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1192 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1195 return p
>= specpdl
;
1198 /* Store the value NEWVAL into SYMBOL.
1199 If buffer-locality is an issue, BUF specifies which buffer to use.
1200 (0 stands for the current buffer.)
1202 If BINDFLAG is zero, then if this symbol is supposed to become
1203 local in every buffer where it is set, then we make it local.
1204 If BINDFLAG is nonzero, we don't do that. */
1207 set_internal (symbol
, newval
, buf
, bindflag
)
1208 register Lisp_Object symbol
, newval
;
1212 int voide
= EQ (newval
, Qunbound
);
1213 struct Lisp_Symbol
*sym
;
1217 buf
= current_buffer
;
1219 /* If restoring in a dead buffer, do nothing. */
1220 if (NILP (buf
->name
))
1223 CHECK_SYMBOL (symbol
);
1224 if (SYMBOL_CONSTANT_P (symbol
))
1226 if (NILP (Fkeywordp (symbol
))
1227 || !EQ (newval
, Fsymbol_value (symbol
)))
1228 xsignal1 (Qsetting_constant
, symbol
);
1230 /* Allow setting keywords to their own value. */
1234 sym
= XSYMBOL (symbol
);
1237 switch (sym
->redirect
)
1239 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1240 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1241 case SYMBOL_LOCALIZED
:
1243 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1244 Lisp_Object tmp
; XSETBUFFER (tmp
, buf
);
1246 /* If the current buffer is not the buffer whose binding is
1247 loaded, or if there may be frame-local bindings and the frame
1248 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1249 the default binding is loaded, the loaded binding may be the
1251 if (!EQ (blv
->where
,
1252 blv
->frame_local
? selected_frame
: tmp
)
1253 /* Also unload a global binding (if the var is local_if_set). */
1254 || (EQ (blv
->valcell
, blv
->defcell
)))
1256 /* The currently loaded binding is not necessarily valid.
1257 We need to unload it, and choose a new binding. */
1259 /* Write out `realvalue' to the old loaded binding. */
1261 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1263 /* Find the new binding. */
1265 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1266 if (blv
->frame_local
)
1268 tem1
= Fassq (symbol
, XFRAME (selected_frame
)->param_alist
);
1269 blv
->where
= selected_frame
;
1273 tem1
= Fassq (symbol
, buf
->local_var_alist
);
1281 /* This buffer still sees the default value. */
1283 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1284 or if this is `let' rather than `set',
1285 make CURRENT-ALIST-ELEMENT point to itself,
1286 indicating that we're seeing the default value.
1287 Likewise if the variable has been let-bound
1288 in the current buffer. */
1289 if (bindflag
|| !blv
->local_if_set
1290 || let_shadows_buffer_binding_p (sym
))
1293 tem1
= blv
->defcell
;
1295 /* If it's a local_if_set, being set not bound,
1296 and we're not within a let that was made for this buffer,
1297 create a new buffer-local binding for the variable.
1298 That means, give this buffer a new assoc for a local value
1299 and load that binding. */
1302 /* local_if_set is only supported for buffer-local
1303 bindings, not for frame-local bindings. */
1304 eassert (!blv
->frame_local
);
1305 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1306 buf
->local_var_alist
1307 = Fcons (tem1
, buf
->local_var_alist
);
1311 /* Record which binding is now loaded. */
1312 blv
->valcell
= tem1
;
1315 /* Store the new value in the cons cell. */
1316 SET_BLV_VALUE (blv
, newval
);
1321 /* If storing void (making the symbol void), forward only through
1322 buffer-local indicator, not through Lisp_Objfwd, etc. */
1325 store_symval_forwarding (blv
->fwd
, newval
, buf
);
1329 case SYMBOL_FORWARDED
:
1331 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1332 if (BUFFER_OBJFWDP (innercontents
))
1334 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1335 int idx
= PER_BUFFER_IDX (offset
);
1338 && !let_shadows_buffer_binding_p (sym
))
1339 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1343 { /* If storing void (making the symbol void), forward only through
1344 buffer-local indicator, not through Lisp_Objfwd, etc. */
1345 sym
->redirect
= SYMBOL_PLAINVAL
;
1346 SET_SYMBOL_VAL (sym
, newval
);
1349 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1357 /* Access or set a buffer-local symbol's default value. */
1359 /* Return the default value of SYMBOL, but don't check for voidness.
1360 Return Qunbound if it is void. */
1363 default_value (symbol
)
1366 struct Lisp_Symbol
*sym
;
1368 CHECK_SYMBOL (symbol
);
1369 sym
= XSYMBOL (symbol
);
1372 switch (sym
->redirect
)
1374 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1375 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1376 case SYMBOL_LOCALIZED
:
1378 /* If var is set up for a buffer that lacks a local value for it,
1379 the current value is nominally the default value.
1380 But the `realvalue' slot may be more up to date, since
1381 ordinary setq stores just that slot. So use that. */
1382 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1383 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1384 return do_symval_forwarding (blv
->fwd
);
1386 return XCDR (blv
->defcell
);
1388 case SYMBOL_FORWARDED
:
1390 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1392 /* For a built-in buffer-local variable, get the default value
1393 rather than letting do_symval_forwarding get the current value. */
1394 if (BUFFER_OBJFWDP (valcontents
))
1396 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1397 if (PER_BUFFER_IDX (offset
) != 0)
1398 return PER_BUFFER_DEFAULT (offset
);
1401 /* For other variables, get the current value. */
1402 return do_symval_forwarding (valcontents
);
1408 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1409 doc
: /* Return t if SYMBOL has a non-void default value.
1410 This is the value that is seen in buffers that do not have their own values
1411 for this variable. */)
1415 register Lisp_Object value
;
1417 value
= default_value (symbol
);
1418 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1421 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1422 doc
: /* Return SYMBOL's default value.
1423 This is the value that is seen in buffers that do not have their own values
1424 for this variable. The default value is meaningful for variables with
1425 local bindings in certain buffers. */)
1429 register Lisp_Object value
;
1431 value
= default_value (symbol
);
1432 if (!EQ (value
, Qunbound
))
1435 xsignal1 (Qvoid_variable
, symbol
);
1438 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1439 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1440 The default value is seen in buffers that do not have their own values
1441 for this variable. */)
1443 Lisp_Object symbol
, value
;
1445 struct Lisp_Symbol
*sym
;
1447 CHECK_SYMBOL (symbol
);
1448 if (SYMBOL_CONSTANT_P (symbol
))
1450 if (NILP (Fkeywordp (symbol
))
1451 || !EQ (value
, Fdefault_value (symbol
)))
1452 xsignal1 (Qsetting_constant
, symbol
);
1454 /* Allow setting keywords to their own value. */
1457 sym
= XSYMBOL (symbol
);
1460 switch (sym
->redirect
)
1462 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1463 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1464 case SYMBOL_LOCALIZED
:
1466 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1468 /* Store new value into the DEFAULT-VALUE slot. */
1469 XSETCDR (blv
->defcell
, value
);
1471 /* If the default binding is now loaded, set the REALVALUE slot too. */
1472 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1473 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1476 case SYMBOL_FORWARDED
:
1478 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1480 /* Handle variables like case-fold-search that have special slots
1482 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1483 if (BUFFER_OBJFWDP (valcontents
))
1485 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1486 int idx
= PER_BUFFER_IDX (offset
);
1488 PER_BUFFER_DEFAULT (offset
) = value
;
1490 /* If this variable is not always local in all buffers,
1491 set it in the buffers that don't nominally have a local value. */
1496 for (b
= all_buffers
; b
; b
= b
->next
)
1497 if (!PER_BUFFER_VALUE_P (b
, idx
))
1498 PER_BUFFER_VALUE (b
, offset
) = value
;
1503 return Fset (symbol
, value
);
1509 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1510 doc
: /* Set the default value of variable VAR to VALUE.
1511 VAR, the variable name, is literal (not evaluated);
1512 VALUE is an expression: it is evaluated and its value returned.
1513 The default value of a variable is seen in buffers
1514 that do not have their own values for the variable.
1516 More generally, you can use multiple variables and values, as in
1517 (setq-default VAR VALUE VAR VALUE...)
1518 This sets each VAR's default value to the corresponding VALUE.
1519 The VALUE for the Nth VAR can refer to the new default values
1521 usage: (setq-default [VAR VALUE]...) */)
1525 register Lisp_Object args_left
;
1526 register Lisp_Object val
, symbol
;
1527 struct gcpro gcpro1
;
1537 val
= Feval (Fcar (Fcdr (args_left
)));
1538 symbol
= XCAR (args_left
);
1539 Fset_default (symbol
, val
);
1540 args_left
= Fcdr (XCDR (args_left
));
1542 while (!NILP (args_left
));
1548 /* Lisp functions for creating and removing buffer-local variables. */
1553 union Lisp_Fwd
*fwd
;
1556 static struct Lisp_Buffer_Local_Value
*
1557 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1559 struct Lisp_Buffer_Local_Value
*blv
1560 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1561 Lisp_Object symbol
; XSETSYMBOL (symbol
, sym
);
1562 Lisp_Object tem
= Fcons (symbol
, (forwarded
1563 ? do_symval_forwarding (valcontents
.fwd
)
1564 : valcontents
.value
));
1565 /* Buffer_Local_Values cannot have as realval a buffer-local
1566 or keyboard-local forwarding. */
1567 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1568 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1569 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1571 blv
->frame_local
= 0;
1572 blv
->local_if_set
= 0;
1575 SET_BLV_FOUND (blv
, 0);
1579 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1580 1, 1, "vMake Variable Buffer Local: ",
1581 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1582 At any time, the value for the current buffer is in effect,
1583 unless the variable has never been set in this buffer,
1584 in which case the default value is in effect.
1585 Note that binding the variable with `let', or setting it while
1586 a `let'-style binding made in this buffer is in effect,
1587 does not make the variable buffer-local. Return VARIABLE.
1589 In most cases it is better to use `make-local-variable',
1590 which makes a variable local in just one buffer.
1592 The function `default-value' gets the default value and `set-default' sets it. */)
1594 register Lisp_Object variable
;
1596 struct Lisp_Symbol
*sym
;
1597 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1598 union Lisp_Val_Fwd valcontents
;
1601 CHECK_SYMBOL (variable
);
1602 sym
= XSYMBOL (variable
);
1605 switch (sym
->redirect
)
1607 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1608 case SYMBOL_PLAINVAL
:
1609 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1610 if (EQ (valcontents
.value
, Qunbound
))
1611 valcontents
.value
= Qnil
;
1613 case SYMBOL_LOCALIZED
:
1614 blv
= SYMBOL_BLV (sym
);
1615 if (blv
->frame_local
)
1616 error ("Symbol %s may not be buffer-local",
1617 SDATA (SYMBOL_NAME (variable
)));
1619 case SYMBOL_FORWARDED
:
1620 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1621 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1622 error ("Symbol %s may not be buffer-local",
1623 SDATA (SYMBOL_NAME (variable
)));
1624 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1631 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1635 blv
= make_blv (sym
, forwarded
, valcontents
);
1636 sym
->redirect
= SYMBOL_LOCALIZED
;
1637 SET_SYMBOL_BLV (sym
, blv
);
1640 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1641 if (let_shadows_global_binding_p (symbol
))
1642 error ("Making %s buffer-local while let-bound!",
1643 SDATA (SYMBOL_NAME (variable
)));
1647 blv
->local_if_set
= 1;
1651 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1652 1, 1, "vMake Local Variable: ",
1653 doc
: /* Make VARIABLE have a separate value in the current buffer.
1654 Other buffers will continue to share a common default value.
1655 \(The buffer-local value of VARIABLE starts out as the same value
1656 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1659 If the variable is already arranged to become local when set,
1660 this function causes a local value to exist for this buffer,
1661 just as setting the variable would do.
1663 This function returns VARIABLE, and therefore
1664 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1667 See also `make-variable-buffer-local'.
1669 Do not use `make-local-variable' to make a hook variable buffer-local.
1670 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1672 register Lisp_Object variable
;
1674 register Lisp_Object tem
;
1676 union Lisp_Val_Fwd valcontents
;
1677 struct Lisp_Symbol
*sym
;
1678 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1680 CHECK_SYMBOL (variable
);
1681 sym
= XSYMBOL (variable
);
1684 switch (sym
->redirect
)
1686 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1687 case SYMBOL_PLAINVAL
:
1688 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1689 case SYMBOL_LOCALIZED
:
1690 blv
= SYMBOL_BLV (sym
);
1691 if (blv
->frame_local
)
1692 error ("Symbol %s may not be buffer-local",
1693 SDATA (SYMBOL_NAME (variable
)));
1695 case SYMBOL_FORWARDED
:
1696 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1697 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1698 error ("Symbol %s may not be buffer-local",
1699 SDATA (SYMBOL_NAME (variable
)));
1705 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1707 if (blv
? blv
->local_if_set
1708 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1710 tem
= Fboundp (variable
);
1711 /* Make sure the symbol has a local value in this particular buffer,
1712 by setting it to the same value it already has. */
1713 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1718 blv
= make_blv (sym
, forwarded
, valcontents
);
1719 sym
->redirect
= SYMBOL_LOCALIZED
;
1720 SET_SYMBOL_BLV (sym
, blv
);
1723 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1724 if (let_shadows_global_binding_p (symbol
))
1725 error ("Making %s local to %s while let-bound!",
1726 SDATA (SYMBOL_NAME (variable
)), SDATA (current_buffer
->name
));
1730 /* Make sure this buffer has its own value of symbol. */
1731 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1732 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1735 if (let_shadows_buffer_binding_p (sym
))
1736 message ("Making %s buffer-local while locally let-bound!",
1737 SDATA (SYMBOL_NAME (variable
)));
1739 /* Swap out any local binding for some other buffer, and make
1740 sure the current value is permanently recorded, if it's the
1742 find_symbol_value (variable
);
1744 current_buffer
->local_var_alist
1745 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1746 current_buffer
->local_var_alist
);
1748 /* Make sure symbol does not think it is set up for this buffer;
1749 force it to look once again for this buffer's value. */
1750 if (current_buffer
== XBUFFER (blv
->where
))
1752 /* blv->valcell = blv->defcell;
1753 * SET_BLV_FOUND (blv, 0); */
1757 /* If the symbol forwards into a C variable, then load the binding
1758 for this buffer now. If C code modifies the variable before we
1759 load the binding in, then that new value will clobber the default
1760 binding the next time we unload it. */
1762 swap_in_symval_forwarding (sym
, blv
);
1767 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1768 1, 1, "vKill Local Variable: ",
1769 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1770 From now on the default value will apply in this buffer. Return VARIABLE. */)
1772 register Lisp_Object variable
;
1774 register Lisp_Object tem
;
1775 struct Lisp_Buffer_Local_Value
*blv
;
1776 struct Lisp_Symbol
*sym
;
1778 CHECK_SYMBOL (variable
);
1779 sym
= XSYMBOL (variable
);
1782 switch (sym
->redirect
)
1784 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1785 case SYMBOL_PLAINVAL
: return variable
;
1786 case SYMBOL_FORWARDED
:
1788 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1789 if (BUFFER_OBJFWDP (valcontents
))
1791 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1792 int idx
= PER_BUFFER_IDX (offset
);
1796 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1797 PER_BUFFER_VALUE (current_buffer
, offset
)
1798 = PER_BUFFER_DEFAULT (offset
);
1803 case SYMBOL_LOCALIZED
:
1804 blv
= SYMBOL_BLV (sym
);
1805 if (blv
->frame_local
)
1811 /* Get rid of this buffer's alist element, if any. */
1812 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1813 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1815 current_buffer
->local_var_alist
1816 = Fdelq (tem
, current_buffer
->local_var_alist
);
1818 /* If the symbol is set up with the current buffer's binding
1819 loaded, recompute its value. We have to do it now, or else
1820 forwarded objects won't work right. */
1822 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1823 if (EQ (buf
, blv
->where
))
1826 /* blv->valcell = blv->defcell;
1827 * SET_BLV_FOUND (blv, 0); */
1829 find_symbol_value (variable
);
1836 /* Lisp functions for creating and removing buffer-local variables. */
1838 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1839 when/if this is removed. */
1841 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1842 1, 1, "vMake Variable Frame Local: ",
1843 doc
: /* Enable VARIABLE to have frame-local bindings.
1844 This does not create any frame-local bindings for VARIABLE,
1845 it just makes them possible.
1847 A frame-local binding is actually a frame parameter value.
1848 If a frame F has a value for the frame parameter named VARIABLE,
1849 that also acts as a frame-local binding for VARIABLE in F--
1850 provided this function has been called to enable VARIABLE
1851 to have frame-local bindings at all.
1853 The only way to create a frame-local binding for VARIABLE in a frame
1854 is to set the VARIABLE frame parameter of that frame. See
1855 `modify-frame-parameters' for how to set frame parameters.
1857 Note that since Emacs 23.1, variables cannot be both buffer-local and
1858 frame-local any more (buffer-local bindings used to take precedence over
1859 frame-local bindings). */)
1861 register Lisp_Object variable
;
1864 union Lisp_Val_Fwd valcontents
;
1865 struct Lisp_Symbol
*sym
;
1866 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1868 CHECK_SYMBOL (variable
);
1869 sym
= XSYMBOL (variable
);
1872 switch (sym
->redirect
)
1874 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1875 case SYMBOL_PLAINVAL
:
1876 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1877 if (EQ (valcontents
.value
, Qunbound
))
1878 valcontents
.value
= Qnil
;
1880 case SYMBOL_LOCALIZED
:
1881 if (SYMBOL_BLV (sym
)->frame_local
)
1884 error ("Symbol %s may not be frame-local",
1885 SDATA (SYMBOL_NAME (variable
)));
1886 case SYMBOL_FORWARDED
:
1887 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1888 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1889 error ("Symbol %s may not be frame-local",
1890 SDATA (SYMBOL_NAME (variable
)));
1896 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1898 blv
= make_blv (sym
, forwarded
, valcontents
);
1899 blv
->frame_local
= 1;
1900 sym
->redirect
= SYMBOL_LOCALIZED
;
1901 SET_SYMBOL_BLV (sym
, blv
);
1905 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1907 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1908 BUFFER defaults to the current buffer. */)
1910 register Lisp_Object variable
, buffer
;
1912 register struct buffer
*buf
;
1913 struct Lisp_Symbol
*sym
;
1916 buf
= current_buffer
;
1919 CHECK_BUFFER (buffer
);
1920 buf
= XBUFFER (buffer
);
1923 CHECK_SYMBOL (variable
);
1924 sym
= XSYMBOL (variable
);
1927 switch (sym
->redirect
)
1929 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1930 case SYMBOL_PLAINVAL
: return Qnil
;
1931 case SYMBOL_LOCALIZED
:
1933 Lisp_Object tail
, elt
, tmp
;
1934 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1935 XSETBUFFER (tmp
, buf
);
1937 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1940 if (EQ (variable
, XCAR (elt
)))
1942 eassert (!blv
->frame_local
);
1943 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1947 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1950 case SYMBOL_FORWARDED
:
1952 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1953 if (BUFFER_OBJFWDP (valcontents
))
1955 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1956 int idx
= PER_BUFFER_IDX (offset
);
1957 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1966 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1968 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1969 More precisely, this means that setting the variable \(with `set' or`setq'),
1970 while it does not have a `let'-style binding that was made in BUFFER,
1971 will produce a buffer local binding. See Info node
1972 `(elisp)Creating Buffer-Local'.
1973 BUFFER defaults to the current buffer. */)
1975 register Lisp_Object variable
, buffer
;
1977 struct Lisp_Symbol
*sym
;
1979 CHECK_SYMBOL (variable
);
1980 sym
= XSYMBOL (variable
);
1983 switch (sym
->redirect
)
1985 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1986 case SYMBOL_PLAINVAL
: return Qnil
;
1987 case SYMBOL_LOCALIZED
:
1989 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1990 if (blv
->local_if_set
)
1992 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1993 return Flocal_variable_p (variable
, buffer
);
1995 case SYMBOL_FORWARDED
:
1996 /* All BUFFER_OBJFWD slots become local if they are set. */
1997 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
2002 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
2004 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
2005 If the current binding is buffer-local, the value is the current buffer.
2006 If the current binding is frame-local, the value is the selected frame.
2007 If the current binding is global (the default), the value is nil. */)
2009 register Lisp_Object variable
;
2011 struct Lisp_Symbol
*sym
;
2013 CHECK_SYMBOL (variable
);
2014 sym
= XSYMBOL (variable
);
2016 /* Make sure the current binding is actually swapped in. */
2017 find_symbol_value (variable
);
2020 switch (sym
->redirect
)
2022 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
2023 case SYMBOL_PLAINVAL
: return Qnil
;
2024 case SYMBOL_FORWARDED
:
2026 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
2027 if (KBOARD_OBJFWDP (valcontents
))
2028 return Fframe_terminal (Fselected_frame ());
2029 else if (!BUFFER_OBJFWDP (valcontents
))
2033 case SYMBOL_LOCALIZED
:
2034 /* For a local variable, record both the symbol and which
2035 buffer's or frame's value we are saving. */
2036 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
2037 return Fcurrent_buffer ();
2038 else if (sym
->redirect
== SYMBOL_LOCALIZED
2039 && BLV_FOUND (SYMBOL_BLV (sym
)))
2040 return SYMBOL_BLV (sym
)->where
;
2047 /* This code is disabled now that we use the selected frame to return
2048 keyboard-local-values. */
2050 extern struct terminal
*get_terminal
P_ ((Lisp_Object display
, int));
2052 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
2053 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
2054 If SYMBOL is not a terminal-local variable, then return its normal
2055 value, like `symbol-value'.
2057 TERMINAL may be a terminal object, a frame, or nil (meaning the
2058 selected frame's terminal device). */)
2061 Lisp_Object terminal
;
2064 struct terminal
*t
= get_terminal (terminal
, 1);
2065 push_kboard (t
->kboard
);
2066 result
= Fsymbol_value (symbol
);
2071 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2072 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2073 If VARIABLE is not a terminal-local variable, then set its normal
2074 binding, like `set'.
2076 TERMINAL may be a terminal object, a frame, or nil (meaning the
2077 selected frame's terminal device). */)
2078 (symbol
, terminal
, value
)
2080 Lisp_Object terminal
;
2084 struct terminal
*t
= get_terminal (terminal
, 1);
2085 push_kboard (d
->kboard
);
2086 result
= Fset (symbol
, value
);
2092 /* Find the function at the end of a chain of symbol function indirections. */
2094 /* If OBJECT is a symbol, find the end of its function chain and
2095 return the value found there. If OBJECT is not a symbol, just
2096 return it. If there is a cycle in the function chain, signal a
2097 cyclic-function-indirection error.
2099 This is like Findirect_function, except that it doesn't signal an
2100 error if the chain ends up unbound. */
2102 indirect_function (object
)
2103 register Lisp_Object object
;
2105 Lisp_Object tortoise
, hare
;
2107 hare
= tortoise
= object
;
2111 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2113 hare
= XSYMBOL (hare
)->function
;
2114 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2116 hare
= XSYMBOL (hare
)->function
;
2118 tortoise
= XSYMBOL (tortoise
)->function
;
2120 if (EQ (hare
, tortoise
))
2121 xsignal1 (Qcyclic_function_indirection
, object
);
2127 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2128 doc
: /* Return the function at the end of OBJECT's function chain.
2129 If OBJECT is not a symbol, just return it. Otherwise, follow all
2130 function indirections to find the final function binding and return it.
2131 If the final symbol in the chain is unbound, signal a void-function error.
2132 Optional arg NOERROR non-nil means to return nil instead of signalling.
2133 Signal a cyclic-function-indirection error if there is a loop in the
2134 function chain of symbols. */)
2136 register Lisp_Object object
;
2137 Lisp_Object noerror
;
2141 /* Optimize for no indirection. */
2143 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2144 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2145 result
= indirect_function (result
);
2146 if (!EQ (result
, Qunbound
))
2150 xsignal1 (Qvoid_function
, object
);
2155 /* Extract and set vector and string elements */
2157 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2158 doc
: /* Return the element of ARRAY at index IDX.
2159 ARRAY may be a vector, a string, a char-table, a bool-vector,
2160 or a byte-code object. IDX starts at 0. */)
2162 register Lisp_Object array
;
2165 register int idxval
;
2168 idxval
= XINT (idx
);
2169 if (STRINGP (array
))
2173 if (idxval
< 0 || idxval
>= SCHARS (array
))
2174 args_out_of_range (array
, idx
);
2175 if (! STRING_MULTIBYTE (array
))
2176 return make_number ((unsigned char) SREF (array
, idxval
));
2177 idxval_byte
= string_char_to_byte (array
, idxval
);
2179 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2180 return make_number (c
);
2182 else if (BOOL_VECTOR_P (array
))
2186 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2187 args_out_of_range (array
, idx
);
2189 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2190 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2192 else if (CHAR_TABLE_P (array
))
2194 CHECK_CHARACTER (idx
);
2195 return CHAR_TABLE_REF (array
, idxval
);
2200 if (VECTORP (array
))
2201 size
= XVECTOR (array
)->size
;
2202 else if (COMPILEDP (array
))
2203 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2205 wrong_type_argument (Qarrayp
, array
);
2207 if (idxval
< 0 || idxval
>= size
)
2208 args_out_of_range (array
, idx
);
2209 return XVECTOR (array
)->contents
[idxval
];
2213 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2214 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2215 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2216 bool-vector. IDX starts at 0. */)
2217 (array
, idx
, newelt
)
2218 register Lisp_Object array
;
2219 Lisp_Object idx
, newelt
;
2221 register int idxval
;
2224 idxval
= XINT (idx
);
2225 CHECK_ARRAY (array
, Qarrayp
);
2226 CHECK_IMPURE (array
);
2228 if (VECTORP (array
))
2230 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2231 args_out_of_range (array
, idx
);
2232 XVECTOR (array
)->contents
[idxval
] = newelt
;
2234 else if (BOOL_VECTOR_P (array
))
2238 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2239 args_out_of_range (array
, idx
);
2241 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2243 if (! NILP (newelt
))
2244 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2246 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2247 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2249 else if (CHAR_TABLE_P (array
))
2251 CHECK_CHARACTER (idx
);
2252 CHAR_TABLE_SET (array
, idxval
, newelt
);
2254 else if (STRING_MULTIBYTE (array
))
2256 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2257 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2259 if (idxval
< 0 || idxval
>= SCHARS (array
))
2260 args_out_of_range (array
, idx
);
2261 CHECK_CHARACTER (newelt
);
2263 nbytes
= SBYTES (array
);
2265 idxval_byte
= string_char_to_byte (array
, idxval
);
2266 p1
= SDATA (array
) + idxval_byte
;
2267 PARSE_MULTIBYTE_SEQ (p1
, nbytes
- idxval_byte
, prev_bytes
);
2268 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2269 if (prev_bytes
!= new_bytes
)
2271 /* We must relocate the string data. */
2272 int nchars
= SCHARS (array
);
2276 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2277 bcopy (SDATA (array
), str
, nbytes
);
2278 allocate_string_data (XSTRING (array
), nchars
,
2279 nbytes
+ new_bytes
- prev_bytes
);
2280 bcopy (str
, SDATA (array
), idxval_byte
);
2281 p1
= SDATA (array
) + idxval_byte
;
2282 bcopy (str
+ idxval_byte
+ prev_bytes
, p1
+ new_bytes
,
2283 nbytes
- (idxval_byte
+ prev_bytes
));
2285 clear_string_char_byte_cache ();
2292 if (idxval
< 0 || idxval
>= SCHARS (array
))
2293 args_out_of_range (array
, idx
);
2294 CHECK_NUMBER (newelt
);
2296 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2300 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2301 if (SREF (array
, i
) >= 0x80)
2302 args_out_of_range (array
, newelt
);
2303 /* ARRAY is an ASCII string. Convert it to a multibyte
2304 string, and try `aset' again. */
2305 STRING_SET_MULTIBYTE (array
);
2306 return Faset (array
, idx
, newelt
);
2308 SSET (array
, idxval
, XINT (newelt
));
2314 /* Arithmetic functions */
2316 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2319 arithcompare (num1
, num2
, comparison
)
2320 Lisp_Object num1
, num2
;
2321 enum comparison comparison
;
2323 double f1
= 0, f2
= 0;
2326 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2327 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2329 if (FLOATP (num1
) || FLOATP (num2
))
2332 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2333 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2339 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2344 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2349 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2354 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2359 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2364 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2373 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2374 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2376 register Lisp_Object num1
, num2
;
2378 return arithcompare (num1
, num2
, equal
);
2381 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2382 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2384 register Lisp_Object num1
, num2
;
2386 return arithcompare (num1
, num2
, less
);
2389 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2390 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2392 register Lisp_Object num1
, num2
;
2394 return arithcompare (num1
, num2
, grtr
);
2397 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2398 doc
: /* Return t if first arg is less than or equal to second arg.
2399 Both must be numbers or markers. */)
2401 register Lisp_Object num1
, num2
;
2403 return arithcompare (num1
, num2
, less_or_equal
);
2406 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2407 doc
: /* Return t if first arg is greater than or equal to second arg.
2408 Both must be numbers or markers. */)
2410 register Lisp_Object num1
, num2
;
2412 return arithcompare (num1
, num2
, grtr_or_equal
);
2415 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2416 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2418 register Lisp_Object num1
, num2
;
2420 return arithcompare (num1
, num2
, notequal
);
2423 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2424 doc
: /* Return t if NUMBER is zero. */)
2426 register Lisp_Object number
;
2428 CHECK_NUMBER_OR_FLOAT (number
);
2430 if (FLOATP (number
))
2432 if (XFLOAT_DATA (number
) == 0.0)
2442 /* Convert between long values and pairs of Lisp integers.
2443 Note that long_to_cons returns a single Lisp integer
2444 when the value fits in one. */
2450 unsigned long top
= i
>> 16;
2451 unsigned int bot
= i
& 0xFFFF;
2453 return make_number (bot
);
2454 if (top
== (unsigned long)-1 >> 16)
2455 return Fcons (make_number (-1), make_number (bot
));
2456 return Fcons (make_number (top
), make_number (bot
));
2463 Lisp_Object top
, bot
;
2470 return ((XINT (top
) << 16) | XINT (bot
));
2473 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2474 doc
: /* Return the decimal representation of NUMBER as a string.
2475 Uses a minus sign if negative.
2476 NUMBER may be an integer or a floating point number. */)
2480 char buffer
[VALBITS
];
2482 CHECK_NUMBER_OR_FLOAT (number
);
2484 if (FLOATP (number
))
2486 char pigbuf
[350]; /* see comments in float_to_string */
2488 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2489 return build_string (pigbuf
);
2492 if (sizeof (int) == sizeof (EMACS_INT
))
2493 sprintf (buffer
, "%d", (int) XINT (number
));
2494 else if (sizeof (long) == sizeof (EMACS_INT
))
2495 sprintf (buffer
, "%ld", (long) XINT (number
));
2498 return build_string (buffer
);
2502 digit_to_number (character
, base
)
2503 int character
, base
;
2507 if (character
>= '0' && character
<= '9')
2508 digit
= character
- '0';
2509 else if (character
>= 'a' && character
<= 'z')
2510 digit
= character
- 'a' + 10;
2511 else if (character
>= 'A' && character
<= 'Z')
2512 digit
= character
- 'A' + 10;
2522 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2523 doc
: /* Parse STRING as a decimal number and return the number.
2524 This parses both integers and floating point numbers.
2525 It ignores leading spaces and tabs, and all trailing chars.
2527 If BASE, interpret STRING as a number in that base. If BASE isn't
2528 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2529 If the base used is not 10, STRING is always parsed as integer. */)
2531 register Lisp_Object string
, base
;
2533 register unsigned char *p
;
2538 CHECK_STRING (string
);
2544 CHECK_NUMBER (base
);
2546 if (b
< 2 || b
> 16)
2547 xsignal1 (Qargs_out_of_range
, base
);
2550 /* Skip any whitespace at the front of the number. Some versions of
2551 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2553 while (*p
== ' ' || *p
== '\t')
2564 if (isfloat_string (p
, 1) && b
== 10)
2565 val
= make_float (sign
* atof (p
));
2572 int digit
= digit_to_number (*p
++, b
);
2578 val
= make_fixnum_or_float (sign
* v
);
2598 static Lisp_Object float_arith_driver
P_ ((double, int, enum arithop
,
2599 int, Lisp_Object
*));
2600 extern Lisp_Object
fmod_float ();
2603 arith_driver (code
, nargs
, args
)
2606 register Lisp_Object
*args
;
2608 register Lisp_Object val
;
2609 register int argnum
;
2610 register EMACS_INT accum
= 0;
2611 register EMACS_INT next
;
2613 switch (SWITCH_ENUM_CAST (code
))
2631 for (argnum
= 0; argnum
< nargs
; argnum
++)
2633 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2635 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2638 return float_arith_driver ((double) accum
, argnum
, code
,
2641 next
= XINT (args
[argnum
]);
2642 switch (SWITCH_ENUM_CAST (code
))
2648 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2659 xsignal0 (Qarith_error
);
2673 if (!argnum
|| next
> accum
)
2677 if (!argnum
|| next
< accum
)
2683 XSETINT (val
, accum
);
2688 #define isnan(x) ((x) != (x))
2691 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2693 register int argnum
;
2696 register Lisp_Object
*args
;
2698 register Lisp_Object val
;
2701 for (; argnum
< nargs
; argnum
++)
2703 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2704 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2708 next
= XFLOAT_DATA (val
);
2712 args
[argnum
] = val
; /* runs into a compiler bug. */
2713 next
= XINT (args
[argnum
]);
2715 switch (SWITCH_ENUM_CAST (code
))
2721 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2731 if (! IEEE_FLOATING_POINT
&& next
== 0)
2732 xsignal0 (Qarith_error
);
2739 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2741 if (!argnum
|| isnan (next
) || next
> accum
)
2745 if (!argnum
|| isnan (next
) || next
< accum
)
2751 return make_float (accum
);
2755 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2756 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2757 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2762 return arith_driver (Aadd
, nargs
, args
);
2765 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2766 doc
: /* Negate number or subtract numbers or markers and return the result.
2767 With one arg, negates it. With more than one arg,
2768 subtracts all but the first from the first.
2769 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2774 return arith_driver (Asub
, nargs
, args
);
2777 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2778 doc
: /* Return product of any number of arguments, which are numbers or markers.
2779 usage: (* &rest NUMBERS-OR-MARKERS) */)
2784 return arith_driver (Amult
, nargs
, args
);
2787 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2788 doc
: /* Return first argument divided by all the remaining arguments.
2789 The arguments must be numbers or markers.
2790 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2796 for (argnum
= 2; argnum
< nargs
; argnum
++)
2797 if (FLOATP (args
[argnum
]))
2798 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2799 return arith_driver (Adiv
, nargs
, args
);
2802 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2803 doc
: /* Return remainder of X divided by Y.
2804 Both must be integers or markers. */)
2806 register Lisp_Object x
, y
;
2810 CHECK_NUMBER_COERCE_MARKER (x
);
2811 CHECK_NUMBER_COERCE_MARKER (y
);
2813 if (XFASTINT (y
) == 0)
2814 xsignal0 (Qarith_error
);
2816 XSETINT (val
, XINT (x
) % XINT (y
));
2830 /* If the magnitude of the result exceeds that of the divisor, or
2831 the sign of the result does not agree with that of the dividend,
2832 iterate with the reduced value. This does not yield a
2833 particularly accurate result, but at least it will be in the
2834 range promised by fmod. */
2836 r
-= f2
* floor (r
/ f2
);
2837 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2841 #endif /* ! HAVE_FMOD */
2843 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2844 doc
: /* Return X modulo Y.
2845 The result falls between zero (inclusive) and Y (exclusive).
2846 Both X and Y must be numbers or markers. */)
2848 register Lisp_Object x
, y
;
2853 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2854 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2856 if (FLOATP (x
) || FLOATP (y
))
2857 return fmod_float (x
, y
);
2863 xsignal0 (Qarith_error
);
2867 /* If the "remainder" comes out with the wrong sign, fix it. */
2868 if (i2
< 0 ? i1
> 0 : i1
< 0)
2875 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2876 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2877 The value is always a number; markers are converted to numbers.
2878 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2883 return arith_driver (Amax
, nargs
, args
);
2886 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2887 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2888 The value is always a number; markers are converted to numbers.
2889 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2894 return arith_driver (Amin
, nargs
, args
);
2897 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2898 doc
: /* Return bitwise-and of all the arguments.
2899 Arguments may be integers, or markers converted to integers.
2900 usage: (logand &rest INTS-OR-MARKERS) */)
2905 return arith_driver (Alogand
, nargs
, args
);
2908 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2909 doc
: /* Return bitwise-or of all the arguments.
2910 Arguments may be integers, or markers converted to integers.
2911 usage: (logior &rest INTS-OR-MARKERS) */)
2916 return arith_driver (Alogior
, nargs
, args
);
2919 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2920 doc
: /* Return bitwise-exclusive-or of all the arguments.
2921 Arguments may be integers, or markers converted to integers.
2922 usage: (logxor &rest INTS-OR-MARKERS) */)
2927 return arith_driver (Alogxor
, nargs
, args
);
2930 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2931 doc
: /* Return VALUE with its bits shifted left by COUNT.
2932 If COUNT is negative, shifting is actually to the right.
2933 In this case, the sign bit is duplicated. */)
2935 register Lisp_Object value
, count
;
2937 register Lisp_Object val
;
2939 CHECK_NUMBER (value
);
2940 CHECK_NUMBER (count
);
2942 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2944 else if (XINT (count
) > 0)
2945 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2946 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2947 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2949 XSETINT (val
, XINT (value
) >> -XINT (count
));
2953 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2954 doc
: /* Return VALUE with its bits shifted left by COUNT.
2955 If COUNT is negative, shifting is actually to the right.
2956 In this case, zeros are shifted in on the left. */)
2958 register Lisp_Object value
, count
;
2960 register Lisp_Object val
;
2962 CHECK_NUMBER (value
);
2963 CHECK_NUMBER (count
);
2965 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2967 else if (XINT (count
) > 0)
2968 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2969 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2972 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2976 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2977 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2978 Markers are converted to integers. */)
2980 register Lisp_Object number
;
2982 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2984 if (FLOATP (number
))
2985 return (make_float (1.0 + XFLOAT_DATA (number
)));
2987 XSETINT (number
, XINT (number
) + 1);
2991 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2992 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2993 Markers are converted to integers. */)
2995 register Lisp_Object number
;
2997 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2999 if (FLOATP (number
))
3000 return (make_float (-1.0 + XFLOAT_DATA (number
)));
3002 XSETINT (number
, XINT (number
) - 1);
3006 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
3007 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3009 register Lisp_Object number
;
3011 CHECK_NUMBER (number
);
3012 XSETINT (number
, ~XINT (number
));
3016 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
3017 doc
: /* Return the byteorder for the machine.
3018 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3019 lowercase l) for small endian machines. */)
3022 unsigned i
= 0x04030201;
3023 int order
= *(char *)&i
== 1 ? 108 : 66;
3025 return make_number (order
);
3033 Lisp_Object error_tail
, arith_tail
;
3035 Qquote
= intern_c_string ("quote");
3036 Qlambda
= intern_c_string ("lambda");
3037 Qsubr
= intern_c_string ("subr");
3038 Qerror_conditions
= intern_c_string ("error-conditions");
3039 Qerror_message
= intern_c_string ("error-message");
3040 Qtop_level
= intern_c_string ("top-level");
3042 Qerror
= intern_c_string ("error");
3043 Qquit
= intern_c_string ("quit");
3044 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
3045 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
3046 Qvoid_function
= intern_c_string ("void-function");
3047 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
3048 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
3049 Qvoid_variable
= intern_c_string ("void-variable");
3050 Qsetting_constant
= intern_c_string ("setting-constant");
3051 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
3053 Qinvalid_function
= intern_c_string ("invalid-function");
3054 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
3055 Qno_catch
= intern_c_string ("no-catch");
3056 Qend_of_file
= intern_c_string ("end-of-file");
3057 Qarith_error
= intern_c_string ("arith-error");
3058 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
3059 Qend_of_buffer
= intern_c_string ("end-of-buffer");
3060 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
3061 Qtext_read_only
= intern_c_string ("text-read-only");
3062 Qmark_inactive
= intern_c_string ("mark-inactive");
3064 Qlistp
= intern_c_string ("listp");
3065 Qconsp
= intern_c_string ("consp");
3066 Qsymbolp
= intern_c_string ("symbolp");
3067 Qkeywordp
= intern_c_string ("keywordp");
3068 Qintegerp
= intern_c_string ("integerp");
3069 Qnatnump
= intern_c_string ("natnump");
3070 Qwholenump
= intern_c_string ("wholenump");
3071 Qstringp
= intern_c_string ("stringp");
3072 Qarrayp
= intern_c_string ("arrayp");
3073 Qsequencep
= intern_c_string ("sequencep");
3074 Qbufferp
= intern_c_string ("bufferp");
3075 Qvectorp
= intern_c_string ("vectorp");
3076 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
3077 Qmarkerp
= intern_c_string ("markerp");
3078 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
3079 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
3080 Qboundp
= intern_c_string ("boundp");
3081 Qfboundp
= intern_c_string ("fboundp");
3083 Qfloatp
= intern_c_string ("floatp");
3084 Qnumberp
= intern_c_string ("numberp");
3085 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
3087 Qchar_table_p
= intern_c_string ("char-table-p");
3088 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
3090 Qsubrp
= intern_c_string ("subrp");
3091 Qunevalled
= intern_c_string ("unevalled");
3092 Qmany
= intern_c_string ("many");
3094 Qcdr
= intern_c_string ("cdr");
3096 /* Handle automatic advice activation */
3097 Qad_advice_info
= intern_c_string ("ad-advice-info");
3098 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
3100 error_tail
= pure_cons (Qerror
, Qnil
);
3102 /* ERROR is used as a signaler for random errors for which nothing else is right */
3104 Fput (Qerror
, Qerror_conditions
,
3106 Fput (Qerror
, Qerror_message
,
3107 make_pure_c_string ("error"));
3109 Fput (Qquit
, Qerror_conditions
,
3110 pure_cons (Qquit
, Qnil
));
3111 Fput (Qquit
, Qerror_message
,
3112 make_pure_c_string ("Quit"));
3114 Fput (Qwrong_type_argument
, Qerror_conditions
,
3115 pure_cons (Qwrong_type_argument
, error_tail
));
3116 Fput (Qwrong_type_argument
, Qerror_message
,
3117 make_pure_c_string ("Wrong type argument"));
3119 Fput (Qargs_out_of_range
, Qerror_conditions
,
3120 pure_cons (Qargs_out_of_range
, error_tail
));
3121 Fput (Qargs_out_of_range
, Qerror_message
,
3122 make_pure_c_string ("Args out of range"));
3124 Fput (Qvoid_function
, Qerror_conditions
,
3125 pure_cons (Qvoid_function
, error_tail
));
3126 Fput (Qvoid_function
, Qerror_message
,
3127 make_pure_c_string ("Symbol's function definition is void"));
3129 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3130 pure_cons (Qcyclic_function_indirection
, error_tail
));
3131 Fput (Qcyclic_function_indirection
, Qerror_message
,
3132 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3134 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3135 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3136 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3137 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3139 Qcircular_list
= intern_c_string ("circular-list");
3140 staticpro (&Qcircular_list
);
3141 Fput (Qcircular_list
, Qerror_conditions
,
3142 pure_cons (Qcircular_list
, error_tail
));
3143 Fput (Qcircular_list
, Qerror_message
,
3144 make_pure_c_string ("List contains a loop"));
3146 Fput (Qvoid_variable
, Qerror_conditions
,
3147 pure_cons (Qvoid_variable
, error_tail
));
3148 Fput (Qvoid_variable
, Qerror_message
,
3149 make_pure_c_string ("Symbol's value as variable is void"));
3151 Fput (Qsetting_constant
, Qerror_conditions
,
3152 pure_cons (Qsetting_constant
, error_tail
));
3153 Fput (Qsetting_constant
, Qerror_message
,
3154 make_pure_c_string ("Attempt to set a constant symbol"));
3156 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3157 pure_cons (Qinvalid_read_syntax
, error_tail
));
3158 Fput (Qinvalid_read_syntax
, Qerror_message
,
3159 make_pure_c_string ("Invalid read syntax"));
3161 Fput (Qinvalid_function
, Qerror_conditions
,
3162 pure_cons (Qinvalid_function
, error_tail
));
3163 Fput (Qinvalid_function
, Qerror_message
,
3164 make_pure_c_string ("Invalid function"));
3166 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3167 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3168 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3169 make_pure_c_string ("Wrong number of arguments"));
3171 Fput (Qno_catch
, Qerror_conditions
,
3172 pure_cons (Qno_catch
, error_tail
));
3173 Fput (Qno_catch
, Qerror_message
,
3174 make_pure_c_string ("No catch for tag"));
3176 Fput (Qend_of_file
, Qerror_conditions
,
3177 pure_cons (Qend_of_file
, error_tail
));
3178 Fput (Qend_of_file
, Qerror_message
,
3179 make_pure_c_string ("End of file during parsing"));
3181 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3182 Fput (Qarith_error
, Qerror_conditions
,
3184 Fput (Qarith_error
, Qerror_message
,
3185 make_pure_c_string ("Arithmetic error"));
3187 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3188 pure_cons (Qbeginning_of_buffer
, error_tail
));
3189 Fput (Qbeginning_of_buffer
, Qerror_message
,
3190 make_pure_c_string ("Beginning of buffer"));
3192 Fput (Qend_of_buffer
, Qerror_conditions
,
3193 pure_cons (Qend_of_buffer
, error_tail
));
3194 Fput (Qend_of_buffer
, Qerror_message
,
3195 make_pure_c_string ("End of buffer"));
3197 Fput (Qbuffer_read_only
, Qerror_conditions
,
3198 pure_cons (Qbuffer_read_only
, error_tail
));
3199 Fput (Qbuffer_read_only
, Qerror_message
,
3200 make_pure_c_string ("Buffer is read-only"));
3202 Fput (Qtext_read_only
, Qerror_conditions
,
3203 pure_cons (Qtext_read_only
, error_tail
));
3204 Fput (Qtext_read_only
, Qerror_message
,
3205 make_pure_c_string ("Text is read-only"));
3207 Qrange_error
= intern_c_string ("range-error");
3208 Qdomain_error
= intern_c_string ("domain-error");
3209 Qsingularity_error
= intern_c_string ("singularity-error");
3210 Qoverflow_error
= intern_c_string ("overflow-error");
3211 Qunderflow_error
= intern_c_string ("underflow-error");
3213 Fput (Qdomain_error
, Qerror_conditions
,
3214 pure_cons (Qdomain_error
, arith_tail
));
3215 Fput (Qdomain_error
, Qerror_message
,
3216 make_pure_c_string ("Arithmetic domain error"));
3218 Fput (Qrange_error
, Qerror_conditions
,
3219 pure_cons (Qrange_error
, arith_tail
));
3220 Fput (Qrange_error
, Qerror_message
,
3221 make_pure_c_string ("Arithmetic range error"));
3223 Fput (Qsingularity_error
, Qerror_conditions
,
3224 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3225 Fput (Qsingularity_error
, Qerror_message
,
3226 make_pure_c_string ("Arithmetic singularity error"));
3228 Fput (Qoverflow_error
, Qerror_conditions
,
3229 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3230 Fput (Qoverflow_error
, Qerror_message
,
3231 make_pure_c_string ("Arithmetic overflow error"));
3233 Fput (Qunderflow_error
, Qerror_conditions
,
3234 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3235 Fput (Qunderflow_error
, Qerror_message
,
3236 make_pure_c_string ("Arithmetic underflow error"));
3238 staticpro (&Qrange_error
);
3239 staticpro (&Qdomain_error
);
3240 staticpro (&Qsingularity_error
);
3241 staticpro (&Qoverflow_error
);
3242 staticpro (&Qunderflow_error
);
3246 staticpro (&Qquote
);
3247 staticpro (&Qlambda
);
3249 staticpro (&Qunbound
);
3250 staticpro (&Qerror_conditions
);
3251 staticpro (&Qerror_message
);
3252 staticpro (&Qtop_level
);
3254 staticpro (&Qerror
);
3256 staticpro (&Qwrong_type_argument
);
3257 staticpro (&Qargs_out_of_range
);
3258 staticpro (&Qvoid_function
);
3259 staticpro (&Qcyclic_function_indirection
);
3260 staticpro (&Qcyclic_variable_indirection
);
3261 staticpro (&Qvoid_variable
);
3262 staticpro (&Qsetting_constant
);
3263 staticpro (&Qinvalid_read_syntax
);
3264 staticpro (&Qwrong_number_of_arguments
);
3265 staticpro (&Qinvalid_function
);
3266 staticpro (&Qno_catch
);
3267 staticpro (&Qend_of_file
);
3268 staticpro (&Qarith_error
);
3269 staticpro (&Qbeginning_of_buffer
);
3270 staticpro (&Qend_of_buffer
);
3271 staticpro (&Qbuffer_read_only
);
3272 staticpro (&Qtext_read_only
);
3273 staticpro (&Qmark_inactive
);
3275 staticpro (&Qlistp
);
3276 staticpro (&Qconsp
);
3277 staticpro (&Qsymbolp
);
3278 staticpro (&Qkeywordp
);
3279 staticpro (&Qintegerp
);
3280 staticpro (&Qnatnump
);
3281 staticpro (&Qwholenump
);
3282 staticpro (&Qstringp
);
3283 staticpro (&Qarrayp
);
3284 staticpro (&Qsequencep
);
3285 staticpro (&Qbufferp
);
3286 staticpro (&Qvectorp
);
3287 staticpro (&Qchar_or_string_p
);
3288 staticpro (&Qmarkerp
);
3289 staticpro (&Qbuffer_or_string_p
);
3290 staticpro (&Qinteger_or_marker_p
);
3291 staticpro (&Qfloatp
);
3292 staticpro (&Qnumberp
);
3293 staticpro (&Qnumber_or_marker_p
);
3294 staticpro (&Qchar_table_p
);
3295 staticpro (&Qvector_or_char_table_p
);
3296 staticpro (&Qsubrp
);
3298 staticpro (&Qunevalled
);
3300 staticpro (&Qboundp
);
3301 staticpro (&Qfboundp
);
3303 staticpro (&Qad_advice_info
);
3304 staticpro (&Qad_activate_internal
);
3306 /* Types that type-of returns. */
3307 Qinteger
= intern_c_string ("integer");
3308 Qsymbol
= intern_c_string ("symbol");
3309 Qstring
= intern_c_string ("string");
3310 Qcons
= intern_c_string ("cons");
3311 Qmarker
= intern_c_string ("marker");
3312 Qoverlay
= intern_c_string ("overlay");
3313 Qfloat
= intern_c_string ("float");
3314 Qwindow_configuration
= intern_c_string ("window-configuration");
3315 Qprocess
= intern_c_string ("process");
3316 Qwindow
= intern_c_string ("window");
3317 /* Qsubr = intern_c_string ("subr"); */
3318 Qcompiled_function
= intern_c_string ("compiled-function");
3319 Qbuffer
= intern_c_string ("buffer");
3320 Qframe
= intern_c_string ("frame");
3321 Qvector
= intern_c_string ("vector");
3322 Qchar_table
= intern_c_string ("char-table");
3323 Qbool_vector
= intern_c_string ("bool-vector");
3324 Qhash_table
= intern_c_string ("hash-table");
3326 DEFSYM (Qfont_spec
, "font-spec");
3327 DEFSYM (Qfont_entity
, "font-entity");
3328 DEFSYM (Qfont_object
, "font-object");
3330 DEFSYM (Qinteractive_form
, "interactive-form");
3332 staticpro (&Qinteger
);
3333 staticpro (&Qsymbol
);
3334 staticpro (&Qstring
);
3336 staticpro (&Qmarker
);
3337 staticpro (&Qoverlay
);
3338 staticpro (&Qfloat
);
3339 staticpro (&Qwindow_configuration
);
3340 staticpro (&Qprocess
);
3341 staticpro (&Qwindow
);
3342 /* staticpro (&Qsubr); */
3343 staticpro (&Qcompiled_function
);
3344 staticpro (&Qbuffer
);
3345 staticpro (&Qframe
);
3346 staticpro (&Qvector
);
3347 staticpro (&Qchar_table
);
3348 staticpro (&Qbool_vector
);
3349 staticpro (&Qhash_table
);
3351 defsubr (&Sindirect_variable
);
3352 defsubr (&Sinteractive_form
);
3355 defsubr (&Stype_of
);
3360 defsubr (&Sintegerp
);
3361 defsubr (&Sinteger_or_marker_p
);
3362 defsubr (&Snumberp
);
3363 defsubr (&Snumber_or_marker_p
);
3365 defsubr (&Snatnump
);
3366 defsubr (&Ssymbolp
);
3367 defsubr (&Skeywordp
);
3368 defsubr (&Sstringp
);
3369 defsubr (&Smultibyte_string_p
);
3370 defsubr (&Svectorp
);
3371 defsubr (&Schar_table_p
);
3372 defsubr (&Svector_or_char_table_p
);
3373 defsubr (&Sbool_vector_p
);
3375 defsubr (&Ssequencep
);
3376 defsubr (&Sbufferp
);
3377 defsubr (&Smarkerp
);
3379 defsubr (&Sbyte_code_function_p
);
3380 defsubr (&Schar_or_string_p
);
3383 defsubr (&Scar_safe
);
3384 defsubr (&Scdr_safe
);
3387 defsubr (&Ssymbol_function
);
3388 defsubr (&Sindirect_function
);
3389 defsubr (&Ssymbol_plist
);
3390 defsubr (&Ssymbol_name
);
3391 defsubr (&Smakunbound
);
3392 defsubr (&Sfmakunbound
);
3394 defsubr (&Sfboundp
);
3396 defsubr (&Sdefalias
);
3397 defsubr (&Ssetplist
);
3398 defsubr (&Ssymbol_value
);
3400 defsubr (&Sdefault_boundp
);
3401 defsubr (&Sdefault_value
);
3402 defsubr (&Sset_default
);
3403 defsubr (&Ssetq_default
);
3404 defsubr (&Smake_variable_buffer_local
);
3405 defsubr (&Smake_local_variable
);
3406 defsubr (&Skill_local_variable
);
3407 defsubr (&Smake_variable_frame_local
);
3408 defsubr (&Slocal_variable_p
);
3409 defsubr (&Slocal_variable_if_set_p
);
3410 defsubr (&Svariable_binding_locus
);
3411 #if 0 /* XXX Remove this. --lorentey */
3412 defsubr (&Sterminal_local_value
);
3413 defsubr (&Sset_terminal_local_value
);
3417 defsubr (&Snumber_to_string
);
3418 defsubr (&Sstring_to_number
);
3419 defsubr (&Seqlsign
);
3442 defsubr (&Sbyteorder
);
3443 defsubr (&Ssubr_arity
);
3444 defsubr (&Ssubr_name
);
3446 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3448 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3449 doc
: /* The largest value that is representable in a Lisp integer. */);
3450 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3451 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3453 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3454 doc
: /* The smallest value that is representable in a Lisp integer. */);
3455 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3456 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3463 sigsetmask (SIGEMPTYMASK
);
3465 SIGNAL_THREAD_CHECK (signo
);
3466 xsignal0 (Qarith_error
);
3472 /* Don't do this if just dumping out.
3473 We don't want to call `signal' in this case
3474 so that we don't have trouble with dumping
3475 signal-delivering routines in an inconsistent state. */
3479 #endif /* CANNOT_DUMP */
3480 signal (SIGFPE
, arith_error
);
3483 signal (SIGEMT
, arith_error
);
3487 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3488 (do not change this comment) */