1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 #include "character.h"
34 #include "syssignal.h"
35 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
42 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
43 #ifndef IEEE_FLOATING_POINT
44 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
45 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
46 #define IEEE_FLOATING_POINT 1
48 #define IEEE_FLOATING_POINT 0
54 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qunbound
;
55 static Lisp_Object Qsubr
;
56 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
57 Lisp_Object Qerror
, Qquit
, Qargs_out_of_range
;
58 static Lisp_Object Qwrong_type_argument
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
;
60 static Lisp_Object Qcyclic_function_indirection
;
61 static Lisp_Object Qcyclic_variable_indirection
;
62 Lisp_Object Qcircular_list
;
63 static Lisp_Object Qsetting_constant
;
64 Lisp_Object Qinvalid_read_syntax
;
65 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
66 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
67 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
68 Lisp_Object Qtext_read_only
;
70 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
71 static Lisp_Object Qnatnump
;
72 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
73 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
74 Lisp_Object Qbuffer_or_string_p
;
75 static Lisp_Object Qkeywordp
, Qboundp
;
77 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
80 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
82 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
83 Lisp_Object Qoverflow_error
, Qunderflow_error
;
86 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
89 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
91 static Lisp_Object Qfloat
, Qwindow_configuration
;
92 static Lisp_Object Qprocess
, Qcompiled_function
;
93 Lisp_Object Qbuffer
, Qframe
, Qvector
;
94 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
95 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
96 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
98 Lisp_Object Qinteractive_form
;
100 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
104 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
106 /* If VALUE is not even a valid Lisp object, we'd want to abort here
107 where we can get a backtrace showing where it came from. We used
108 to try and do that by checking the tagbits, but nowadays all
109 tagbits are potentially valid. */
110 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
113 xsignal2 (Qwrong_type_argument
, predicate
, value
);
117 pure_write_error (void)
119 error ("Attempt to modify read-only object");
123 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
125 xsignal2 (Qargs_out_of_range
, a1
, a2
);
129 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
131 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
135 /* Data type predicates */
137 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
138 doc
: /* Return t if the two args are the same Lisp object. */)
139 (Lisp_Object obj1
, Lisp_Object obj2
)
146 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
147 doc
: /* Return t if OBJECT is nil. */)
155 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
156 doc
: /* Return a symbol representing the type of OBJECT.
157 The symbol returned names the object's basic type;
158 for example, (type-of 1) returns `integer'. */)
161 switch (XTYPE (object
))
176 switch (XMISCTYPE (object
))
178 case Lisp_Misc_Marker
:
180 case Lisp_Misc_Overlay
:
182 case Lisp_Misc_Float
:
187 case Lisp_Vectorlike
:
188 if (WINDOW_CONFIGURATIONP (object
))
189 return Qwindow_configuration
;
190 if (PROCESSP (object
))
192 if (WINDOWP (object
))
196 if (COMPILEDP (object
))
197 return Qcompiled_function
;
198 if (BUFFERP (object
))
200 if (CHAR_TABLE_P (object
))
202 if (BOOL_VECTOR_P (object
))
206 if (HASH_TABLE_P (object
))
208 if (FONT_SPEC_P (object
))
210 if (FONT_ENTITY_P (object
))
212 if (FONT_OBJECT_P (object
))
224 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
225 doc
: /* Return t if OBJECT is a cons cell. */)
233 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
234 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
242 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
243 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
244 Otherwise, return nil. */)
247 if (CONSP (object
) || NILP (object
))
252 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
253 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
256 if (CONSP (object
) || NILP (object
))
261 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
262 doc
: /* Return t if OBJECT is a symbol. */)
265 if (SYMBOLP (object
))
270 /* Define this in C to avoid unnecessarily consing up the symbol
272 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
273 doc
: /* Return t if OBJECT is a keyword.
274 This means that it is a symbol with a print name beginning with `:'
275 interned in the initial obarray. */)
279 && SREF (SYMBOL_NAME (object
), 0) == ':'
280 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
285 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
286 doc
: /* Return t if OBJECT is a vector. */)
289 if (VECTORP (object
))
294 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
295 doc
: /* Return t if OBJECT is a string. */)
298 if (STRINGP (object
))
303 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
305 doc
: /* Return t if OBJECT is a multibyte string. */)
308 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
313 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
314 doc
: /* Return t if OBJECT is a char-table. */)
317 if (CHAR_TABLE_P (object
))
322 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
323 Svector_or_char_table_p
, 1, 1, 0,
324 doc
: /* Return t if OBJECT is a char-table or vector. */)
327 if (VECTORP (object
) || CHAR_TABLE_P (object
))
332 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
333 doc
: /* Return t if OBJECT is a bool-vector. */)
336 if (BOOL_VECTOR_P (object
))
341 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
342 doc
: /* Return t if OBJECT is an array (string or vector). */)
350 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
351 doc
: /* Return t if OBJECT is a sequence (list or array). */)
352 (register Lisp_Object object
)
354 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
359 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
360 doc
: /* Return t if OBJECT is an editor buffer. */)
363 if (BUFFERP (object
))
368 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
369 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
372 if (MARKERP (object
))
377 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is a built-in function. */)
386 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
388 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
391 if (COMPILEDP (object
))
396 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is a character or a string. */)
398 (register Lisp_Object object
)
400 if (CHARACTERP (object
) || STRINGP (object
))
405 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
406 doc
: /* Return t if OBJECT is an integer. */)
409 if (INTEGERP (object
))
414 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
416 (register Lisp_Object object
)
418 if (MARKERP (object
) || INTEGERP (object
))
423 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
424 doc
: /* Return t if OBJECT is a nonnegative integer. */)
427 if (NATNUMP (object
))
432 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
433 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
436 if (NUMBERP (object
))
442 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
443 Snumber_or_marker_p
, 1, 1, 0,
444 doc
: /* Return t if OBJECT is a number or a marker. */)
447 if (NUMBERP (object
) || MARKERP (object
))
452 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
453 doc
: /* Return t if OBJECT is a floating point number. */)
462 /* Extract and set components of lists */
464 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
465 doc
: /* Return the car of LIST. If arg is nil, return nil.
466 Error if arg is not nil and not a cons cell. See also `car-safe'.
468 See Info node `(elisp)Cons Cells' for a discussion of related basic
469 Lisp concepts such as car, cdr, cons cell and list. */)
470 (register Lisp_Object list
)
475 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
476 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
479 return CAR_SAFE (object
);
482 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
483 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
484 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
486 See Info node `(elisp)Cons Cells' for a discussion of related basic
487 Lisp concepts such as cdr, car, cons cell and list. */)
488 (register Lisp_Object list
)
493 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
494 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
497 return CDR_SAFE (object
);
500 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
501 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
502 (register Lisp_Object cell
, Lisp_Object newcar
)
506 XSETCAR (cell
, newcar
);
510 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
511 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
512 (register Lisp_Object cell
, Lisp_Object newcdr
)
516 XSETCDR (cell
, newcdr
);
520 /* Extract and set components of symbols */
522 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
523 doc
: /* Return t if SYMBOL's value is not void. */)
524 (register Lisp_Object symbol
)
526 Lisp_Object valcontents
;
527 struct Lisp_Symbol
*sym
;
528 CHECK_SYMBOL (symbol
);
529 sym
= XSYMBOL (symbol
);
532 switch (sym
->redirect
)
534 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
535 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
536 case SYMBOL_LOCALIZED
:
538 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
540 /* In set_internal, we un-forward vars when their value is
545 swap_in_symval_forwarding (sym
, blv
);
546 valcontents
= BLV_VALUE (blv
);
550 case SYMBOL_FORWARDED
:
551 /* In set_internal, we un-forward vars when their value is
557 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
560 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
561 doc
: /* Return t if SYMBOL's function definition is not void. */)
562 (register Lisp_Object symbol
)
564 CHECK_SYMBOL (symbol
);
565 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
568 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
569 doc
: /* Make SYMBOL's value be void.
571 (register Lisp_Object symbol
)
573 CHECK_SYMBOL (symbol
);
574 if (SYMBOL_CONSTANT_P (symbol
))
575 xsignal1 (Qsetting_constant
, symbol
);
576 Fset (symbol
, Qunbound
);
580 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
581 doc
: /* Make SYMBOL's function definition be void.
583 (register Lisp_Object symbol
)
585 CHECK_SYMBOL (symbol
);
586 if (NILP (symbol
) || EQ (symbol
, Qt
))
587 xsignal1 (Qsetting_constant
, symbol
);
588 XSYMBOL (symbol
)->function
= Qunbound
;
592 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
593 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
594 (register Lisp_Object symbol
)
596 CHECK_SYMBOL (symbol
);
597 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
598 return XSYMBOL (symbol
)->function
;
599 xsignal1 (Qvoid_function
, symbol
);
602 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
603 doc
: /* Return SYMBOL's property list. */)
604 (register Lisp_Object symbol
)
606 CHECK_SYMBOL (symbol
);
607 return XSYMBOL (symbol
)->plist
;
610 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
611 doc
: /* Return SYMBOL's name, a string. */)
612 (register Lisp_Object symbol
)
614 register Lisp_Object name
;
616 CHECK_SYMBOL (symbol
);
617 name
= SYMBOL_NAME (symbol
);
621 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
622 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
623 (register Lisp_Object symbol
, Lisp_Object definition
)
625 register Lisp_Object function
;
627 CHECK_SYMBOL (symbol
);
628 if (NILP (symbol
) || EQ (symbol
, Qt
))
629 xsignal1 (Qsetting_constant
, symbol
);
631 function
= XSYMBOL (symbol
)->function
;
633 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
634 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
636 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
637 Fput (symbol
, Qautoload
, XCDR (function
));
639 XSYMBOL (symbol
)->function
= definition
;
640 /* Handle automatic advice activation */
641 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
643 call2 (Qad_activate_internal
, symbol
, Qnil
);
644 definition
= XSYMBOL (symbol
)->function
;
649 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
650 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
651 Associates the function with the current load file, if any.
652 The optional third argument DOCSTRING specifies the documentation string
653 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
654 determined by DEFINITION. */)
655 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
657 CHECK_SYMBOL (symbol
);
658 if (CONSP (XSYMBOL (symbol
)->function
)
659 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
660 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
661 definition
= Ffset (symbol
, definition
);
662 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
663 if (!NILP (docstring
))
664 Fput (symbol
, Qfunction_documentation
, docstring
);
668 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
669 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
670 (register Lisp_Object symbol
, Lisp_Object newplist
)
672 CHECK_SYMBOL (symbol
);
673 XSYMBOL (symbol
)->plist
= newplist
;
677 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
678 doc
: /* Return minimum and maximum number of args allowed for SUBR.
679 SUBR must be a built-in function.
680 The returned value is a pair (MIN . MAX). MIN is the minimum number
681 of args. MAX is the maximum number or the symbol `many', for a
682 function with `&rest' args, or `unevalled' for a special form. */)
685 short minargs
, maxargs
;
687 minargs
= XSUBR (subr
)->min_args
;
688 maxargs
= XSUBR (subr
)->max_args
;
690 return Fcons (make_number (minargs
), Qmany
);
691 else if (maxargs
== UNEVALLED
)
692 return Fcons (make_number (minargs
), Qunevalled
);
694 return Fcons (make_number (minargs
), make_number (maxargs
));
697 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
698 doc
: /* Return name of subroutine SUBR.
699 SUBR must be a built-in function. */)
704 name
= XSUBR (subr
)->symbol_name
;
705 return make_string (name
, strlen (name
));
708 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
709 doc
: /* Return the interactive form of CMD or nil if none.
710 If CMD is not a command, the return value is nil.
711 Value, if non-nil, is a list \(interactive SPEC). */)
714 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
716 if (NILP (fun
) || EQ (fun
, Qunbound
))
719 /* Use an `interactive-form' property if present, analogous to the
720 function-documentation property. */
722 while (SYMBOLP (fun
))
724 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
728 fun
= Fsymbol_function (fun
);
733 const char *spec
= XSUBR (fun
)->intspec
;
735 return list2 (Qinteractive
,
736 (*spec
!= '(') ? build_string (spec
) :
737 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
739 else if (COMPILEDP (fun
))
741 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
742 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
744 else if (CONSP (fun
))
746 Lisp_Object funcar
= XCAR (fun
);
747 if (EQ (funcar
, Qclosure
))
748 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
749 else if (EQ (funcar
, Qlambda
))
750 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
751 else if (EQ (funcar
, Qautoload
))
755 do_autoload (fun
, cmd
);
757 return Finteractive_form (cmd
);
764 /***********************************************************************
765 Getting and Setting Values of Symbols
766 ***********************************************************************/
768 /* Return the symbol holding SYMBOL's value. Signal
769 `cyclic-variable-indirection' if SYMBOL's chain of variable
770 indirections contains a loop. */
773 indirect_variable (struct Lisp_Symbol
*symbol
)
775 struct Lisp_Symbol
*tortoise
, *hare
;
777 hare
= tortoise
= symbol
;
779 while (hare
->redirect
== SYMBOL_VARALIAS
)
781 hare
= SYMBOL_ALIAS (hare
);
782 if (hare
->redirect
!= SYMBOL_VARALIAS
)
785 hare
= SYMBOL_ALIAS (hare
);
786 tortoise
= SYMBOL_ALIAS (tortoise
);
788 if (hare
== tortoise
)
791 XSETSYMBOL (tem
, symbol
);
792 xsignal1 (Qcyclic_variable_indirection
, tem
);
800 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
801 doc
: /* Return the variable at the end of OBJECT's variable chain.
802 If OBJECT is a symbol, follow all variable indirections and return the final
803 variable. If OBJECT is not a symbol, just return it.
804 Signal a cyclic-variable-indirection error if there is a loop in the
805 variable chain of symbols. */)
808 if (SYMBOLP (object
))
810 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
811 XSETSYMBOL (object
, sym
);
817 /* Given the raw contents of a symbol value cell,
818 return the Lisp value of the symbol.
819 This does not handle buffer-local variables; use
820 swap_in_symval_forwarding for that. */
823 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
825 register Lisp_Object val
;
826 switch (XFWDTYPE (valcontents
))
829 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
833 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
836 return *XOBJFWD (valcontents
)->objvar
;
838 case Lisp_Fwd_Buffer_Obj
:
839 return PER_BUFFER_VALUE (current_buffer
,
840 XBUFFER_OBJFWD (valcontents
)->offset
);
842 case Lisp_Fwd_Kboard_Obj
:
843 /* We used to simply use current_kboard here, but from Lisp
844 code, it's value is often unexpected. It seems nicer to
845 allow constructions like this to work as intuitively expected:
847 (with-selected-frame frame
848 (define-key local-function-map "\eOP" [f1]))
850 On the other hand, this affects the semantics of
851 last-command and real-last-command, and people may rely on
852 that. I took a quick look at the Lisp codebase, and I
853 don't think anything will break. --lorentey */
854 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
855 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
860 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
861 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
862 buffer-independent contents of the value cell: forwarded just one
863 step past the buffer-localness.
865 BUF non-zero means set the value in buffer BUF instead of the
866 current buffer. This only plays a role for per-buffer variables. */
869 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
871 switch (XFWDTYPE (valcontents
))
874 CHECK_NUMBER (newval
);
875 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
879 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
883 *XOBJFWD (valcontents
)->objvar
= newval
;
885 /* If this variable is a default for something stored
886 in the buffer itself, such as default-fill-column,
887 find the buffers that don't have local values for it
889 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
890 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
892 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
893 - (char *) &buffer_defaults
);
894 int idx
= PER_BUFFER_IDX (offset
);
901 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
906 lbuf
= Fcdr (XCAR (tail
));
907 if (!BUFFERP (lbuf
)) continue;
910 if (! PER_BUFFER_VALUE_P (b
, idx
))
911 PER_BUFFER_VALUE (b
, offset
) = newval
;
916 case Lisp_Fwd_Buffer_Obj
:
918 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
919 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
921 if (!(NILP (type
) || NILP (newval
)
922 || (XINT (type
) == LISP_INT_TAG
924 : XTYPE (newval
) == XINT (type
))))
925 buffer_slot_type_mismatch (newval
, XINT (type
));
928 buf
= current_buffer
;
929 PER_BUFFER_VALUE (buf
, offset
) = newval
;
933 case Lisp_Fwd_Kboard_Obj
:
935 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
936 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
937 *(Lisp_Object
*) p
= newval
;
942 abort (); /* goto def; */
946 /* Set up SYMBOL to refer to its global binding.
947 This makes it safe to alter the status of other bindings. */
950 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
952 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
954 /* Unload the previously loaded binding. */
956 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
958 /* Select the global binding in the symbol. */
959 blv
->valcell
= blv
->defcell
;
961 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
963 /* Indicate that the global binding is set up now. */
965 SET_BLV_FOUND (blv
, 0);
968 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
969 VALCONTENTS is the contents of its value cell,
970 which points to a struct Lisp_Buffer_Local_Value.
972 Return the value forwarded one step past the buffer-local stage.
973 This could be another forwarding pointer. */
976 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
978 register Lisp_Object tem1
;
980 eassert (blv
== SYMBOL_BLV (symbol
));
986 ? !EQ (selected_frame
, tem1
)
987 : current_buffer
!= XBUFFER (tem1
)))
990 /* Unload the previously loaded binding. */
993 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
994 /* Choose the new binding. */
997 XSETSYMBOL (var
, symbol
);
998 if (blv
->frame_local
)
1000 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1001 blv
->where
= selected_frame
;
1005 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1006 XSETBUFFER (blv
->where
, current_buffer
);
1009 if (!(blv
->found
= !NILP (tem1
)))
1010 tem1
= blv
->defcell
;
1012 /* Load the new binding. */
1013 blv
->valcell
= tem1
;
1015 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1019 /* Find the value of a symbol, returning Qunbound if it's not bound.
1020 This is helpful for code which just wants to get a variable's value
1021 if it has one, without signaling an error.
1022 Note that it must not be possible to quit
1023 within this function. Great care is required for this. */
1026 find_symbol_value (Lisp_Object symbol
)
1028 struct Lisp_Symbol
*sym
;
1030 CHECK_SYMBOL (symbol
);
1031 sym
= XSYMBOL (symbol
);
1034 switch (sym
->redirect
)
1036 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1037 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1038 case SYMBOL_LOCALIZED
:
1040 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1041 swap_in_symval_forwarding (sym
, blv
);
1042 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1045 case SYMBOL_FORWARDED
:
1046 return do_symval_forwarding (SYMBOL_FWD (sym
));
1051 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1052 doc
: /* Return SYMBOL's value. Error if that is void. */)
1053 (Lisp_Object symbol
)
1057 val
= find_symbol_value (symbol
);
1058 if (!EQ (val
, Qunbound
))
1061 xsignal1 (Qvoid_variable
, symbol
);
1064 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1065 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1066 (register Lisp_Object symbol
, Lisp_Object newval
)
1068 set_internal (symbol
, newval
, Qnil
, 0);
1072 /* Return 1 if SYMBOL currently has a let-binding
1073 which was made in the buffer that is now current. */
1076 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1078 struct specbinding
*p
;
1080 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1082 && CONSP (p
->symbol
))
1084 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1085 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1086 if (symbol
== let_bound_symbol
1087 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1091 return p
>= specpdl
;
1095 let_shadows_global_binding_p (Lisp_Object symbol
)
1097 struct specbinding
*p
;
1099 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1100 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1103 return p
>= specpdl
;
1106 /* Store the value NEWVAL into SYMBOL.
1107 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1108 (nil stands for the current buffer/frame).
1110 If BINDFLAG is zero, then if this symbol is supposed to become
1111 local in every buffer where it is set, then we make it local.
1112 If BINDFLAG is nonzero, we don't do that. */
1115 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1117 int voide
= EQ (newval
, Qunbound
);
1118 struct Lisp_Symbol
*sym
;
1121 /* If restoring in a dead buffer, do nothing. */
1122 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1125 CHECK_SYMBOL (symbol
);
1126 if (SYMBOL_CONSTANT_P (symbol
))
1128 if (NILP (Fkeywordp (symbol
))
1129 || !EQ (newval
, Fsymbol_value (symbol
)))
1130 xsignal1 (Qsetting_constant
, symbol
);
1132 /* Allow setting keywords to their own value. */
1136 sym
= XSYMBOL (symbol
);
1139 switch (sym
->redirect
)
1141 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1142 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1143 case SYMBOL_LOCALIZED
:
1145 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1148 if (blv
->frame_local
)
1149 where
= selected_frame
;
1151 XSETBUFFER (where
, current_buffer
);
1153 /* If the current buffer is not the buffer whose binding is
1154 loaded, or if there may be frame-local bindings and the frame
1155 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1156 the default binding is loaded, the loaded binding may be the
1158 if (!EQ (blv
->where
, where
)
1159 /* Also unload a global binding (if the var is local_if_set). */
1160 || (EQ (blv
->valcell
, blv
->defcell
)))
1162 /* The currently loaded binding is not necessarily valid.
1163 We need to unload it, and choose a new binding. */
1165 /* Write out `realvalue' to the old loaded binding. */
1167 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1169 /* Find the new binding. */
1170 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1171 tem1
= Fassq (symbol
,
1173 ? XFRAME (where
)->param_alist
1174 : BVAR (XBUFFER (where
), local_var_alist
)));
1180 /* This buffer still sees the default value. */
1182 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1183 or if this is `let' rather than `set',
1184 make CURRENT-ALIST-ELEMENT point to itself,
1185 indicating that we're seeing the default value.
1186 Likewise if the variable has been let-bound
1187 in the current buffer. */
1188 if (bindflag
|| !blv
->local_if_set
1189 || let_shadows_buffer_binding_p (sym
))
1192 tem1
= blv
->defcell
;
1194 /* If it's a local_if_set, being set not bound,
1195 and we're not within a let that was made for this buffer,
1196 create a new buffer-local binding for the variable.
1197 That means, give this buffer a new assoc for a local value
1198 and load that binding. */
1201 /* local_if_set is only supported for buffer-local
1202 bindings, not for frame-local bindings. */
1203 eassert (!blv
->frame_local
);
1204 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1205 BVAR (XBUFFER (where
), local_var_alist
)
1206 = Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
));
1210 /* Record which binding is now loaded. */
1211 blv
->valcell
= tem1
;
1214 /* Store the new value in the cons cell. */
1215 SET_BLV_VALUE (blv
, newval
);
1220 /* If storing void (making the symbol void), forward only through
1221 buffer-local indicator, not through Lisp_Objfwd, etc. */
1224 store_symval_forwarding (blv
->fwd
, newval
,
1226 ? XBUFFER (where
) : current_buffer
);
1230 case SYMBOL_FORWARDED
:
1233 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1234 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1235 if (BUFFER_OBJFWDP (innercontents
))
1237 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1238 int idx
= PER_BUFFER_IDX (offset
);
1241 && !let_shadows_buffer_binding_p (sym
))
1242 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1246 { /* If storing void (making the symbol void), forward only through
1247 buffer-local indicator, not through Lisp_Objfwd, etc. */
1248 sym
->redirect
= SYMBOL_PLAINVAL
;
1249 SET_SYMBOL_VAL (sym
, newval
);
1252 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1260 /* Access or set a buffer-local symbol's default value. */
1262 /* Return the default value of SYMBOL, but don't check for voidness.
1263 Return Qunbound if it is void. */
1266 default_value (Lisp_Object symbol
)
1268 struct Lisp_Symbol
*sym
;
1270 CHECK_SYMBOL (symbol
);
1271 sym
= XSYMBOL (symbol
);
1274 switch (sym
->redirect
)
1276 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1277 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1278 case SYMBOL_LOCALIZED
:
1280 /* If var is set up for a buffer that lacks a local value for it,
1281 the current value is nominally the default value.
1282 But the `realvalue' slot may be more up to date, since
1283 ordinary setq stores just that slot. So use that. */
1284 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1285 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1286 return do_symval_forwarding (blv
->fwd
);
1288 return XCDR (blv
->defcell
);
1290 case SYMBOL_FORWARDED
:
1292 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1294 /* For a built-in buffer-local variable, get the default value
1295 rather than letting do_symval_forwarding get the current value. */
1296 if (BUFFER_OBJFWDP (valcontents
))
1298 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1299 if (PER_BUFFER_IDX (offset
) != 0)
1300 return PER_BUFFER_DEFAULT (offset
);
1303 /* For other variables, get the current value. */
1304 return do_symval_forwarding (valcontents
);
1310 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1311 doc
: /* Return t if SYMBOL has a non-void default value.
1312 This is the value that is seen in buffers that do not have their own values
1313 for this variable. */)
1314 (Lisp_Object symbol
)
1316 register Lisp_Object value
;
1318 value
= default_value (symbol
);
1319 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1322 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1323 doc
: /* Return SYMBOL's default value.
1324 This is the value that is seen in buffers that do not have their own values
1325 for this variable. The default value is meaningful for variables with
1326 local bindings in certain buffers. */)
1327 (Lisp_Object symbol
)
1329 register Lisp_Object value
;
1331 value
= default_value (symbol
);
1332 if (!EQ (value
, Qunbound
))
1335 xsignal1 (Qvoid_variable
, symbol
);
1338 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1339 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1340 The default value is seen in buffers that do not have their own values
1341 for this variable. */)
1342 (Lisp_Object symbol
, Lisp_Object value
)
1344 struct Lisp_Symbol
*sym
;
1346 CHECK_SYMBOL (symbol
);
1347 if (SYMBOL_CONSTANT_P (symbol
))
1349 if (NILP (Fkeywordp (symbol
))
1350 || !EQ (value
, Fdefault_value (symbol
)))
1351 xsignal1 (Qsetting_constant
, symbol
);
1353 /* Allow setting keywords to their own value. */
1356 sym
= XSYMBOL (symbol
);
1359 switch (sym
->redirect
)
1361 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1362 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1363 case SYMBOL_LOCALIZED
:
1365 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1367 /* Store new value into the DEFAULT-VALUE slot. */
1368 XSETCDR (blv
->defcell
, value
);
1370 /* If the default binding is now loaded, set the REALVALUE slot too. */
1371 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1372 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1375 case SYMBOL_FORWARDED
:
1377 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1379 /* Handle variables like case-fold-search that have special slots
1381 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1382 if (BUFFER_OBJFWDP (valcontents
))
1384 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1385 int idx
= PER_BUFFER_IDX (offset
);
1387 PER_BUFFER_DEFAULT (offset
) = value
;
1389 /* If this variable is not always local in all buffers,
1390 set it in the buffers that don't nominally have a local value. */
1395 for (b
= all_buffers
; b
; b
= b
->header
.next
.buffer
)
1396 if (!PER_BUFFER_VALUE_P (b
, idx
))
1397 PER_BUFFER_VALUE (b
, offset
) = value
;
1402 return Fset (symbol
, value
);
1408 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1409 doc
: /* Set the default value of variable VAR to VALUE.
1410 VAR, the variable name, is literal (not evaluated);
1411 VALUE is an expression: it is evaluated and its value returned.
1412 The default value of a variable is seen in buffers
1413 that do not have their own values for the variable.
1415 More generally, you can use multiple variables and values, as in
1416 (setq-default VAR VALUE VAR VALUE...)
1417 This sets each VAR's default value to the corresponding VALUE.
1418 The VALUE for the Nth VAR can refer to the new default values
1420 usage: (setq-default [VAR VALUE]...) */)
1423 register Lisp_Object args_left
;
1424 register Lisp_Object val
, symbol
;
1425 struct gcpro gcpro1
;
1435 val
= eval_sub (Fcar (Fcdr (args_left
)));
1436 symbol
= XCAR (args_left
);
1437 Fset_default (symbol
, val
);
1438 args_left
= Fcdr (XCDR (args_left
));
1440 while (!NILP (args_left
));
1446 /* Lisp functions for creating and removing buffer-local variables. */
1451 union Lisp_Fwd
*fwd
;
1454 static struct Lisp_Buffer_Local_Value
*
1455 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1457 struct Lisp_Buffer_Local_Value
*blv
1458 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1462 XSETSYMBOL (symbol
, sym
);
1463 tem
= Fcons (symbol
, (forwarded
1464 ? do_symval_forwarding (valcontents
.fwd
)
1465 : valcontents
.value
));
1467 /* Buffer_Local_Values cannot have as realval a buffer-local
1468 or keyboard-local forwarding. */
1469 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1470 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1471 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1473 blv
->frame_local
= 0;
1474 blv
->local_if_set
= 0;
1477 SET_BLV_FOUND (blv
, 0);
1481 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1482 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1483 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1484 At any time, the value for the current buffer is in effect,
1485 unless the variable has never been set in this buffer,
1486 in which case the default value is in effect.
1487 Note that binding the variable with `let', or setting it while
1488 a `let'-style binding made in this buffer is in effect,
1489 does not make the variable buffer-local. Return VARIABLE.
1491 In most cases it is better to use `make-local-variable',
1492 which makes a variable local in just one buffer.
1494 The function `default-value' gets the default value and `set-default' sets it. */)
1495 (register Lisp_Object variable
)
1497 struct Lisp_Symbol
*sym
;
1498 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1499 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1500 int forwarded
IF_LINT (= 0);
1502 CHECK_SYMBOL (variable
);
1503 sym
= XSYMBOL (variable
);
1506 switch (sym
->redirect
)
1508 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1509 case SYMBOL_PLAINVAL
:
1510 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1511 if (EQ (valcontents
.value
, Qunbound
))
1512 valcontents
.value
= Qnil
;
1514 case SYMBOL_LOCALIZED
:
1515 blv
= SYMBOL_BLV (sym
);
1516 if (blv
->frame_local
)
1517 error ("Symbol %s may not be buffer-local",
1518 SDATA (SYMBOL_NAME (variable
)));
1520 case SYMBOL_FORWARDED
:
1521 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1522 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1523 error ("Symbol %s may not be buffer-local",
1524 SDATA (SYMBOL_NAME (variable
)));
1525 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1532 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1536 blv
= make_blv (sym
, forwarded
, valcontents
);
1537 sym
->redirect
= SYMBOL_LOCALIZED
;
1538 SET_SYMBOL_BLV (sym
, blv
);
1541 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1542 if (let_shadows_global_binding_p (symbol
))
1543 message ("Making %s buffer-local while let-bound!",
1544 SDATA (SYMBOL_NAME (variable
)));
1548 blv
->local_if_set
= 1;
1552 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1553 1, 1, "vMake Local Variable: ",
1554 doc
: /* Make VARIABLE have a separate value in the current buffer.
1555 Other buffers will continue to share a common default value.
1556 \(The buffer-local value of VARIABLE starts out as the same value
1557 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1560 If the variable is already arranged to become local when set,
1561 this function causes a local value to exist for this buffer,
1562 just as setting the variable would do.
1564 This function returns VARIABLE, and therefore
1565 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1568 See also `make-variable-buffer-local'.
1570 Do not use `make-local-variable' to make a hook variable buffer-local.
1571 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1572 (register Lisp_Object variable
)
1574 register Lisp_Object tem
;
1575 int forwarded
IF_LINT (= 0);
1576 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1577 struct Lisp_Symbol
*sym
;
1578 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1580 CHECK_SYMBOL (variable
);
1581 sym
= XSYMBOL (variable
);
1584 switch (sym
->redirect
)
1586 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1587 case SYMBOL_PLAINVAL
:
1588 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1589 case SYMBOL_LOCALIZED
:
1590 blv
= SYMBOL_BLV (sym
);
1591 if (blv
->frame_local
)
1592 error ("Symbol %s may not be buffer-local",
1593 SDATA (SYMBOL_NAME (variable
)));
1595 case SYMBOL_FORWARDED
:
1596 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1597 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1598 error ("Symbol %s may not be buffer-local",
1599 SDATA (SYMBOL_NAME (variable
)));
1605 error ("Symbol %s may not be buffer-local",
1606 SDATA (SYMBOL_NAME (variable
)));
1608 if (blv
? blv
->local_if_set
1609 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1611 tem
= Fboundp (variable
);
1612 /* Make sure the symbol has a local value in this particular buffer,
1613 by setting it to the same value it already has. */
1614 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1619 blv
= make_blv (sym
, forwarded
, valcontents
);
1620 sym
->redirect
= SYMBOL_LOCALIZED
;
1621 SET_SYMBOL_BLV (sym
, blv
);
1624 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1625 if (let_shadows_global_binding_p (symbol
))
1626 message ("Making %s local to %s while let-bound!",
1627 SDATA (SYMBOL_NAME (variable
)),
1628 SDATA (BVAR (current_buffer
, name
)));
1632 /* Make sure this buffer has its own value of symbol. */
1633 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1634 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1637 if (let_shadows_buffer_binding_p (sym
))
1638 message ("Making %s buffer-local while locally let-bound!",
1639 SDATA (SYMBOL_NAME (variable
)));
1641 /* Swap out any local binding for some other buffer, and make
1642 sure the current value is permanently recorded, if it's the
1644 find_symbol_value (variable
);
1646 BVAR (current_buffer
, local_var_alist
)
1647 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1648 BVAR (current_buffer
, local_var_alist
));
1650 /* Make sure symbol does not think it is set up for this buffer;
1651 force it to look once again for this buffer's value. */
1652 if (current_buffer
== XBUFFER (blv
->where
))
1654 /* blv->valcell = blv->defcell;
1655 * SET_BLV_FOUND (blv, 0); */
1659 /* If the symbol forwards into a C variable, then load the binding
1660 for this buffer now. If C code modifies the variable before we
1661 load the binding in, then that new value will clobber the default
1662 binding the next time we unload it. */
1664 swap_in_symval_forwarding (sym
, blv
);
1669 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1670 1, 1, "vKill Local Variable: ",
1671 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1672 From now on the default value will apply in this buffer. Return VARIABLE. */)
1673 (register Lisp_Object variable
)
1675 register Lisp_Object tem
;
1676 struct Lisp_Buffer_Local_Value
*blv
;
1677 struct Lisp_Symbol
*sym
;
1679 CHECK_SYMBOL (variable
);
1680 sym
= XSYMBOL (variable
);
1683 switch (sym
->redirect
)
1685 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1686 case SYMBOL_PLAINVAL
: return variable
;
1687 case SYMBOL_FORWARDED
:
1689 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1690 if (BUFFER_OBJFWDP (valcontents
))
1692 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1693 int idx
= PER_BUFFER_IDX (offset
);
1697 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1698 PER_BUFFER_VALUE (current_buffer
, offset
)
1699 = PER_BUFFER_DEFAULT (offset
);
1704 case SYMBOL_LOCALIZED
:
1705 blv
= SYMBOL_BLV (sym
);
1706 if (blv
->frame_local
)
1712 /* Get rid of this buffer's alist element, if any. */
1713 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1714 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1716 BVAR (current_buffer
, local_var_alist
)
1717 = Fdelq (tem
, BVAR (current_buffer
, local_var_alist
));
1719 /* If the symbol is set up with the current buffer's binding
1720 loaded, recompute its value. We have to do it now, or else
1721 forwarded objects won't work right. */
1723 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1724 if (EQ (buf
, blv
->where
))
1727 /* blv->valcell = blv->defcell;
1728 * SET_BLV_FOUND (blv, 0); */
1730 find_symbol_value (variable
);
1737 /* Lisp functions for creating and removing buffer-local variables. */
1739 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1740 when/if this is removed. */
1742 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1743 1, 1, "vMake Variable Frame Local: ",
1744 doc
: /* Enable VARIABLE to have frame-local bindings.
1745 This does not create any frame-local bindings for VARIABLE,
1746 it just makes them possible.
1748 A frame-local binding is actually a frame parameter value.
1749 If a frame F has a value for the frame parameter named VARIABLE,
1750 that also acts as a frame-local binding for VARIABLE in F--
1751 provided this function has been called to enable VARIABLE
1752 to have frame-local bindings at all.
1754 The only way to create a frame-local binding for VARIABLE in a frame
1755 is to set the VARIABLE frame parameter of that frame. See
1756 `modify-frame-parameters' for how to set frame parameters.
1758 Note that since Emacs 23.1, variables cannot be both buffer-local and
1759 frame-local any more (buffer-local bindings used to take precedence over
1760 frame-local bindings). */)
1761 (register Lisp_Object variable
)
1764 union Lisp_Val_Fwd valcontents
;
1765 struct Lisp_Symbol
*sym
;
1766 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1768 CHECK_SYMBOL (variable
);
1769 sym
= XSYMBOL (variable
);
1772 switch (sym
->redirect
)
1774 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1775 case SYMBOL_PLAINVAL
:
1776 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1777 if (EQ (valcontents
.value
, Qunbound
))
1778 valcontents
.value
= Qnil
;
1780 case SYMBOL_LOCALIZED
:
1781 if (SYMBOL_BLV (sym
)->frame_local
)
1784 error ("Symbol %s may not be frame-local",
1785 SDATA (SYMBOL_NAME (variable
)));
1786 case SYMBOL_FORWARDED
:
1787 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1788 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1789 error ("Symbol %s may not be frame-local",
1790 SDATA (SYMBOL_NAME (variable
)));
1796 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1798 blv
= make_blv (sym
, forwarded
, valcontents
);
1799 blv
->frame_local
= 1;
1800 sym
->redirect
= SYMBOL_LOCALIZED
;
1801 SET_SYMBOL_BLV (sym
, blv
);
1804 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1805 if (let_shadows_global_binding_p (symbol
))
1806 message ("Making %s frame-local while let-bound!",
1807 SDATA (SYMBOL_NAME (variable
)));
1812 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1814 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1815 BUFFER defaults to the current buffer. */)
1816 (register Lisp_Object variable
, Lisp_Object buffer
)
1818 register struct buffer
*buf
;
1819 struct Lisp_Symbol
*sym
;
1822 buf
= current_buffer
;
1825 CHECK_BUFFER (buffer
);
1826 buf
= XBUFFER (buffer
);
1829 CHECK_SYMBOL (variable
);
1830 sym
= XSYMBOL (variable
);
1833 switch (sym
->redirect
)
1835 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1836 case SYMBOL_PLAINVAL
: return Qnil
;
1837 case SYMBOL_LOCALIZED
:
1839 Lisp_Object tail
, elt
, tmp
;
1840 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1841 XSETBUFFER (tmp
, buf
);
1842 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1844 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1847 if (EQ (variable
, XCAR (elt
)))
1849 eassert (!blv
->frame_local
);
1850 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1854 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1857 case SYMBOL_FORWARDED
:
1859 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1860 if (BUFFER_OBJFWDP (valcontents
))
1862 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1863 int idx
= PER_BUFFER_IDX (offset
);
1864 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1873 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1875 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1876 More precisely, this means that setting the variable \(with `set' or`setq'),
1877 while it does not have a `let'-style binding that was made in BUFFER,
1878 will produce a buffer local binding. See Info node
1879 `(elisp)Creating Buffer-Local'.
1880 BUFFER defaults to the current buffer. */)
1881 (register Lisp_Object variable
, Lisp_Object buffer
)
1883 struct Lisp_Symbol
*sym
;
1885 CHECK_SYMBOL (variable
);
1886 sym
= XSYMBOL (variable
);
1889 switch (sym
->redirect
)
1891 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1892 case SYMBOL_PLAINVAL
: return Qnil
;
1893 case SYMBOL_LOCALIZED
:
1895 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1896 if (blv
->local_if_set
)
1898 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1899 return Flocal_variable_p (variable
, buffer
);
1901 case SYMBOL_FORWARDED
:
1902 /* All BUFFER_OBJFWD slots become local if they are set. */
1903 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1908 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1910 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1911 If the current binding is buffer-local, the value is the current buffer.
1912 If the current binding is frame-local, the value is the selected frame.
1913 If the current binding is global (the default), the value is nil. */)
1914 (register Lisp_Object variable
)
1916 struct Lisp_Symbol
*sym
;
1918 CHECK_SYMBOL (variable
);
1919 sym
= XSYMBOL (variable
);
1921 /* Make sure the current binding is actually swapped in. */
1922 find_symbol_value (variable
);
1925 switch (sym
->redirect
)
1927 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1928 case SYMBOL_PLAINVAL
: return Qnil
;
1929 case SYMBOL_FORWARDED
:
1931 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1932 if (KBOARD_OBJFWDP (valcontents
))
1933 return Fframe_terminal (Fselected_frame ());
1934 else if (!BUFFER_OBJFWDP (valcontents
))
1938 case SYMBOL_LOCALIZED
:
1939 /* For a local variable, record both the symbol and which
1940 buffer's or frame's value we are saving. */
1941 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1942 return Fcurrent_buffer ();
1943 else if (sym
->redirect
== SYMBOL_LOCALIZED
1944 && BLV_FOUND (SYMBOL_BLV (sym
)))
1945 return SYMBOL_BLV (sym
)->where
;
1952 /* This code is disabled now that we use the selected frame to return
1953 keyboard-local-values. */
1955 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1957 DEFUN ("terminal-local-value", Fterminal_local_value
,
1958 Sterminal_local_value
, 2, 2, 0,
1959 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1960 If SYMBOL is not a terminal-local variable, then return its normal
1961 value, like `symbol-value'.
1963 TERMINAL may be a terminal object, a frame, or nil (meaning the
1964 selected frame's terminal device). */)
1965 (Lisp_Object symbol
, Lisp_Object terminal
)
1968 struct terminal
*t
= get_terminal (terminal
, 1);
1969 push_kboard (t
->kboard
);
1970 result
= Fsymbol_value (symbol
);
1975 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1976 Sset_terminal_local_value
, 3, 3, 0,
1977 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1978 If VARIABLE is not a terminal-local variable, then set its normal
1979 binding, like `set'.
1981 TERMINAL may be a terminal object, a frame, or nil (meaning the
1982 selected frame's terminal device). */)
1983 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1986 struct terminal
*t
= get_terminal (terminal
, 1);
1987 push_kboard (d
->kboard
);
1988 result
= Fset (symbol
, value
);
1994 /* Find the function at the end of a chain of symbol function indirections. */
1996 /* If OBJECT is a symbol, find the end of its function chain and
1997 return the value found there. If OBJECT is not a symbol, just
1998 return it. If there is a cycle in the function chain, signal a
1999 cyclic-function-indirection error.
2001 This is like Findirect_function, except that it doesn't signal an
2002 error if the chain ends up unbound. */
2004 indirect_function (register Lisp_Object object
)
2006 Lisp_Object tortoise
, hare
;
2008 hare
= tortoise
= object
;
2012 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2014 hare
= XSYMBOL (hare
)->function
;
2015 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2017 hare
= XSYMBOL (hare
)->function
;
2019 tortoise
= XSYMBOL (tortoise
)->function
;
2021 if (EQ (hare
, tortoise
))
2022 xsignal1 (Qcyclic_function_indirection
, object
);
2028 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2029 doc
: /* Return the function at the end of OBJECT's function chain.
2030 If OBJECT is not a symbol, just return it. Otherwise, follow all
2031 function indirections to find the final function binding and return it.
2032 If the final symbol in the chain is unbound, signal a void-function error.
2033 Optional arg NOERROR non-nil means to return nil instead of signalling.
2034 Signal a cyclic-function-indirection error if there is a loop in the
2035 function chain of symbols. */)
2036 (register Lisp_Object object
, Lisp_Object noerror
)
2040 /* Optimize for no indirection. */
2042 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2043 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2044 result
= indirect_function (result
);
2045 if (!EQ (result
, Qunbound
))
2049 xsignal1 (Qvoid_function
, object
);
2054 /* Extract and set vector and string elements */
2056 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2057 doc
: /* Return the element of ARRAY at index IDX.
2058 ARRAY may be a vector, a string, a char-table, a bool-vector,
2059 or a byte-code object. IDX starts at 0. */)
2060 (register Lisp_Object array
, Lisp_Object idx
)
2062 register EMACS_INT idxval
;
2065 idxval
= XINT (idx
);
2066 if (STRINGP (array
))
2069 EMACS_INT idxval_byte
;
2071 if (idxval
< 0 || idxval
>= SCHARS (array
))
2072 args_out_of_range (array
, idx
);
2073 if (! STRING_MULTIBYTE (array
))
2074 return make_number ((unsigned char) SREF (array
, idxval
));
2075 idxval_byte
= string_char_to_byte (array
, idxval
);
2077 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2078 return make_number (c
);
2080 else if (BOOL_VECTOR_P (array
))
2084 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2085 args_out_of_range (array
, idx
);
2087 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2088 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2090 else if (CHAR_TABLE_P (array
))
2092 CHECK_CHARACTER (idx
);
2093 return CHAR_TABLE_REF (array
, idxval
);
2098 if (VECTORP (array
))
2099 size
= ASIZE (array
);
2100 else if (COMPILEDP (array
))
2101 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2103 wrong_type_argument (Qarrayp
, array
);
2105 if (idxval
< 0 || idxval
>= size
)
2106 args_out_of_range (array
, idx
);
2107 return AREF (array
, idxval
);
2111 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2112 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2113 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2114 bool-vector. IDX starts at 0. */)
2115 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2117 register EMACS_INT idxval
;
2120 idxval
= XINT (idx
);
2121 CHECK_ARRAY (array
, Qarrayp
);
2122 CHECK_IMPURE (array
);
2124 if (VECTORP (array
))
2126 if (idxval
< 0 || idxval
>= ASIZE (array
))
2127 args_out_of_range (array
, idx
);
2128 XVECTOR (array
)->contents
[idxval
] = newelt
;
2130 else if (BOOL_VECTOR_P (array
))
2134 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2135 args_out_of_range (array
, idx
);
2137 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2139 if (! NILP (newelt
))
2140 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2142 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2143 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2145 else if (CHAR_TABLE_P (array
))
2147 CHECK_CHARACTER (idx
);
2148 CHAR_TABLE_SET (array
, idxval
, newelt
);
2150 else if (STRING_MULTIBYTE (array
))
2152 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2153 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2155 if (idxval
< 0 || idxval
>= SCHARS (array
))
2156 args_out_of_range (array
, idx
);
2157 CHECK_CHARACTER (newelt
);
2159 nbytes
= SBYTES (array
);
2161 idxval_byte
= string_char_to_byte (array
, idxval
);
2162 p1
= SDATA (array
) + idxval_byte
;
2163 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2164 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2165 if (prev_bytes
!= new_bytes
)
2167 /* We must relocate the string data. */
2168 EMACS_INT nchars
= SCHARS (array
);
2172 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2173 memcpy (str
, SDATA (array
), nbytes
);
2174 allocate_string_data (XSTRING (array
), nchars
,
2175 nbytes
+ new_bytes
- prev_bytes
);
2176 memcpy (SDATA (array
), str
, idxval_byte
);
2177 p1
= SDATA (array
) + idxval_byte
;
2178 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2179 nbytes
- (idxval_byte
+ prev_bytes
));
2181 clear_string_char_byte_cache ();
2188 if (idxval
< 0 || idxval
>= SCHARS (array
))
2189 args_out_of_range (array
, idx
);
2190 CHECK_NUMBER (newelt
);
2192 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2196 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2197 if (SREF (array
, i
) >= 0x80)
2198 args_out_of_range (array
, newelt
);
2199 /* ARRAY is an ASCII string. Convert it to a multibyte
2200 string, and try `aset' again. */
2201 STRING_SET_MULTIBYTE (array
);
2202 return Faset (array
, idx
, newelt
);
2204 SSET (array
, idxval
, XINT (newelt
));
2210 /* Arithmetic functions */
2212 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2215 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2217 double f1
= 0, f2
= 0;
2220 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2221 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2223 if (FLOATP (num1
) || FLOATP (num2
))
2226 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2227 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2233 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2238 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2243 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2248 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2253 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2258 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2267 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2268 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2269 (register Lisp_Object num1
, Lisp_Object num2
)
2271 return arithcompare (num1
, num2
, equal
);
2274 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2275 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2276 (register Lisp_Object num1
, Lisp_Object num2
)
2278 return arithcompare (num1
, num2
, less
);
2281 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2282 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2283 (register Lisp_Object num1
, Lisp_Object num2
)
2285 return arithcompare (num1
, num2
, grtr
);
2288 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2289 doc
: /* Return t if first arg is less than or equal to second arg.
2290 Both must be numbers or markers. */)
2291 (register Lisp_Object num1
, Lisp_Object num2
)
2293 return arithcompare (num1
, num2
, less_or_equal
);
2296 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2297 doc
: /* Return t if first arg is greater than or equal to second arg.
2298 Both must be numbers or markers. */)
2299 (register Lisp_Object num1
, Lisp_Object num2
)
2301 return arithcompare (num1
, num2
, grtr_or_equal
);
2304 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2305 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2306 (register Lisp_Object num1
, Lisp_Object num2
)
2308 return arithcompare (num1
, num2
, notequal
);
2311 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2312 doc
: /* Return t if NUMBER is zero. */)
2313 (register Lisp_Object number
)
2315 CHECK_NUMBER_OR_FLOAT (number
);
2317 if (FLOATP (number
))
2319 if (XFLOAT_DATA (number
) == 0.0)
2329 /* Convert the cons-of-integers, integer, or float value C to an
2330 unsigned value with maximum value MAX. Signal an error if C does not
2331 have a valid format or is out of range. */
2333 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2336 uintmax_t val
IF_LINT (= 0);
2339 valid
= 0 <= XINT (c
);
2342 else if (FLOATP (c
))
2344 double d
= XFLOAT_DATA (c
);
2346 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2352 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2354 uintmax_t top
= XFASTINT (XCAR (c
));
2355 Lisp_Object rest
= XCDR (c
);
2356 if (top
<= UINTMAX_MAX
>> 24 >> 16
2358 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2359 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2361 uintmax_t mid
= XFASTINT (XCAR (rest
));
2362 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2365 else if (top
<= UINTMAX_MAX
>> 16)
2369 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2371 val
= top
<< 16 | XFASTINT (rest
);
2377 if (! (valid
&& val
<= max
))
2378 error ("Not an in-range integer, float, or cons of integers");
2382 /* Convert the cons-of-integers, integer, or float value C to a signed
2383 value with extrema MIN and MAX. Signal an error if C does not have
2384 a valid format or is out of range. */
2386 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2389 intmax_t val
IF_LINT (= 0);
2395 else if (FLOATP (c
))
2397 double d
= XFLOAT_DATA (c
);
2399 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2405 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2407 intmax_t top
= XINT (XCAR (c
));
2408 Lisp_Object rest
= XCDR (c
);
2409 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2411 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2412 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2414 intmax_t mid
= XFASTINT (XCAR (rest
));
2415 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2418 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2422 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2424 val
= top
<< 16 | XFASTINT (rest
);
2430 if (! (valid
&& min
<= val
&& val
<= max
))
2431 error ("Not an in-range integer, float, or cons of integers");
2435 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2436 doc
: /* Return the decimal representation of NUMBER as a string.
2437 Uses a minus sign if negative.
2438 NUMBER may be an integer or a floating point number. */)
2439 (Lisp_Object number
)
2441 char buffer
[VALBITS
];
2443 CHECK_NUMBER_OR_FLOAT (number
);
2445 if (FLOATP (number
))
2447 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2449 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2450 return build_string (pigbuf
);
2453 sprintf (buffer
, "%"pI
"d", XINT (number
));
2454 return build_string (buffer
);
2457 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2458 doc
: /* Parse STRING as a decimal number and return the number.
2459 This parses both integers and floating point numbers.
2460 It ignores leading spaces and tabs, and all trailing chars.
2462 If BASE, interpret STRING as a number in that base. If BASE isn't
2463 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2464 If the base used is not 10, STRING is always parsed as integer. */)
2465 (register Lisp_Object string
, Lisp_Object base
)
2471 CHECK_STRING (string
);
2477 CHECK_NUMBER (base
);
2479 if (b
< 2 || b
> 16)
2480 xsignal1 (Qargs_out_of_range
, base
);
2483 p
= SSDATA (string
);
2484 while (*p
== ' ' || *p
== '\t')
2487 val
= string_to_number (p
, b
, 1);
2488 return NILP (val
) ? make_number (0) : val
;
2504 static Lisp_Object
float_arith_driver (double, size_t, enum arithop
,
2505 size_t, Lisp_Object
*);
2507 arith_driver (enum arithop code
, size_t nargs
, register Lisp_Object
*args
)
2509 register Lisp_Object val
;
2510 register size_t argnum
;
2511 register EMACS_INT accum
= 0;
2512 register EMACS_INT next
;
2518 switch (SWITCH_ENUM_CAST (code
))
2536 for (argnum
= 0; argnum
< nargs
; argnum
++)
2544 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2546 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2549 return float_arith_driver (ok_accum
, ok_args
, code
,
2552 next
= XINT (args
[argnum
]);
2553 switch (SWITCH_ENUM_CAST (code
))
2556 if (INT_ADD_OVERFLOW (accum
, next
))
2564 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2569 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2572 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2574 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2576 accum
= ab
& INTMASK
;
2587 xsignal0 (Qarith_error
);
2601 if (!argnum
|| next
> accum
)
2605 if (!argnum
|| next
< accum
)
2611 XSETINT (val
, accum
);
2616 #define isnan(x) ((x) != (x))
2619 float_arith_driver (double accum
, register size_t argnum
, enum arithop code
,
2620 size_t nargs
, register Lisp_Object
*args
)
2622 register Lisp_Object val
;
2625 for (; argnum
< nargs
; argnum
++)
2627 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2628 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2632 next
= XFLOAT_DATA (val
);
2636 args
[argnum
] = val
; /* runs into a compiler bug. */
2637 next
= XINT (args
[argnum
]);
2639 switch (SWITCH_ENUM_CAST (code
))
2645 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2655 if (! IEEE_FLOATING_POINT
&& next
== 0)
2656 xsignal0 (Qarith_error
);
2663 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2665 if (!argnum
|| isnan (next
) || next
> accum
)
2669 if (!argnum
|| isnan (next
) || next
< accum
)
2675 return make_float (accum
);
2679 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2680 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2681 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2682 (size_t nargs
, Lisp_Object
*args
)
2684 return arith_driver (Aadd
, nargs
, args
);
2687 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2688 doc
: /* Negate number or subtract numbers or markers and return the result.
2689 With one arg, negates it. With more than one arg,
2690 subtracts all but the first from the first.
2691 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2692 (size_t nargs
, Lisp_Object
*args
)
2694 return arith_driver (Asub
, nargs
, args
);
2697 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2698 doc
: /* Return product of any number of arguments, which are numbers or markers.
2699 usage: (* &rest NUMBERS-OR-MARKERS) */)
2700 (size_t nargs
, Lisp_Object
*args
)
2702 return arith_driver (Amult
, nargs
, args
);
2705 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2706 doc
: /* Return first argument divided by all the remaining arguments.
2707 The arguments must be numbers or markers.
2708 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2709 (size_t nargs
, Lisp_Object
*args
)
2712 for (argnum
= 2; argnum
< nargs
; argnum
++)
2713 if (FLOATP (args
[argnum
]))
2714 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2715 return arith_driver (Adiv
, nargs
, args
);
2718 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2719 doc
: /* Return remainder of X divided by Y.
2720 Both must be integers or markers. */)
2721 (register Lisp_Object x
, Lisp_Object y
)
2725 CHECK_NUMBER_COERCE_MARKER (x
);
2726 CHECK_NUMBER_COERCE_MARKER (y
);
2728 if (XFASTINT (y
) == 0)
2729 xsignal0 (Qarith_error
);
2731 XSETINT (val
, XINT (x
) % XINT (y
));
2745 /* If the magnitude of the result exceeds that of the divisor, or
2746 the sign of the result does not agree with that of the dividend,
2747 iterate with the reduced value. This does not yield a
2748 particularly accurate result, but at least it will be in the
2749 range promised by fmod. */
2751 r
-= f2
* floor (r
/ f2
);
2752 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2756 #endif /* ! HAVE_FMOD */
2758 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2759 doc
: /* Return X modulo Y.
2760 The result falls between zero (inclusive) and Y (exclusive).
2761 Both X and Y must be numbers or markers. */)
2762 (register Lisp_Object x
, Lisp_Object y
)
2767 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2768 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2770 if (FLOATP (x
) || FLOATP (y
))
2771 return fmod_float (x
, y
);
2777 xsignal0 (Qarith_error
);
2781 /* If the "remainder" comes out with the wrong sign, fix it. */
2782 if (i2
< 0 ? i1
> 0 : i1
< 0)
2789 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2790 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2791 The value is always a number; markers are converted to numbers.
2792 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2793 (size_t nargs
, Lisp_Object
*args
)
2795 return arith_driver (Amax
, nargs
, args
);
2798 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2799 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2800 The value is always a number; markers are converted to numbers.
2801 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2802 (size_t nargs
, Lisp_Object
*args
)
2804 return arith_driver (Amin
, nargs
, args
);
2807 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2808 doc
: /* Return bitwise-and of all the arguments.
2809 Arguments may be integers, or markers converted to integers.
2810 usage: (logand &rest INTS-OR-MARKERS) */)
2811 (size_t nargs
, Lisp_Object
*args
)
2813 return arith_driver (Alogand
, nargs
, args
);
2816 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2817 doc
: /* Return bitwise-or of all the arguments.
2818 Arguments may be integers, or markers converted to integers.
2819 usage: (logior &rest INTS-OR-MARKERS) */)
2820 (size_t nargs
, Lisp_Object
*args
)
2822 return arith_driver (Alogior
, nargs
, args
);
2825 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2826 doc
: /* Return bitwise-exclusive-or of all the arguments.
2827 Arguments may be integers, or markers converted to integers.
2828 usage: (logxor &rest INTS-OR-MARKERS) */)
2829 (size_t nargs
, Lisp_Object
*args
)
2831 return arith_driver (Alogxor
, nargs
, args
);
2834 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2835 doc
: /* Return VALUE with its bits shifted left by COUNT.
2836 If COUNT is negative, shifting is actually to the right.
2837 In this case, the sign bit is duplicated. */)
2838 (register Lisp_Object value
, Lisp_Object count
)
2840 register Lisp_Object val
;
2842 CHECK_NUMBER (value
);
2843 CHECK_NUMBER (count
);
2845 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2847 else if (XINT (count
) > 0)
2848 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2849 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2850 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2852 XSETINT (val
, XINT (value
) >> -XINT (count
));
2856 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2857 doc
: /* Return VALUE with its bits shifted left by COUNT.
2858 If COUNT is negative, shifting is actually to the right.
2859 In this case, zeros are shifted in on the left. */)
2860 (register Lisp_Object value
, Lisp_Object count
)
2862 register Lisp_Object val
;
2864 CHECK_NUMBER (value
);
2865 CHECK_NUMBER (count
);
2867 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2869 else if (XINT (count
) > 0)
2870 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2871 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2874 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2878 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2879 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2880 Markers are converted to integers. */)
2881 (register Lisp_Object number
)
2883 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2885 if (FLOATP (number
))
2886 return (make_float (1.0 + XFLOAT_DATA (number
)));
2888 XSETINT (number
, XINT (number
) + 1);
2892 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2893 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2894 Markers are converted to integers. */)
2895 (register Lisp_Object number
)
2897 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2899 if (FLOATP (number
))
2900 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2902 XSETINT (number
, XINT (number
) - 1);
2906 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2907 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2908 (register Lisp_Object number
)
2910 CHECK_NUMBER (number
);
2911 XSETINT (number
, ~XINT (number
));
2915 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2916 doc
: /* Return the byteorder for the machine.
2917 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2918 lowercase l) for small endian machines. */)
2921 unsigned i
= 0x04030201;
2922 int order
= *(char *)&i
== 1 ? 108 : 66;
2924 return make_number (order
);
2932 Lisp_Object error_tail
, arith_tail
;
2934 DEFSYM (Qquote
, "quote");
2935 DEFSYM (Qlambda
, "lambda");
2936 DEFSYM (Qsubr
, "subr");
2937 DEFSYM (Qerror_conditions
, "error-conditions");
2938 DEFSYM (Qerror_message
, "error-message");
2939 DEFSYM (Qtop_level
, "top-level");
2941 DEFSYM (Qerror
, "error");
2942 DEFSYM (Qquit
, "quit");
2943 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2944 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2945 DEFSYM (Qvoid_function
, "void-function");
2946 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2947 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2948 DEFSYM (Qvoid_variable
, "void-variable");
2949 DEFSYM (Qsetting_constant
, "setting-constant");
2950 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2952 DEFSYM (Qinvalid_function
, "invalid-function");
2953 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2954 DEFSYM (Qno_catch
, "no-catch");
2955 DEFSYM (Qend_of_file
, "end-of-file");
2956 DEFSYM (Qarith_error
, "arith-error");
2957 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2958 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2959 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2960 DEFSYM (Qtext_read_only
, "text-read-only");
2961 DEFSYM (Qmark_inactive
, "mark-inactive");
2963 DEFSYM (Qlistp
, "listp");
2964 DEFSYM (Qconsp
, "consp");
2965 DEFSYM (Qsymbolp
, "symbolp");
2966 DEFSYM (Qkeywordp
, "keywordp");
2967 DEFSYM (Qintegerp
, "integerp");
2968 DEFSYM (Qnatnump
, "natnump");
2969 DEFSYM (Qwholenump
, "wholenump");
2970 DEFSYM (Qstringp
, "stringp");
2971 DEFSYM (Qarrayp
, "arrayp");
2972 DEFSYM (Qsequencep
, "sequencep");
2973 DEFSYM (Qbufferp
, "bufferp");
2974 DEFSYM (Qvectorp
, "vectorp");
2975 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2976 DEFSYM (Qmarkerp
, "markerp");
2977 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
2978 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
2979 DEFSYM (Qboundp
, "boundp");
2980 DEFSYM (Qfboundp
, "fboundp");
2982 DEFSYM (Qfloatp
, "floatp");
2983 DEFSYM (Qnumberp
, "numberp");
2984 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
2986 DEFSYM (Qchar_table_p
, "char-table-p");
2987 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
2989 DEFSYM (Qsubrp
, "subrp");
2990 DEFSYM (Qunevalled
, "unevalled");
2991 DEFSYM (Qmany
, "many");
2993 DEFSYM (Qcdr
, "cdr");
2995 /* Handle automatic advice activation. */
2996 DEFSYM (Qad_advice_info
, "ad-advice-info");
2997 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
2999 error_tail
= pure_cons (Qerror
, Qnil
);
3001 /* ERROR is used as a signaler for random errors for which nothing else is
3004 Fput (Qerror
, Qerror_conditions
,
3006 Fput (Qerror
, Qerror_message
,
3007 make_pure_c_string ("error"));
3009 Fput (Qquit
, Qerror_conditions
,
3010 pure_cons (Qquit
, Qnil
));
3011 Fput (Qquit
, Qerror_message
,
3012 make_pure_c_string ("Quit"));
3014 Fput (Qwrong_type_argument
, Qerror_conditions
,
3015 pure_cons (Qwrong_type_argument
, error_tail
));
3016 Fput (Qwrong_type_argument
, Qerror_message
,
3017 make_pure_c_string ("Wrong type argument"));
3019 Fput (Qargs_out_of_range
, Qerror_conditions
,
3020 pure_cons (Qargs_out_of_range
, error_tail
));
3021 Fput (Qargs_out_of_range
, Qerror_message
,
3022 make_pure_c_string ("Args out of range"));
3024 Fput (Qvoid_function
, Qerror_conditions
,
3025 pure_cons (Qvoid_function
, error_tail
));
3026 Fput (Qvoid_function
, Qerror_message
,
3027 make_pure_c_string ("Symbol's function definition is void"));
3029 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3030 pure_cons (Qcyclic_function_indirection
, error_tail
));
3031 Fput (Qcyclic_function_indirection
, Qerror_message
,
3032 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3034 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3035 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3036 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3037 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3039 DEFSYM (Qcircular_list
, "circular-list");
3040 Fput (Qcircular_list
, Qerror_conditions
,
3041 pure_cons (Qcircular_list
, error_tail
));
3042 Fput (Qcircular_list
, Qerror_message
,
3043 make_pure_c_string ("List contains a loop"));
3045 Fput (Qvoid_variable
, Qerror_conditions
,
3046 pure_cons (Qvoid_variable
, error_tail
));
3047 Fput (Qvoid_variable
, Qerror_message
,
3048 make_pure_c_string ("Symbol's value as variable is void"));
3050 Fput (Qsetting_constant
, Qerror_conditions
,
3051 pure_cons (Qsetting_constant
, error_tail
));
3052 Fput (Qsetting_constant
, Qerror_message
,
3053 make_pure_c_string ("Attempt to set a constant symbol"));
3055 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3056 pure_cons (Qinvalid_read_syntax
, error_tail
));
3057 Fput (Qinvalid_read_syntax
, Qerror_message
,
3058 make_pure_c_string ("Invalid read syntax"));
3060 Fput (Qinvalid_function
, Qerror_conditions
,
3061 pure_cons (Qinvalid_function
, error_tail
));
3062 Fput (Qinvalid_function
, Qerror_message
,
3063 make_pure_c_string ("Invalid function"));
3065 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3066 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3067 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3068 make_pure_c_string ("Wrong number of arguments"));
3070 Fput (Qno_catch
, Qerror_conditions
,
3071 pure_cons (Qno_catch
, error_tail
));
3072 Fput (Qno_catch
, Qerror_message
,
3073 make_pure_c_string ("No catch for tag"));
3075 Fput (Qend_of_file
, Qerror_conditions
,
3076 pure_cons (Qend_of_file
, error_tail
));
3077 Fput (Qend_of_file
, Qerror_message
,
3078 make_pure_c_string ("End of file during parsing"));
3080 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3081 Fput (Qarith_error
, Qerror_conditions
,
3083 Fput (Qarith_error
, Qerror_message
,
3084 make_pure_c_string ("Arithmetic error"));
3086 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3087 pure_cons (Qbeginning_of_buffer
, error_tail
));
3088 Fput (Qbeginning_of_buffer
, Qerror_message
,
3089 make_pure_c_string ("Beginning of buffer"));
3091 Fput (Qend_of_buffer
, Qerror_conditions
,
3092 pure_cons (Qend_of_buffer
, error_tail
));
3093 Fput (Qend_of_buffer
, Qerror_message
,
3094 make_pure_c_string ("End of buffer"));
3096 Fput (Qbuffer_read_only
, Qerror_conditions
,
3097 pure_cons (Qbuffer_read_only
, error_tail
));
3098 Fput (Qbuffer_read_only
, Qerror_message
,
3099 make_pure_c_string ("Buffer is read-only"));
3101 Fput (Qtext_read_only
, Qerror_conditions
,
3102 pure_cons (Qtext_read_only
, error_tail
));
3103 Fput (Qtext_read_only
, Qerror_message
,
3104 make_pure_c_string ("Text is read-only"));
3106 DEFSYM (Qrange_error
, "range-error");
3107 DEFSYM (Qdomain_error
, "domain-error");
3108 DEFSYM (Qsingularity_error
, "singularity-error");
3109 DEFSYM (Qoverflow_error
, "overflow-error");
3110 DEFSYM (Qunderflow_error
, "underflow-error");
3112 Fput (Qdomain_error
, Qerror_conditions
,
3113 pure_cons (Qdomain_error
, arith_tail
));
3114 Fput (Qdomain_error
, Qerror_message
,
3115 make_pure_c_string ("Arithmetic domain error"));
3117 Fput (Qrange_error
, Qerror_conditions
,
3118 pure_cons (Qrange_error
, arith_tail
));
3119 Fput (Qrange_error
, Qerror_message
,
3120 make_pure_c_string ("Arithmetic range error"));
3122 Fput (Qsingularity_error
, Qerror_conditions
,
3123 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3124 Fput (Qsingularity_error
, Qerror_message
,
3125 make_pure_c_string ("Arithmetic singularity error"));
3127 Fput (Qoverflow_error
, Qerror_conditions
,
3128 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3129 Fput (Qoverflow_error
, Qerror_message
,
3130 make_pure_c_string ("Arithmetic overflow error"));
3132 Fput (Qunderflow_error
, Qerror_conditions
,
3133 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3134 Fput (Qunderflow_error
, Qerror_message
,
3135 make_pure_c_string ("Arithmetic underflow error"));
3139 staticpro (&Qunbound
);
3141 /* Types that type-of returns. */
3142 DEFSYM (Qinteger
, "integer");
3143 DEFSYM (Qsymbol
, "symbol");
3144 DEFSYM (Qstring
, "string");
3145 DEFSYM (Qcons
, "cons");
3146 DEFSYM (Qmarker
, "marker");
3147 DEFSYM (Qoverlay
, "overlay");
3148 DEFSYM (Qfloat
, "float");
3149 DEFSYM (Qwindow_configuration
, "window-configuration");
3150 DEFSYM (Qprocess
, "process");
3151 DEFSYM (Qwindow
, "window");
3152 /* DEFSYM (Qsubr, "subr"); */
3153 DEFSYM (Qcompiled_function
, "compiled-function");
3154 DEFSYM (Qbuffer
, "buffer");
3155 DEFSYM (Qframe
, "frame");
3156 DEFSYM (Qvector
, "vector");
3157 DEFSYM (Qchar_table
, "char-table");
3158 DEFSYM (Qbool_vector
, "bool-vector");
3159 DEFSYM (Qhash_table
, "hash-table");
3161 DEFSYM (Qfont_spec
, "font-spec");
3162 DEFSYM (Qfont_entity
, "font-entity");
3163 DEFSYM (Qfont_object
, "font-object");
3165 DEFSYM (Qinteractive_form
, "interactive-form");
3167 defsubr (&Sindirect_variable
);
3168 defsubr (&Sinteractive_form
);
3171 defsubr (&Stype_of
);
3176 defsubr (&Sintegerp
);
3177 defsubr (&Sinteger_or_marker_p
);
3178 defsubr (&Snumberp
);
3179 defsubr (&Snumber_or_marker_p
);
3181 defsubr (&Snatnump
);
3182 defsubr (&Ssymbolp
);
3183 defsubr (&Skeywordp
);
3184 defsubr (&Sstringp
);
3185 defsubr (&Smultibyte_string_p
);
3186 defsubr (&Svectorp
);
3187 defsubr (&Schar_table_p
);
3188 defsubr (&Svector_or_char_table_p
);
3189 defsubr (&Sbool_vector_p
);
3191 defsubr (&Ssequencep
);
3192 defsubr (&Sbufferp
);
3193 defsubr (&Smarkerp
);
3195 defsubr (&Sbyte_code_function_p
);
3196 defsubr (&Schar_or_string_p
);
3199 defsubr (&Scar_safe
);
3200 defsubr (&Scdr_safe
);
3203 defsubr (&Ssymbol_function
);
3204 defsubr (&Sindirect_function
);
3205 defsubr (&Ssymbol_plist
);
3206 defsubr (&Ssymbol_name
);
3207 defsubr (&Smakunbound
);
3208 defsubr (&Sfmakunbound
);
3210 defsubr (&Sfboundp
);
3212 defsubr (&Sdefalias
);
3213 defsubr (&Ssetplist
);
3214 defsubr (&Ssymbol_value
);
3216 defsubr (&Sdefault_boundp
);
3217 defsubr (&Sdefault_value
);
3218 defsubr (&Sset_default
);
3219 defsubr (&Ssetq_default
);
3220 defsubr (&Smake_variable_buffer_local
);
3221 defsubr (&Smake_local_variable
);
3222 defsubr (&Skill_local_variable
);
3223 defsubr (&Smake_variable_frame_local
);
3224 defsubr (&Slocal_variable_p
);
3225 defsubr (&Slocal_variable_if_set_p
);
3226 defsubr (&Svariable_binding_locus
);
3227 #if 0 /* XXX Remove this. --lorentey */
3228 defsubr (&Sterminal_local_value
);
3229 defsubr (&Sset_terminal_local_value
);
3233 defsubr (&Snumber_to_string
);
3234 defsubr (&Sstring_to_number
);
3235 defsubr (&Seqlsign
);
3258 defsubr (&Sbyteorder
);
3259 defsubr (&Ssubr_arity
);
3260 defsubr (&Ssubr_name
);
3262 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3264 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3265 doc
: /* The largest value that is representable in a Lisp integer. */);
3266 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3267 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3269 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3270 doc
: /* The smallest value that is representable in a Lisp integer. */);
3271 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3272 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3275 #ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
3276 static void arith_error (int) NO_RETURN
;
3280 arith_error (int signo
)
3282 sigsetmask (SIGEMPTYMASK
);
3284 SIGNAL_THREAD_CHECK (signo
);
3285 xsignal0 (Qarith_error
);
3291 /* Don't do this if just dumping out.
3292 We don't want to call `signal' in this case
3293 so that we don't have trouble with dumping
3294 signal-delivering routines in an inconsistent state. */
3298 #endif /* CANNOT_DUMP */
3299 signal (SIGFPE
, arith_error
);