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
;
93 static Lisp_Object Qcompiled_function
, Qframe
, Qvector
;
95 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
96 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
97 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
99 Lisp_Object Qinteractive_form
;
101 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
105 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
107 /* If VALUE is not even a valid Lisp object, we'd want to abort here
108 where we can get a backtrace showing where it came from. We used
109 to try and do that by checking the tagbits, but nowadays all
110 tagbits are potentially valid. */
111 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
114 xsignal2 (Qwrong_type_argument
, predicate
, value
);
118 pure_write_error (void)
120 error ("Attempt to modify read-only object");
124 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
126 xsignal2 (Qargs_out_of_range
, a1
, a2
);
130 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
132 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
136 /* Data type predicates */
138 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
139 doc
: /* Return t if the two args are the same Lisp object. */)
140 (Lisp_Object obj1
, Lisp_Object obj2
)
147 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
148 doc
: /* Return t if OBJECT is nil. */)
156 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
157 doc
: /* Return a symbol representing the type of OBJECT.
158 The symbol returned names the object's basic type;
159 for example, (type-of 1) returns `integer'. */)
162 switch (XTYPE (object
))
177 switch (XMISCTYPE (object
))
179 case Lisp_Misc_Marker
:
181 case Lisp_Misc_Overlay
:
183 case Lisp_Misc_Float
:
188 case Lisp_Vectorlike
:
189 if (WINDOW_CONFIGURATIONP (object
))
190 return Qwindow_configuration
;
191 if (PROCESSP (object
))
193 if (WINDOWP (object
))
197 if (COMPILEDP (object
))
198 return Qcompiled_function
;
199 if (BUFFERP (object
))
201 if (CHAR_TABLE_P (object
))
203 if (BOOL_VECTOR_P (object
))
207 if (HASH_TABLE_P (object
))
209 if (FONT_SPEC_P (object
))
211 if (FONT_ENTITY_P (object
))
213 if (FONT_OBJECT_P (object
))
225 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
226 doc
: /* Return t if OBJECT is a cons cell. */)
234 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
235 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
243 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
244 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
245 Otherwise, return nil. */)
248 if (CONSP (object
) || NILP (object
))
253 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
254 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
257 if (CONSP (object
) || NILP (object
))
262 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
263 doc
: /* Return t if OBJECT is a symbol. */)
266 if (SYMBOLP (object
))
271 /* Define this in C to avoid unnecessarily consing up the symbol
273 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
274 doc
: /* Return t if OBJECT is a keyword.
275 This means that it is a symbol with a print name beginning with `:'
276 interned in the initial obarray. */)
280 && SREF (SYMBOL_NAME (object
), 0) == ':'
281 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
286 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
287 doc
: /* Return t if OBJECT is a vector. */)
290 if (VECTORP (object
))
295 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
296 doc
: /* Return t if OBJECT is a string. */)
299 if (STRINGP (object
))
304 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
306 doc
: /* Return t if OBJECT is a multibyte string. */)
309 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
314 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
315 doc
: /* Return t if OBJECT is a char-table. */)
318 if (CHAR_TABLE_P (object
))
323 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
324 Svector_or_char_table_p
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a char-table or vector. */)
328 if (VECTORP (object
) || CHAR_TABLE_P (object
))
333 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is a bool-vector. */)
337 if (BOOL_VECTOR_P (object
))
342 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
343 doc
: /* Return t if OBJECT is an array (string or vector). */)
351 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a sequence (list or array). */)
353 (register Lisp_Object object
)
355 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
360 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
361 doc
: /* Return t if OBJECT is an editor buffer. */)
364 if (BUFFERP (object
))
369 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
373 if (MARKERP (object
))
378 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
379 doc
: /* Return t if OBJECT is a built-in function. */)
387 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
389 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
392 if (COMPILEDP (object
))
397 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is a character or a string. */)
399 (register Lisp_Object object
)
401 if (CHARACTERP (object
) || STRINGP (object
))
406 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is an integer. */)
410 if (INTEGERP (object
))
415 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
416 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
417 (register Lisp_Object object
)
419 if (MARKERP (object
) || INTEGERP (object
))
424 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a nonnegative integer. */)
428 if (NATNUMP (object
))
433 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
434 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
437 if (NUMBERP (object
))
443 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
444 Snumber_or_marker_p
, 1, 1, 0,
445 doc
: /* Return t if OBJECT is a number or a marker. */)
448 if (NUMBERP (object
) || MARKERP (object
))
453 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
454 doc
: /* Return t if OBJECT is a floating point number. */)
463 /* Extract and set components of lists */
465 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
466 doc
: /* Return the car of LIST. If arg is nil, return nil.
467 Error if arg is not nil and not a cons cell. See also `car-safe'.
469 See Info node `(elisp)Cons Cells' for a discussion of related basic
470 Lisp concepts such as car, cdr, cons cell and list. */)
471 (register Lisp_Object list
)
476 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
477 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
480 return CAR_SAFE (object
);
483 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
484 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
485 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
487 See Info node `(elisp)Cons Cells' for a discussion of related basic
488 Lisp concepts such as cdr, car, cons cell and list. */)
489 (register Lisp_Object list
)
494 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
495 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
498 return CDR_SAFE (object
);
501 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
502 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
503 (register Lisp_Object cell
, Lisp_Object newcar
)
507 XSETCAR (cell
, newcar
);
511 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
512 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
513 (register Lisp_Object cell
, Lisp_Object newcdr
)
517 XSETCDR (cell
, newcdr
);
521 /* Extract and set components of symbols */
523 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
524 doc
: /* Return t if SYMBOL's value is not void. */)
525 (register Lisp_Object symbol
)
527 Lisp_Object valcontents
;
528 struct Lisp_Symbol
*sym
;
529 CHECK_SYMBOL (symbol
);
530 sym
= XSYMBOL (symbol
);
533 switch (sym
->redirect
)
535 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
536 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
537 case SYMBOL_LOCALIZED
:
539 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
541 /* In set_internal, we un-forward vars when their value is
546 swap_in_symval_forwarding (sym
, blv
);
547 valcontents
= BLV_VALUE (blv
);
551 case SYMBOL_FORWARDED
:
552 /* In set_internal, we un-forward vars when their value is
558 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
561 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
562 doc
: /* Return t if SYMBOL's function definition is not void. */)
563 (register Lisp_Object symbol
)
565 CHECK_SYMBOL (symbol
);
566 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
569 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
570 doc
: /* Make SYMBOL's value be void.
572 (register Lisp_Object symbol
)
574 CHECK_SYMBOL (symbol
);
575 if (SYMBOL_CONSTANT_P (symbol
))
576 xsignal1 (Qsetting_constant
, symbol
);
577 Fset (symbol
, Qunbound
);
581 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
582 doc
: /* Make SYMBOL's function definition be void.
584 (register Lisp_Object symbol
)
586 CHECK_SYMBOL (symbol
);
587 if (NILP (symbol
) || EQ (symbol
, Qt
))
588 xsignal1 (Qsetting_constant
, symbol
);
589 XSYMBOL (symbol
)->function
= Qunbound
;
593 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
594 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
595 (register Lisp_Object symbol
)
597 CHECK_SYMBOL (symbol
);
598 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
599 return XSYMBOL (symbol
)->function
;
600 xsignal1 (Qvoid_function
, symbol
);
603 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
604 doc
: /* Return SYMBOL's property list. */)
605 (register Lisp_Object symbol
)
607 CHECK_SYMBOL (symbol
);
608 return XSYMBOL (symbol
)->plist
;
611 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
612 doc
: /* Return SYMBOL's name, a string. */)
613 (register Lisp_Object symbol
)
615 register Lisp_Object name
;
617 CHECK_SYMBOL (symbol
);
618 name
= SYMBOL_NAME (symbol
);
622 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
623 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
624 (register Lisp_Object symbol
, Lisp_Object definition
)
626 register Lisp_Object function
;
628 CHECK_SYMBOL (symbol
);
629 if (NILP (symbol
) || EQ (symbol
, Qt
))
630 xsignal1 (Qsetting_constant
, symbol
);
632 function
= XSYMBOL (symbol
)->function
;
634 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
635 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
637 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
638 Fput (symbol
, Qautoload
, XCDR (function
));
640 XSYMBOL (symbol
)->function
= definition
;
641 /* Handle automatic advice activation */
642 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
644 call2 (Qad_activate_internal
, symbol
, Qnil
);
645 definition
= XSYMBOL (symbol
)->function
;
650 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
651 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
652 Associates the function with the current load file, if any.
653 The optional third argument DOCSTRING specifies the documentation string
654 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
655 determined by DEFINITION. */)
656 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
658 CHECK_SYMBOL (symbol
);
659 if (CONSP (XSYMBOL (symbol
)->function
)
660 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
661 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
662 definition
= Ffset (symbol
, definition
);
663 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
664 if (!NILP (docstring
))
665 Fput (symbol
, Qfunction_documentation
, docstring
);
669 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
670 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
671 (register Lisp_Object symbol
, Lisp_Object newplist
)
673 CHECK_SYMBOL (symbol
);
674 XSYMBOL (symbol
)->plist
= newplist
;
678 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
679 doc
: /* Return minimum and maximum number of args allowed for SUBR.
680 SUBR must be a built-in function.
681 The returned value is a pair (MIN . MAX). MIN is the minimum number
682 of args. MAX is the maximum number or the symbol `many', for a
683 function with `&rest' args, or `unevalled' for a special form. */)
686 short minargs
, maxargs
;
688 minargs
= XSUBR (subr
)->min_args
;
689 maxargs
= XSUBR (subr
)->max_args
;
691 return Fcons (make_number (minargs
), Qmany
);
692 else if (maxargs
== UNEVALLED
)
693 return Fcons (make_number (minargs
), Qunevalled
);
695 return Fcons (make_number (minargs
), make_number (maxargs
));
698 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
699 doc
: /* Return name of subroutine SUBR.
700 SUBR must be a built-in function. */)
705 name
= XSUBR (subr
)->symbol_name
;
706 return make_string (name
, strlen (name
));
709 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
710 doc
: /* Return the interactive form of CMD or nil if none.
711 If CMD is not a command, the return value is nil.
712 Value, if non-nil, is a list \(interactive SPEC). */)
715 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
717 if (NILP (fun
) || EQ (fun
, Qunbound
))
720 /* Use an `interactive-form' property if present, analogous to the
721 function-documentation property. */
723 while (SYMBOLP (fun
))
725 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
729 fun
= Fsymbol_function (fun
);
734 const char *spec
= XSUBR (fun
)->intspec
;
736 return list2 (Qinteractive
,
737 (*spec
!= '(') ? build_string (spec
) :
738 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
740 else if (COMPILEDP (fun
))
742 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
743 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
745 else if (CONSP (fun
))
747 Lisp_Object funcar
= XCAR (fun
);
748 if (EQ (funcar
, Qclosure
))
749 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
750 else if (EQ (funcar
, Qlambda
))
751 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
752 else if (EQ (funcar
, Qautoload
))
756 do_autoload (fun
, cmd
);
758 return Finteractive_form (cmd
);
765 /***********************************************************************
766 Getting and Setting Values of Symbols
767 ***********************************************************************/
769 /* Return the symbol holding SYMBOL's value. Signal
770 `cyclic-variable-indirection' if SYMBOL's chain of variable
771 indirections contains a loop. */
774 indirect_variable (struct Lisp_Symbol
*symbol
)
776 struct Lisp_Symbol
*tortoise
, *hare
;
778 hare
= tortoise
= symbol
;
780 while (hare
->redirect
== SYMBOL_VARALIAS
)
782 hare
= SYMBOL_ALIAS (hare
);
783 if (hare
->redirect
!= SYMBOL_VARALIAS
)
786 hare
= SYMBOL_ALIAS (hare
);
787 tortoise
= SYMBOL_ALIAS (tortoise
);
789 if (hare
== tortoise
)
792 XSETSYMBOL (tem
, symbol
);
793 xsignal1 (Qcyclic_variable_indirection
, tem
);
801 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
802 doc
: /* Return the variable at the end of OBJECT's variable chain.
803 If OBJECT is a symbol, follow all variable indirections and return the final
804 variable. If OBJECT is not a symbol, just return it.
805 Signal a cyclic-variable-indirection error if there is a loop in the
806 variable chain of symbols. */)
809 if (SYMBOLP (object
))
811 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
812 XSETSYMBOL (object
, sym
);
818 /* Given the raw contents of a symbol value cell,
819 return the Lisp value of the symbol.
820 This does not handle buffer-local variables; use
821 swap_in_symval_forwarding for that. */
824 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
826 register Lisp_Object val
;
827 switch (XFWDTYPE (valcontents
))
830 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
834 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
837 return *XOBJFWD (valcontents
)->objvar
;
839 case Lisp_Fwd_Buffer_Obj
:
840 return PER_BUFFER_VALUE (current_buffer
,
841 XBUFFER_OBJFWD (valcontents
)->offset
);
843 case Lisp_Fwd_Kboard_Obj
:
844 /* We used to simply use current_kboard here, but from Lisp
845 code, it's value is often unexpected. It seems nicer to
846 allow constructions like this to work as intuitively expected:
848 (with-selected-frame frame
849 (define-key local-function-map "\eOP" [f1]))
851 On the other hand, this affects the semantics of
852 last-command and real-last-command, and people may rely on
853 that. I took a quick look at the Lisp codebase, and I
854 don't think anything will break. --lorentey */
855 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
856 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
861 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
862 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
863 buffer-independent contents of the value cell: forwarded just one
864 step past the buffer-localness.
866 BUF non-zero means set the value in buffer BUF instead of the
867 current buffer. This only plays a role for per-buffer variables. */
870 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
872 switch (XFWDTYPE (valcontents
))
875 CHECK_NUMBER (newval
);
876 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
880 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
884 *XOBJFWD (valcontents
)->objvar
= newval
;
886 /* If this variable is a default for something stored
887 in the buffer itself, such as default-fill-column,
888 find the buffers that don't have local values for it
890 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
891 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
893 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
894 - (char *) &buffer_defaults
);
895 int idx
= PER_BUFFER_IDX (offset
);
902 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
907 lbuf
= Fcdr (XCAR (tail
));
908 if (!BUFFERP (lbuf
)) continue;
911 if (! PER_BUFFER_VALUE_P (b
, idx
))
912 PER_BUFFER_VALUE (b
, offset
) = newval
;
917 case Lisp_Fwd_Buffer_Obj
:
919 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
920 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
922 if (!(NILP (type
) || NILP (newval
)
923 || (XINT (type
) == LISP_INT_TAG
925 : XTYPE (newval
) == XINT (type
))))
926 buffer_slot_type_mismatch (newval
, XINT (type
));
929 buf
= current_buffer
;
930 PER_BUFFER_VALUE (buf
, offset
) = newval
;
934 case Lisp_Fwd_Kboard_Obj
:
936 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
937 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
938 *(Lisp_Object
*) p
= newval
;
943 abort (); /* goto def; */
947 /* Set up SYMBOL to refer to its global binding.
948 This makes it safe to alter the status of other bindings. */
951 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
953 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
955 /* Unload the previously loaded binding. */
957 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
959 /* Select the global binding in the symbol. */
960 blv
->valcell
= blv
->defcell
;
962 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
964 /* Indicate that the global binding is set up now. */
966 SET_BLV_FOUND (blv
, 0);
969 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
970 VALCONTENTS is the contents of its value cell,
971 which points to a struct Lisp_Buffer_Local_Value.
973 Return the value forwarded one step past the buffer-local stage.
974 This could be another forwarding pointer. */
977 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
979 register Lisp_Object tem1
;
981 eassert (blv
== SYMBOL_BLV (symbol
));
987 ? !EQ (selected_frame
, tem1
)
988 : current_buffer
!= XBUFFER (tem1
)))
991 /* Unload the previously loaded binding. */
994 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
995 /* Choose the new binding. */
998 XSETSYMBOL (var
, symbol
);
999 if (blv
->frame_local
)
1001 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1002 blv
->where
= selected_frame
;
1006 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1007 XSETBUFFER (blv
->where
, current_buffer
);
1010 if (!(blv
->found
= !NILP (tem1
)))
1011 tem1
= blv
->defcell
;
1013 /* Load the new binding. */
1014 blv
->valcell
= tem1
;
1016 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1020 /* Find the value of a symbol, returning Qunbound if it's not bound.
1021 This is helpful for code which just wants to get a variable's value
1022 if it has one, without signaling an error.
1023 Note that it must not be possible to quit
1024 within this function. Great care is required for this. */
1027 find_symbol_value (Lisp_Object symbol
)
1029 struct Lisp_Symbol
*sym
;
1031 CHECK_SYMBOL (symbol
);
1032 sym
= XSYMBOL (symbol
);
1035 switch (sym
->redirect
)
1037 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1038 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1039 case SYMBOL_LOCALIZED
:
1041 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1042 swap_in_symval_forwarding (sym
, blv
);
1043 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1046 case SYMBOL_FORWARDED
:
1047 return do_symval_forwarding (SYMBOL_FWD (sym
));
1052 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1053 doc
: /* Return SYMBOL's value. Error if that is void. */)
1054 (Lisp_Object symbol
)
1058 val
= find_symbol_value (symbol
);
1059 if (!EQ (val
, Qunbound
))
1062 xsignal1 (Qvoid_variable
, symbol
);
1065 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1066 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1067 (register Lisp_Object symbol
, Lisp_Object newval
)
1069 set_internal (symbol
, newval
, Qnil
, 0);
1073 /* Return 1 if SYMBOL currently has a let-binding
1074 which was made in the buffer that is now current. */
1077 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1079 struct specbinding
*p
;
1081 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1083 && CONSP (p
->symbol
))
1085 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1086 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1087 if (symbol
== let_bound_symbol
1088 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1092 return p
>= specpdl
;
1096 let_shadows_global_binding_p (Lisp_Object symbol
)
1098 struct specbinding
*p
;
1100 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1101 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1104 return p
>= specpdl
;
1107 /* Store the value NEWVAL into SYMBOL.
1108 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1109 (nil stands for the current buffer/frame).
1111 If BINDFLAG is zero, then if this symbol is supposed to become
1112 local in every buffer where it is set, then we make it local.
1113 If BINDFLAG is nonzero, we don't do that. */
1116 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1118 int voide
= EQ (newval
, Qunbound
);
1119 struct Lisp_Symbol
*sym
;
1122 /* If restoring in a dead buffer, do nothing. */
1123 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1126 CHECK_SYMBOL (symbol
);
1127 if (SYMBOL_CONSTANT_P (symbol
))
1129 if (NILP (Fkeywordp (symbol
))
1130 || !EQ (newval
, Fsymbol_value (symbol
)))
1131 xsignal1 (Qsetting_constant
, symbol
);
1133 /* Allow setting keywords to their own value. */
1137 sym
= XSYMBOL (symbol
);
1140 switch (sym
->redirect
)
1142 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1143 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1144 case SYMBOL_LOCALIZED
:
1146 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1149 if (blv
->frame_local
)
1150 where
= selected_frame
;
1152 XSETBUFFER (where
, current_buffer
);
1154 /* If the current buffer is not the buffer whose binding is
1155 loaded, or if there may be frame-local bindings and the frame
1156 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1157 the default binding is loaded, the loaded binding may be the
1159 if (!EQ (blv
->where
, where
)
1160 /* Also unload a global binding (if the var is local_if_set). */
1161 || (EQ (blv
->valcell
, blv
->defcell
)))
1163 /* The currently loaded binding is not necessarily valid.
1164 We need to unload it, and choose a new binding. */
1166 /* Write out `realvalue' to the old loaded binding. */
1168 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1170 /* Find the new binding. */
1171 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1172 tem1
= Fassq (symbol
,
1174 ? XFRAME (where
)->param_alist
1175 : BVAR (XBUFFER (where
), local_var_alist
)));
1181 /* This buffer still sees the default value. */
1183 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1184 or if this is `let' rather than `set',
1185 make CURRENT-ALIST-ELEMENT point to itself,
1186 indicating that we're seeing the default value.
1187 Likewise if the variable has been let-bound
1188 in the current buffer. */
1189 if (bindflag
|| !blv
->local_if_set
1190 || let_shadows_buffer_binding_p (sym
))
1193 tem1
= blv
->defcell
;
1195 /* If it's a local_if_set, being set not bound,
1196 and we're not within a let that was made for this buffer,
1197 create a new buffer-local binding for the variable.
1198 That means, give this buffer a new assoc for a local value
1199 and load that binding. */
1202 /* local_if_set is only supported for buffer-local
1203 bindings, not for frame-local bindings. */
1204 eassert (!blv
->frame_local
);
1205 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1206 BVAR (XBUFFER (where
), local_var_alist
)
1207 = Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
));
1211 /* Record which binding is now loaded. */
1212 blv
->valcell
= tem1
;
1215 /* Store the new value in the cons cell. */
1216 SET_BLV_VALUE (blv
, newval
);
1221 /* If storing void (making the symbol void), forward only through
1222 buffer-local indicator, not through Lisp_Objfwd, etc. */
1225 store_symval_forwarding (blv
->fwd
, newval
,
1227 ? XBUFFER (where
) : current_buffer
);
1231 case SYMBOL_FORWARDED
:
1234 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1235 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1236 if (BUFFER_OBJFWDP (innercontents
))
1238 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1239 int idx
= PER_BUFFER_IDX (offset
);
1242 && !let_shadows_buffer_binding_p (sym
))
1243 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1247 { /* If storing void (making the symbol void), forward only through
1248 buffer-local indicator, not through Lisp_Objfwd, etc. */
1249 sym
->redirect
= SYMBOL_PLAINVAL
;
1250 SET_SYMBOL_VAL (sym
, newval
);
1253 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1261 /* Access or set a buffer-local symbol's default value. */
1263 /* Return the default value of SYMBOL, but don't check for voidness.
1264 Return Qunbound if it is void. */
1267 default_value (Lisp_Object symbol
)
1269 struct Lisp_Symbol
*sym
;
1271 CHECK_SYMBOL (symbol
);
1272 sym
= XSYMBOL (symbol
);
1275 switch (sym
->redirect
)
1277 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1278 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1279 case SYMBOL_LOCALIZED
:
1281 /* If var is set up for a buffer that lacks a local value for it,
1282 the current value is nominally the default value.
1283 But the `realvalue' slot may be more up to date, since
1284 ordinary setq stores just that slot. So use that. */
1285 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1286 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1287 return do_symval_forwarding (blv
->fwd
);
1289 return XCDR (blv
->defcell
);
1291 case SYMBOL_FORWARDED
:
1293 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1295 /* For a built-in buffer-local variable, get the default value
1296 rather than letting do_symval_forwarding get the current value. */
1297 if (BUFFER_OBJFWDP (valcontents
))
1299 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1300 if (PER_BUFFER_IDX (offset
) != 0)
1301 return PER_BUFFER_DEFAULT (offset
);
1304 /* For other variables, get the current value. */
1305 return do_symval_forwarding (valcontents
);
1311 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1312 doc
: /* Return t if SYMBOL has a non-void default value.
1313 This is the value that is seen in buffers that do not have their own values
1314 for this variable. */)
1315 (Lisp_Object symbol
)
1317 register Lisp_Object value
;
1319 value
= default_value (symbol
);
1320 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1323 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1324 doc
: /* Return SYMBOL's default value.
1325 This is the value that is seen in buffers that do not have their own values
1326 for this variable. The default value is meaningful for variables with
1327 local bindings in certain buffers. */)
1328 (Lisp_Object symbol
)
1330 register Lisp_Object value
;
1332 value
= default_value (symbol
);
1333 if (!EQ (value
, Qunbound
))
1336 xsignal1 (Qvoid_variable
, symbol
);
1339 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1340 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1341 The default value is seen in buffers that do not have their own values
1342 for this variable. */)
1343 (Lisp_Object symbol
, Lisp_Object value
)
1345 struct Lisp_Symbol
*sym
;
1347 CHECK_SYMBOL (symbol
);
1348 if (SYMBOL_CONSTANT_P (symbol
))
1350 if (NILP (Fkeywordp (symbol
))
1351 || !EQ (value
, Fdefault_value (symbol
)))
1352 xsignal1 (Qsetting_constant
, symbol
);
1354 /* Allow setting keywords to their own value. */
1357 sym
= XSYMBOL (symbol
);
1360 switch (sym
->redirect
)
1362 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1363 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1364 case SYMBOL_LOCALIZED
:
1366 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1368 /* Store new value into the DEFAULT-VALUE slot. */
1369 XSETCDR (blv
->defcell
, value
);
1371 /* If the default binding is now loaded, set the REALVALUE slot too. */
1372 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1373 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1376 case SYMBOL_FORWARDED
:
1378 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1380 /* Handle variables like case-fold-search that have special slots
1382 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1383 if (BUFFER_OBJFWDP (valcontents
))
1385 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1386 int idx
= PER_BUFFER_IDX (offset
);
1388 PER_BUFFER_DEFAULT (offset
) = value
;
1390 /* If this variable is not always local in all buffers,
1391 set it in the buffers that don't nominally have a local value. */
1396 for (b
= all_buffers
; b
; b
= b
->header
.next
.buffer
)
1397 if (!PER_BUFFER_VALUE_P (b
, idx
))
1398 PER_BUFFER_VALUE (b
, offset
) = value
;
1403 return Fset (symbol
, value
);
1409 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1410 doc
: /* Set the default value of variable VAR to VALUE.
1411 VAR, the variable name, is literal (not evaluated);
1412 VALUE is an expression: it is evaluated and its value returned.
1413 The default value of a variable is seen in buffers
1414 that do not have their own values for the variable.
1416 More generally, you can use multiple variables and values, as in
1417 (setq-default VAR VALUE VAR VALUE...)
1418 This sets each VAR's default value to the corresponding VALUE.
1419 The VALUE for the Nth VAR can refer to the new default values
1421 usage: (setq-default [VAR VALUE]...) */)
1424 register Lisp_Object args_left
;
1425 register Lisp_Object val
, symbol
;
1426 struct gcpro gcpro1
;
1436 val
= eval_sub (Fcar (Fcdr (args_left
)));
1437 symbol
= XCAR (args_left
);
1438 Fset_default (symbol
, val
);
1439 args_left
= Fcdr (XCDR (args_left
));
1441 while (!NILP (args_left
));
1447 /* Lisp functions for creating and removing buffer-local variables. */
1452 union Lisp_Fwd
*fwd
;
1455 static struct Lisp_Buffer_Local_Value
*
1456 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1458 struct Lisp_Buffer_Local_Value
*blv
1459 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1463 XSETSYMBOL (symbol
, sym
);
1464 tem
= Fcons (symbol
, (forwarded
1465 ? do_symval_forwarding (valcontents
.fwd
)
1466 : valcontents
.value
));
1468 /* Buffer_Local_Values cannot have as realval a buffer-local
1469 or keyboard-local forwarding. */
1470 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1471 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1472 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1474 blv
->frame_local
= 0;
1475 blv
->local_if_set
= 0;
1478 SET_BLV_FOUND (blv
, 0);
1482 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1483 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1484 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1485 At any time, the value for the current buffer is in effect,
1486 unless the variable has never been set in this buffer,
1487 in which case the default value is in effect.
1488 Note that binding the variable with `let', or setting it while
1489 a `let'-style binding made in this buffer is in effect,
1490 does not make the variable buffer-local. Return VARIABLE.
1492 In most cases it is better to use `make-local-variable',
1493 which makes a variable local in just one buffer.
1495 The function `default-value' gets the default value and `set-default' sets it. */)
1496 (register Lisp_Object variable
)
1498 struct Lisp_Symbol
*sym
;
1499 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1500 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1501 int forwarded
IF_LINT (= 0);
1503 CHECK_SYMBOL (variable
);
1504 sym
= XSYMBOL (variable
);
1507 switch (sym
->redirect
)
1509 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1510 case SYMBOL_PLAINVAL
:
1511 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1512 if (EQ (valcontents
.value
, Qunbound
))
1513 valcontents
.value
= Qnil
;
1515 case SYMBOL_LOCALIZED
:
1516 blv
= SYMBOL_BLV (sym
);
1517 if (blv
->frame_local
)
1518 error ("Symbol %s may not be buffer-local",
1519 SDATA (SYMBOL_NAME (variable
)));
1521 case SYMBOL_FORWARDED
:
1522 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1523 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1524 error ("Symbol %s may not be buffer-local",
1525 SDATA (SYMBOL_NAME (variable
)));
1526 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1533 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1537 blv
= make_blv (sym
, forwarded
, valcontents
);
1538 sym
->redirect
= SYMBOL_LOCALIZED
;
1539 SET_SYMBOL_BLV (sym
, blv
);
1542 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1543 if (let_shadows_global_binding_p (symbol
))
1544 message ("Making %s buffer-local while let-bound!",
1545 SDATA (SYMBOL_NAME (variable
)));
1549 blv
->local_if_set
= 1;
1553 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1554 1, 1, "vMake Local Variable: ",
1555 doc
: /* Make VARIABLE have a separate value in the current buffer.
1556 Other buffers will continue to share a common default value.
1557 \(The buffer-local value of VARIABLE starts out as the same value
1558 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1561 If the variable is already arranged to become local when set,
1562 this function causes a local value to exist for this buffer,
1563 just as setting the variable would do.
1565 This function returns VARIABLE, and therefore
1566 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1569 See also `make-variable-buffer-local'.
1571 Do not use `make-local-variable' to make a hook variable buffer-local.
1572 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1573 (register Lisp_Object variable
)
1575 register Lisp_Object tem
;
1576 int forwarded
IF_LINT (= 0);
1577 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1578 struct Lisp_Symbol
*sym
;
1579 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1581 CHECK_SYMBOL (variable
);
1582 sym
= XSYMBOL (variable
);
1585 switch (sym
->redirect
)
1587 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1588 case SYMBOL_PLAINVAL
:
1589 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1590 case SYMBOL_LOCALIZED
:
1591 blv
= SYMBOL_BLV (sym
);
1592 if (blv
->frame_local
)
1593 error ("Symbol %s may not be buffer-local",
1594 SDATA (SYMBOL_NAME (variable
)));
1596 case SYMBOL_FORWARDED
:
1597 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1598 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1599 error ("Symbol %s may not be buffer-local",
1600 SDATA (SYMBOL_NAME (variable
)));
1606 error ("Symbol %s may not be buffer-local",
1607 SDATA (SYMBOL_NAME (variable
)));
1609 if (blv
? blv
->local_if_set
1610 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1612 tem
= Fboundp (variable
);
1613 /* Make sure the symbol has a local value in this particular buffer,
1614 by setting it to the same value it already has. */
1615 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1620 blv
= make_blv (sym
, forwarded
, valcontents
);
1621 sym
->redirect
= SYMBOL_LOCALIZED
;
1622 SET_SYMBOL_BLV (sym
, blv
);
1625 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1626 if (let_shadows_global_binding_p (symbol
))
1627 message ("Making %s local to %s while let-bound!",
1628 SDATA (SYMBOL_NAME (variable
)),
1629 SDATA (BVAR (current_buffer
, name
)));
1633 /* Make sure this buffer has its own value of symbol. */
1634 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1635 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1638 if (let_shadows_buffer_binding_p (sym
))
1639 message ("Making %s buffer-local while locally let-bound!",
1640 SDATA (SYMBOL_NAME (variable
)));
1642 /* Swap out any local binding for some other buffer, and make
1643 sure the current value is permanently recorded, if it's the
1645 find_symbol_value (variable
);
1647 BVAR (current_buffer
, local_var_alist
)
1648 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1649 BVAR (current_buffer
, local_var_alist
));
1651 /* Make sure symbol does not think it is set up for this buffer;
1652 force it to look once again for this buffer's value. */
1653 if (current_buffer
== XBUFFER (blv
->where
))
1655 /* blv->valcell = blv->defcell;
1656 * SET_BLV_FOUND (blv, 0); */
1660 /* If the symbol forwards into a C variable, then load the binding
1661 for this buffer now. If C code modifies the variable before we
1662 load the binding in, then that new value will clobber the default
1663 binding the next time we unload it. */
1665 swap_in_symval_forwarding (sym
, blv
);
1670 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1671 1, 1, "vKill Local Variable: ",
1672 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1673 From now on the default value will apply in this buffer. Return VARIABLE. */)
1674 (register Lisp_Object variable
)
1676 register Lisp_Object tem
;
1677 struct Lisp_Buffer_Local_Value
*blv
;
1678 struct Lisp_Symbol
*sym
;
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
: return variable
;
1688 case SYMBOL_FORWARDED
:
1690 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1691 if (BUFFER_OBJFWDP (valcontents
))
1693 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1694 int idx
= PER_BUFFER_IDX (offset
);
1698 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1699 PER_BUFFER_VALUE (current_buffer
, offset
)
1700 = PER_BUFFER_DEFAULT (offset
);
1705 case SYMBOL_LOCALIZED
:
1706 blv
= SYMBOL_BLV (sym
);
1707 if (blv
->frame_local
)
1713 /* Get rid of this buffer's alist element, if any. */
1714 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1715 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1717 BVAR (current_buffer
, local_var_alist
)
1718 = Fdelq (tem
, BVAR (current_buffer
, local_var_alist
));
1720 /* If the symbol is set up with the current buffer's binding
1721 loaded, recompute its value. We have to do it now, or else
1722 forwarded objects won't work right. */
1724 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1725 if (EQ (buf
, blv
->where
))
1728 /* blv->valcell = blv->defcell;
1729 * SET_BLV_FOUND (blv, 0); */
1731 find_symbol_value (variable
);
1738 /* Lisp functions for creating and removing buffer-local variables. */
1740 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1741 when/if this is removed. */
1743 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1744 1, 1, "vMake Variable Frame Local: ",
1745 doc
: /* Enable VARIABLE to have frame-local bindings.
1746 This does not create any frame-local bindings for VARIABLE,
1747 it just makes them possible.
1749 A frame-local binding is actually a frame parameter value.
1750 If a frame F has a value for the frame parameter named VARIABLE,
1751 that also acts as a frame-local binding for VARIABLE in F--
1752 provided this function has been called to enable VARIABLE
1753 to have frame-local bindings at all.
1755 The only way to create a frame-local binding for VARIABLE in a frame
1756 is to set the VARIABLE frame parameter of that frame. See
1757 `modify-frame-parameters' for how to set frame parameters.
1759 Note that since Emacs 23.1, variables cannot be both buffer-local and
1760 frame-local any more (buffer-local bindings used to take precedence over
1761 frame-local bindings). */)
1762 (register Lisp_Object variable
)
1765 union Lisp_Val_Fwd valcontents
;
1766 struct Lisp_Symbol
*sym
;
1767 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1769 CHECK_SYMBOL (variable
);
1770 sym
= XSYMBOL (variable
);
1773 switch (sym
->redirect
)
1775 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1776 case SYMBOL_PLAINVAL
:
1777 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1778 if (EQ (valcontents
.value
, Qunbound
))
1779 valcontents
.value
= Qnil
;
1781 case SYMBOL_LOCALIZED
:
1782 if (SYMBOL_BLV (sym
)->frame_local
)
1785 error ("Symbol %s may not be frame-local",
1786 SDATA (SYMBOL_NAME (variable
)));
1787 case SYMBOL_FORWARDED
:
1788 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1789 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1790 error ("Symbol %s may not be frame-local",
1791 SDATA (SYMBOL_NAME (variable
)));
1797 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1799 blv
= make_blv (sym
, forwarded
, valcontents
);
1800 blv
->frame_local
= 1;
1801 sym
->redirect
= SYMBOL_LOCALIZED
;
1802 SET_SYMBOL_BLV (sym
, blv
);
1805 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1806 if (let_shadows_global_binding_p (symbol
))
1807 message ("Making %s frame-local while let-bound!",
1808 SDATA (SYMBOL_NAME (variable
)));
1813 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1815 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1816 BUFFER defaults to the current buffer. */)
1817 (register Lisp_Object variable
, Lisp_Object buffer
)
1819 register struct buffer
*buf
;
1820 struct Lisp_Symbol
*sym
;
1823 buf
= current_buffer
;
1826 CHECK_BUFFER (buffer
);
1827 buf
= XBUFFER (buffer
);
1830 CHECK_SYMBOL (variable
);
1831 sym
= XSYMBOL (variable
);
1834 switch (sym
->redirect
)
1836 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1837 case SYMBOL_PLAINVAL
: return Qnil
;
1838 case SYMBOL_LOCALIZED
:
1840 Lisp_Object tail
, elt
, tmp
;
1841 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1842 XSETBUFFER (tmp
, buf
);
1843 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1845 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1848 if (EQ (variable
, XCAR (elt
)))
1850 eassert (!blv
->frame_local
);
1851 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1855 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1858 case SYMBOL_FORWARDED
:
1860 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1861 if (BUFFER_OBJFWDP (valcontents
))
1863 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1864 int idx
= PER_BUFFER_IDX (offset
);
1865 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1874 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1876 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1877 More precisely, this means that setting the variable \(with `set' or`setq'),
1878 while it does not have a `let'-style binding that was made in BUFFER,
1879 will produce a buffer local binding. See Info node
1880 `(elisp)Creating Buffer-Local'.
1881 BUFFER defaults to the current buffer. */)
1882 (register Lisp_Object variable
, Lisp_Object buffer
)
1884 struct Lisp_Symbol
*sym
;
1886 CHECK_SYMBOL (variable
);
1887 sym
= XSYMBOL (variable
);
1890 switch (sym
->redirect
)
1892 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1893 case SYMBOL_PLAINVAL
: return Qnil
;
1894 case SYMBOL_LOCALIZED
:
1896 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1897 if (blv
->local_if_set
)
1899 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1900 return Flocal_variable_p (variable
, buffer
);
1902 case SYMBOL_FORWARDED
:
1903 /* All BUFFER_OBJFWD slots become local if they are set. */
1904 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1909 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1911 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1912 If the current binding is buffer-local, the value is the current buffer.
1913 If the current binding is frame-local, the value is the selected frame.
1914 If the current binding is global (the default), the value is nil. */)
1915 (register Lisp_Object variable
)
1917 struct Lisp_Symbol
*sym
;
1919 CHECK_SYMBOL (variable
);
1920 sym
= XSYMBOL (variable
);
1922 /* Make sure the current binding is actually swapped in. */
1923 find_symbol_value (variable
);
1926 switch (sym
->redirect
)
1928 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1929 case SYMBOL_PLAINVAL
: return Qnil
;
1930 case SYMBOL_FORWARDED
:
1932 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1933 if (KBOARD_OBJFWDP (valcontents
))
1934 return Fframe_terminal (Fselected_frame ());
1935 else if (!BUFFER_OBJFWDP (valcontents
))
1939 case SYMBOL_LOCALIZED
:
1940 /* For a local variable, record both the symbol and which
1941 buffer's or frame's value we are saving. */
1942 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1943 return Fcurrent_buffer ();
1944 else if (sym
->redirect
== SYMBOL_LOCALIZED
1945 && BLV_FOUND (SYMBOL_BLV (sym
)))
1946 return SYMBOL_BLV (sym
)->where
;
1953 /* This code is disabled now that we use the selected frame to return
1954 keyboard-local-values. */
1956 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1958 DEFUN ("terminal-local-value", Fterminal_local_value
,
1959 Sterminal_local_value
, 2, 2, 0,
1960 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1961 If SYMBOL is not a terminal-local variable, then return its normal
1962 value, like `symbol-value'.
1964 TERMINAL may be a terminal object, a frame, or nil (meaning the
1965 selected frame's terminal device). */)
1966 (Lisp_Object symbol
, Lisp_Object terminal
)
1969 struct terminal
*t
= get_terminal (terminal
, 1);
1970 push_kboard (t
->kboard
);
1971 result
= Fsymbol_value (symbol
);
1976 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1977 Sset_terminal_local_value
, 3, 3, 0,
1978 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1979 If VARIABLE is not a terminal-local variable, then set its normal
1980 binding, like `set'.
1982 TERMINAL may be a terminal object, a frame, or nil (meaning the
1983 selected frame's terminal device). */)
1984 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1987 struct terminal
*t
= get_terminal (terminal
, 1);
1988 push_kboard (d
->kboard
);
1989 result
= Fset (symbol
, value
);
1995 /* Find the function at the end of a chain of symbol function indirections. */
1997 /* If OBJECT is a symbol, find the end of its function chain and
1998 return the value found there. If OBJECT is not a symbol, just
1999 return it. If there is a cycle in the function chain, signal a
2000 cyclic-function-indirection error.
2002 This is like Findirect_function, except that it doesn't signal an
2003 error if the chain ends up unbound. */
2005 indirect_function (register Lisp_Object object
)
2007 Lisp_Object tortoise
, hare
;
2009 hare
= tortoise
= object
;
2013 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2015 hare
= XSYMBOL (hare
)->function
;
2016 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2018 hare
= XSYMBOL (hare
)->function
;
2020 tortoise
= XSYMBOL (tortoise
)->function
;
2022 if (EQ (hare
, tortoise
))
2023 xsignal1 (Qcyclic_function_indirection
, object
);
2029 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2030 doc
: /* Return the function at the end of OBJECT's function chain.
2031 If OBJECT is not a symbol, just return it. Otherwise, follow all
2032 function indirections to find the final function binding and return it.
2033 If the final symbol in the chain is unbound, signal a void-function error.
2034 Optional arg NOERROR non-nil means to return nil instead of signalling.
2035 Signal a cyclic-function-indirection error if there is a loop in the
2036 function chain of symbols. */)
2037 (register Lisp_Object object
, Lisp_Object noerror
)
2041 /* Optimize for no indirection. */
2043 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2044 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2045 result
= indirect_function (result
);
2046 if (!EQ (result
, Qunbound
))
2050 xsignal1 (Qvoid_function
, object
);
2055 /* Extract and set vector and string elements */
2057 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2058 doc
: /* Return the element of ARRAY at index IDX.
2059 ARRAY may be a vector, a string, a char-table, a bool-vector,
2060 or a byte-code object. IDX starts at 0. */)
2061 (register Lisp_Object array
, Lisp_Object idx
)
2063 register EMACS_INT idxval
;
2066 idxval
= XINT (idx
);
2067 if (STRINGP (array
))
2070 EMACS_INT idxval_byte
;
2072 if (idxval
< 0 || idxval
>= SCHARS (array
))
2073 args_out_of_range (array
, idx
);
2074 if (! STRING_MULTIBYTE (array
))
2075 return make_number ((unsigned char) SREF (array
, idxval
));
2076 idxval_byte
= string_char_to_byte (array
, idxval
);
2078 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2079 return make_number (c
);
2081 else if (BOOL_VECTOR_P (array
))
2085 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2086 args_out_of_range (array
, idx
);
2088 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2089 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2091 else if (CHAR_TABLE_P (array
))
2093 CHECK_CHARACTER (idx
);
2094 return CHAR_TABLE_REF (array
, idxval
);
2099 if (VECTORP (array
))
2100 size
= ASIZE (array
);
2101 else if (COMPILEDP (array
))
2102 size
= ASIZE (array
) & PSEUDOVECTOR_SIZE_MASK
;
2104 wrong_type_argument (Qarrayp
, array
);
2106 if (idxval
< 0 || idxval
>= size
)
2107 args_out_of_range (array
, idx
);
2108 return AREF (array
, idxval
);
2112 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2113 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2114 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2115 bool-vector. IDX starts at 0. */)
2116 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2118 register EMACS_INT idxval
;
2121 idxval
= XINT (idx
);
2122 CHECK_ARRAY (array
, Qarrayp
);
2123 CHECK_IMPURE (array
);
2125 if (VECTORP (array
))
2127 if (idxval
< 0 || idxval
>= ASIZE (array
))
2128 args_out_of_range (array
, idx
);
2129 XVECTOR (array
)->contents
[idxval
] = newelt
;
2131 else if (BOOL_VECTOR_P (array
))
2135 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2136 args_out_of_range (array
, idx
);
2138 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2140 if (! NILP (newelt
))
2141 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2143 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2144 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2146 else if (CHAR_TABLE_P (array
))
2148 CHECK_CHARACTER (idx
);
2149 CHAR_TABLE_SET (array
, idxval
, newelt
);
2151 else if (STRING_MULTIBYTE (array
))
2153 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2154 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2157 if (idxval
< 0 || idxval
>= SCHARS (array
))
2158 args_out_of_range (array
, idx
);
2159 CHECK_CHARACTER (newelt
);
2160 c
= XFASTINT (newelt
);
2162 nbytes
= SBYTES (array
);
2164 idxval_byte
= string_char_to_byte (array
, idxval
);
2165 p1
= SDATA (array
) + idxval_byte
;
2166 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2167 new_bytes
= CHAR_STRING (c
, p0
);
2168 if (prev_bytes
!= new_bytes
)
2170 /* We must relocate the string data. */
2171 EMACS_INT nchars
= SCHARS (array
);
2175 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2176 memcpy (str
, SDATA (array
), nbytes
);
2177 allocate_string_data (XSTRING (array
), nchars
,
2178 nbytes
+ new_bytes
- prev_bytes
);
2179 memcpy (SDATA (array
), str
, idxval_byte
);
2180 p1
= SDATA (array
) + idxval_byte
;
2181 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2182 nbytes
- (idxval_byte
+ prev_bytes
));
2184 clear_string_char_byte_cache ();
2191 if (idxval
< 0 || idxval
>= SCHARS (array
))
2192 args_out_of_range (array
, idx
);
2193 CHECK_NUMBER (newelt
);
2195 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2199 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2200 if (SREF (array
, i
) >= 0x80)
2201 args_out_of_range (array
, newelt
);
2202 /* ARRAY is an ASCII string. Convert it to a multibyte
2203 string, and try `aset' again. */
2204 STRING_SET_MULTIBYTE (array
);
2205 return Faset (array
, idx
, newelt
);
2207 SSET (array
, idxval
, XINT (newelt
));
2213 /* Arithmetic functions */
2215 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2218 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2220 double f1
= 0, f2
= 0;
2223 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2224 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2226 if (FLOATP (num1
) || FLOATP (num2
))
2229 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2230 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2236 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2241 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2246 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2251 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2256 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2261 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2270 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2271 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2272 (register Lisp_Object num1
, Lisp_Object num2
)
2274 return arithcompare (num1
, num2
, equal
);
2277 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2278 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2279 (register Lisp_Object num1
, Lisp_Object num2
)
2281 return arithcompare (num1
, num2
, less
);
2284 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2285 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2286 (register Lisp_Object num1
, Lisp_Object num2
)
2288 return arithcompare (num1
, num2
, grtr
);
2291 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2292 doc
: /* Return t if first arg is less than or equal to second arg.
2293 Both must be numbers or markers. */)
2294 (register Lisp_Object num1
, Lisp_Object num2
)
2296 return arithcompare (num1
, num2
, less_or_equal
);
2299 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2300 doc
: /* Return t if first arg is greater than or equal to second arg.
2301 Both must be numbers or markers. */)
2302 (register Lisp_Object num1
, Lisp_Object num2
)
2304 return arithcompare (num1
, num2
, grtr_or_equal
);
2307 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2308 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2309 (register Lisp_Object num1
, Lisp_Object num2
)
2311 return arithcompare (num1
, num2
, notequal
);
2314 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2315 doc
: /* Return t if NUMBER is zero. */)
2316 (register Lisp_Object number
)
2318 CHECK_NUMBER_OR_FLOAT (number
);
2320 if (FLOATP (number
))
2322 if (XFLOAT_DATA (number
) == 0.0)
2332 /* Convert the cons-of-integers, integer, or float value C to an
2333 unsigned value with maximum value MAX. Signal an error if C does not
2334 have a valid format or is out of range. */
2336 cons_to_unsigned (Lisp_Object c
, uintmax_t max
)
2339 uintmax_t val
IF_LINT (= 0);
2342 valid
= 0 <= XINT (c
);
2345 else if (FLOATP (c
))
2347 double d
= XFLOAT_DATA (c
);
2349 && d
< (max
== UINTMAX_MAX
? (double) UINTMAX_MAX
+ 1 : max
+ 1))
2355 else if (CONSP (c
) && NATNUMP (XCAR (c
)))
2357 uintmax_t top
= XFASTINT (XCAR (c
));
2358 Lisp_Object rest
= XCDR (c
);
2359 if (top
<= UINTMAX_MAX
>> 24 >> 16
2361 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2362 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2364 uintmax_t mid
= XFASTINT (XCAR (rest
));
2365 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2368 else if (top
<= UINTMAX_MAX
>> 16)
2372 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2374 val
= top
<< 16 | XFASTINT (rest
);
2380 if (! (valid
&& val
<= max
))
2381 error ("Not an in-range integer, float, or cons of integers");
2385 /* Convert the cons-of-integers, integer, or float value C to a signed
2386 value with extrema MIN and MAX. Signal an error if C does not have
2387 a valid format or is out of range. */
2389 cons_to_signed (Lisp_Object c
, intmax_t min
, intmax_t max
)
2392 intmax_t val
IF_LINT (= 0);
2398 else if (FLOATP (c
))
2400 double d
= XFLOAT_DATA (c
);
2402 && d
< (max
== INTMAX_MAX
? (double) INTMAX_MAX
+ 1 : max
+ 1))
2408 else if (CONSP (c
) && INTEGERP (XCAR (c
)))
2410 intmax_t top
= XINT (XCAR (c
));
2411 Lisp_Object rest
= XCDR (c
);
2412 if (INTMAX_MIN
>> 24 >> 16 <= top
&& top
<= INTMAX_MAX
>> 24 >> 16
2414 && NATNUMP (XCAR (rest
)) && XFASTINT (XCAR (rest
)) < 1 << 24
2415 && NATNUMP (XCDR (rest
)) && XFASTINT (XCDR (rest
)) < 1 << 16)
2417 intmax_t mid
= XFASTINT (XCAR (rest
));
2418 val
= top
<< 24 << 16 | mid
<< 16 | XFASTINT (XCDR (rest
));
2421 else if (INTMAX_MIN
>> 16 <= top
&& top
<= INTMAX_MAX
>> 16)
2425 if (NATNUMP (rest
) && XFASTINT (rest
) < 1 << 16)
2427 val
= top
<< 16 | XFASTINT (rest
);
2433 if (! (valid
&& min
<= val
&& val
<= max
))
2434 error ("Not an in-range integer, float, or cons of integers");
2438 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2439 doc
: /* Return the decimal representation of NUMBER as a string.
2440 Uses a minus sign if negative.
2441 NUMBER may be an integer or a floating point number. */)
2442 (Lisp_Object number
)
2444 char buffer
[VALBITS
];
2446 CHECK_NUMBER_OR_FLOAT (number
);
2448 if (FLOATP (number
))
2450 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2452 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2453 return build_string (pigbuf
);
2456 sprintf (buffer
, "%"pI
"d", XINT (number
));
2457 return build_string (buffer
);
2460 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2461 doc
: /* Parse STRING as a decimal number and return the number.
2462 This parses both integers and floating point numbers.
2463 It ignores leading spaces and tabs, and all trailing chars.
2465 If BASE, interpret STRING as a number in that base. If BASE isn't
2466 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2467 If the base used is not 10, STRING is always parsed as integer. */)
2468 (register Lisp_Object string
, Lisp_Object base
)
2474 CHECK_STRING (string
);
2480 CHECK_NUMBER (base
);
2482 if (b
< 2 || b
> 16)
2483 xsignal1 (Qargs_out_of_range
, base
);
2486 p
= SSDATA (string
);
2487 while (*p
== ' ' || *p
== '\t')
2490 val
= string_to_number (p
, b
, 1);
2491 return NILP (val
) ? make_number (0) : val
;
2507 static Lisp_Object
float_arith_driver (double, size_t, enum arithop
,
2508 size_t, Lisp_Object
*);
2510 arith_driver (enum arithop code
, size_t nargs
, register Lisp_Object
*args
)
2512 register Lisp_Object val
;
2513 register size_t argnum
;
2514 register EMACS_INT accum
= 0;
2515 register EMACS_INT next
;
2521 switch (SWITCH_ENUM_CAST (code
))
2539 for (argnum
= 0; argnum
< nargs
; argnum
++)
2547 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2549 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2552 return float_arith_driver (ok_accum
, ok_args
, code
,
2555 next
= XINT (args
[argnum
]);
2556 switch (SWITCH_ENUM_CAST (code
))
2559 if (INT_ADD_OVERFLOW (accum
, next
))
2567 if (INT_SUBTRACT_OVERFLOW (accum
, next
))
2572 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2575 if (INT_MULTIPLY_OVERFLOW (accum
, next
))
2577 EMACS_UINT a
= accum
, b
= next
, ab
= a
* b
;
2579 accum
= ab
& INTMASK
;
2590 xsignal0 (Qarith_error
);
2604 if (!argnum
|| next
> accum
)
2608 if (!argnum
|| next
< accum
)
2614 XSETINT (val
, accum
);
2619 #define isnan(x) ((x) != (x))
2622 float_arith_driver (double accum
, register size_t argnum
, enum arithop code
,
2623 size_t nargs
, register Lisp_Object
*args
)
2625 register Lisp_Object val
;
2628 for (; argnum
< nargs
; argnum
++)
2630 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2631 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2635 next
= XFLOAT_DATA (val
);
2639 args
[argnum
] = val
; /* runs into a compiler bug. */
2640 next
= XINT (args
[argnum
]);
2642 switch (SWITCH_ENUM_CAST (code
))
2648 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2658 if (! IEEE_FLOATING_POINT
&& next
== 0)
2659 xsignal0 (Qarith_error
);
2666 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2668 if (!argnum
|| isnan (next
) || next
> accum
)
2672 if (!argnum
|| isnan (next
) || next
< accum
)
2678 return make_float (accum
);
2682 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2683 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2684 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2685 (size_t nargs
, Lisp_Object
*args
)
2687 return arith_driver (Aadd
, nargs
, args
);
2690 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2691 doc
: /* Negate number or subtract numbers or markers and return the result.
2692 With one arg, negates it. With more than one arg,
2693 subtracts all but the first from the first.
2694 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2695 (size_t nargs
, Lisp_Object
*args
)
2697 return arith_driver (Asub
, nargs
, args
);
2700 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2701 doc
: /* Return product of any number of arguments, which are numbers or markers.
2702 usage: (* &rest NUMBERS-OR-MARKERS) */)
2703 (size_t nargs
, Lisp_Object
*args
)
2705 return arith_driver (Amult
, nargs
, args
);
2708 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2709 doc
: /* Return first argument divided by all the remaining arguments.
2710 The arguments must be numbers or markers.
2711 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2712 (size_t nargs
, Lisp_Object
*args
)
2715 for (argnum
= 2; argnum
< nargs
; argnum
++)
2716 if (FLOATP (args
[argnum
]))
2717 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2718 return arith_driver (Adiv
, nargs
, args
);
2721 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2722 doc
: /* Return remainder of X divided by Y.
2723 Both must be integers or markers. */)
2724 (register Lisp_Object x
, Lisp_Object y
)
2728 CHECK_NUMBER_COERCE_MARKER (x
);
2729 CHECK_NUMBER_COERCE_MARKER (y
);
2731 if (XFASTINT (y
) == 0)
2732 xsignal0 (Qarith_error
);
2734 XSETINT (val
, XINT (x
) % XINT (y
));
2748 /* If the magnitude of the result exceeds that of the divisor, or
2749 the sign of the result does not agree with that of the dividend,
2750 iterate with the reduced value. This does not yield a
2751 particularly accurate result, but at least it will be in the
2752 range promised by fmod. */
2754 r
-= f2
* floor (r
/ f2
);
2755 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2759 #endif /* ! HAVE_FMOD */
2761 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2762 doc
: /* Return X modulo Y.
2763 The result falls between zero (inclusive) and Y (exclusive).
2764 Both X and Y must be numbers or markers. */)
2765 (register Lisp_Object x
, Lisp_Object y
)
2770 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2771 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2773 if (FLOATP (x
) || FLOATP (y
))
2774 return fmod_float (x
, y
);
2780 xsignal0 (Qarith_error
);
2784 /* If the "remainder" comes out with the wrong sign, fix it. */
2785 if (i2
< 0 ? i1
> 0 : i1
< 0)
2792 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2793 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2794 The value is always a number; markers are converted to numbers.
2795 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2796 (size_t nargs
, Lisp_Object
*args
)
2798 return arith_driver (Amax
, nargs
, args
);
2801 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2802 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2803 The value is always a number; markers are converted to numbers.
2804 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2805 (size_t nargs
, Lisp_Object
*args
)
2807 return arith_driver (Amin
, nargs
, args
);
2810 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2811 doc
: /* Return bitwise-and of all the arguments.
2812 Arguments may be integers, or markers converted to integers.
2813 usage: (logand &rest INTS-OR-MARKERS) */)
2814 (size_t nargs
, Lisp_Object
*args
)
2816 return arith_driver (Alogand
, nargs
, args
);
2819 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2820 doc
: /* Return bitwise-or of all the arguments.
2821 Arguments may be integers, or markers converted to integers.
2822 usage: (logior &rest INTS-OR-MARKERS) */)
2823 (size_t nargs
, Lisp_Object
*args
)
2825 return arith_driver (Alogior
, nargs
, args
);
2828 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2829 doc
: /* Return bitwise-exclusive-or of all the arguments.
2830 Arguments may be integers, or markers converted to integers.
2831 usage: (logxor &rest INTS-OR-MARKERS) */)
2832 (size_t nargs
, Lisp_Object
*args
)
2834 return arith_driver (Alogxor
, nargs
, args
);
2837 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2838 doc
: /* Return VALUE with its bits shifted left by COUNT.
2839 If COUNT is negative, shifting is actually to the right.
2840 In this case, the sign bit is duplicated. */)
2841 (register Lisp_Object value
, Lisp_Object count
)
2843 register Lisp_Object val
;
2845 CHECK_NUMBER (value
);
2846 CHECK_NUMBER (count
);
2848 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2850 else if (XINT (count
) > 0)
2851 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2852 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2853 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2855 XSETINT (val
, XINT (value
) >> -XINT (count
));
2859 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2860 doc
: /* Return VALUE with its bits shifted left by COUNT.
2861 If COUNT is negative, shifting is actually to the right.
2862 In this case, zeros are shifted in on the left. */)
2863 (register Lisp_Object value
, Lisp_Object count
)
2865 register Lisp_Object val
;
2867 CHECK_NUMBER (value
);
2868 CHECK_NUMBER (count
);
2870 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2872 else if (XINT (count
) > 0)
2873 XSETINT (val
, XUINT (value
) << XFASTINT (count
));
2874 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2877 XSETINT (val
, XUINT (value
) >> -XINT (count
));
2881 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2882 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2883 Markers are converted to integers. */)
2884 (register Lisp_Object number
)
2886 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2888 if (FLOATP (number
))
2889 return (make_float (1.0 + XFLOAT_DATA (number
)));
2891 XSETINT (number
, XINT (number
) + 1);
2895 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2896 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2897 Markers are converted to integers. */)
2898 (register Lisp_Object number
)
2900 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2902 if (FLOATP (number
))
2903 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2905 XSETINT (number
, XINT (number
) - 1);
2909 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2910 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2911 (register Lisp_Object number
)
2913 CHECK_NUMBER (number
);
2914 XSETINT (number
, ~XINT (number
));
2918 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2919 doc
: /* Return the byteorder for the machine.
2920 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2921 lowercase l) for small endian machines. */)
2924 unsigned i
= 0x04030201;
2925 int order
= *(char *)&i
== 1 ? 108 : 66;
2927 return make_number (order
);
2935 Lisp_Object error_tail
, arith_tail
;
2937 DEFSYM (Qquote
, "quote");
2938 DEFSYM (Qlambda
, "lambda");
2939 DEFSYM (Qsubr
, "subr");
2940 DEFSYM (Qerror_conditions
, "error-conditions");
2941 DEFSYM (Qerror_message
, "error-message");
2942 DEFSYM (Qtop_level
, "top-level");
2944 DEFSYM (Qerror
, "error");
2945 DEFSYM (Qquit
, "quit");
2946 DEFSYM (Qwrong_type_argument
, "wrong-type-argument");
2947 DEFSYM (Qargs_out_of_range
, "args-out-of-range");
2948 DEFSYM (Qvoid_function
, "void-function");
2949 DEFSYM (Qcyclic_function_indirection
, "cyclic-function-indirection");
2950 DEFSYM (Qcyclic_variable_indirection
, "cyclic-variable-indirection");
2951 DEFSYM (Qvoid_variable
, "void-variable");
2952 DEFSYM (Qsetting_constant
, "setting-constant");
2953 DEFSYM (Qinvalid_read_syntax
, "invalid-read-syntax");
2955 DEFSYM (Qinvalid_function
, "invalid-function");
2956 DEFSYM (Qwrong_number_of_arguments
, "wrong-number-of-arguments");
2957 DEFSYM (Qno_catch
, "no-catch");
2958 DEFSYM (Qend_of_file
, "end-of-file");
2959 DEFSYM (Qarith_error
, "arith-error");
2960 DEFSYM (Qbeginning_of_buffer
, "beginning-of-buffer");
2961 DEFSYM (Qend_of_buffer
, "end-of-buffer");
2962 DEFSYM (Qbuffer_read_only
, "buffer-read-only");
2963 DEFSYM (Qtext_read_only
, "text-read-only");
2964 DEFSYM (Qmark_inactive
, "mark-inactive");
2966 DEFSYM (Qlistp
, "listp");
2967 DEFSYM (Qconsp
, "consp");
2968 DEFSYM (Qsymbolp
, "symbolp");
2969 DEFSYM (Qkeywordp
, "keywordp");
2970 DEFSYM (Qintegerp
, "integerp");
2971 DEFSYM (Qnatnump
, "natnump");
2972 DEFSYM (Qwholenump
, "wholenump");
2973 DEFSYM (Qstringp
, "stringp");
2974 DEFSYM (Qarrayp
, "arrayp");
2975 DEFSYM (Qsequencep
, "sequencep");
2976 DEFSYM (Qbufferp
, "bufferp");
2977 DEFSYM (Qvectorp
, "vectorp");
2978 DEFSYM (Qchar_or_string_p
, "char-or-string-p");
2979 DEFSYM (Qmarkerp
, "markerp");
2980 DEFSYM (Qbuffer_or_string_p
, "buffer-or-string-p");
2981 DEFSYM (Qinteger_or_marker_p
, "integer-or-marker-p");
2982 DEFSYM (Qboundp
, "boundp");
2983 DEFSYM (Qfboundp
, "fboundp");
2985 DEFSYM (Qfloatp
, "floatp");
2986 DEFSYM (Qnumberp
, "numberp");
2987 DEFSYM (Qnumber_or_marker_p
, "number-or-marker-p");
2989 DEFSYM (Qchar_table_p
, "char-table-p");
2990 DEFSYM (Qvector_or_char_table_p
, "vector-or-char-table-p");
2992 DEFSYM (Qsubrp
, "subrp");
2993 DEFSYM (Qunevalled
, "unevalled");
2994 DEFSYM (Qmany
, "many");
2996 DEFSYM (Qcdr
, "cdr");
2998 /* Handle automatic advice activation. */
2999 DEFSYM (Qad_advice_info
, "ad-advice-info");
3000 DEFSYM (Qad_activate_internal
, "ad-activate-internal");
3002 error_tail
= pure_cons (Qerror
, Qnil
);
3004 /* ERROR is used as a signaler for random errors for which nothing else is
3007 Fput (Qerror
, Qerror_conditions
,
3009 Fput (Qerror
, Qerror_message
,
3010 make_pure_c_string ("error"));
3012 Fput (Qquit
, Qerror_conditions
,
3013 pure_cons (Qquit
, Qnil
));
3014 Fput (Qquit
, Qerror_message
,
3015 make_pure_c_string ("Quit"));
3017 Fput (Qwrong_type_argument
, Qerror_conditions
,
3018 pure_cons (Qwrong_type_argument
, error_tail
));
3019 Fput (Qwrong_type_argument
, Qerror_message
,
3020 make_pure_c_string ("Wrong type argument"));
3022 Fput (Qargs_out_of_range
, Qerror_conditions
,
3023 pure_cons (Qargs_out_of_range
, error_tail
));
3024 Fput (Qargs_out_of_range
, Qerror_message
,
3025 make_pure_c_string ("Args out of range"));
3027 Fput (Qvoid_function
, Qerror_conditions
,
3028 pure_cons (Qvoid_function
, error_tail
));
3029 Fput (Qvoid_function
, Qerror_message
,
3030 make_pure_c_string ("Symbol's function definition is void"));
3032 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3033 pure_cons (Qcyclic_function_indirection
, error_tail
));
3034 Fput (Qcyclic_function_indirection
, Qerror_message
,
3035 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3037 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3038 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3039 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3040 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3042 DEFSYM (Qcircular_list
, "circular-list");
3043 Fput (Qcircular_list
, Qerror_conditions
,
3044 pure_cons (Qcircular_list
, error_tail
));
3045 Fput (Qcircular_list
, Qerror_message
,
3046 make_pure_c_string ("List contains a loop"));
3048 Fput (Qvoid_variable
, Qerror_conditions
,
3049 pure_cons (Qvoid_variable
, error_tail
));
3050 Fput (Qvoid_variable
, Qerror_message
,
3051 make_pure_c_string ("Symbol's value as variable is void"));
3053 Fput (Qsetting_constant
, Qerror_conditions
,
3054 pure_cons (Qsetting_constant
, error_tail
));
3055 Fput (Qsetting_constant
, Qerror_message
,
3056 make_pure_c_string ("Attempt to set a constant symbol"));
3058 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3059 pure_cons (Qinvalid_read_syntax
, error_tail
));
3060 Fput (Qinvalid_read_syntax
, Qerror_message
,
3061 make_pure_c_string ("Invalid read syntax"));
3063 Fput (Qinvalid_function
, Qerror_conditions
,
3064 pure_cons (Qinvalid_function
, error_tail
));
3065 Fput (Qinvalid_function
, Qerror_message
,
3066 make_pure_c_string ("Invalid function"));
3068 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3069 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3070 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3071 make_pure_c_string ("Wrong number of arguments"));
3073 Fput (Qno_catch
, Qerror_conditions
,
3074 pure_cons (Qno_catch
, error_tail
));
3075 Fput (Qno_catch
, Qerror_message
,
3076 make_pure_c_string ("No catch for tag"));
3078 Fput (Qend_of_file
, Qerror_conditions
,
3079 pure_cons (Qend_of_file
, error_tail
));
3080 Fput (Qend_of_file
, Qerror_message
,
3081 make_pure_c_string ("End of file during parsing"));
3083 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3084 Fput (Qarith_error
, Qerror_conditions
,
3086 Fput (Qarith_error
, Qerror_message
,
3087 make_pure_c_string ("Arithmetic error"));
3089 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3090 pure_cons (Qbeginning_of_buffer
, error_tail
));
3091 Fput (Qbeginning_of_buffer
, Qerror_message
,
3092 make_pure_c_string ("Beginning of buffer"));
3094 Fput (Qend_of_buffer
, Qerror_conditions
,
3095 pure_cons (Qend_of_buffer
, error_tail
));
3096 Fput (Qend_of_buffer
, Qerror_message
,
3097 make_pure_c_string ("End of buffer"));
3099 Fput (Qbuffer_read_only
, Qerror_conditions
,
3100 pure_cons (Qbuffer_read_only
, error_tail
));
3101 Fput (Qbuffer_read_only
, Qerror_message
,
3102 make_pure_c_string ("Buffer is read-only"));
3104 Fput (Qtext_read_only
, Qerror_conditions
,
3105 pure_cons (Qtext_read_only
, error_tail
));
3106 Fput (Qtext_read_only
, Qerror_message
,
3107 make_pure_c_string ("Text is read-only"));
3109 DEFSYM (Qrange_error
, "range-error");
3110 DEFSYM (Qdomain_error
, "domain-error");
3111 DEFSYM (Qsingularity_error
, "singularity-error");
3112 DEFSYM (Qoverflow_error
, "overflow-error");
3113 DEFSYM (Qunderflow_error
, "underflow-error");
3115 Fput (Qdomain_error
, Qerror_conditions
,
3116 pure_cons (Qdomain_error
, arith_tail
));
3117 Fput (Qdomain_error
, Qerror_message
,
3118 make_pure_c_string ("Arithmetic domain error"));
3120 Fput (Qrange_error
, Qerror_conditions
,
3121 pure_cons (Qrange_error
, arith_tail
));
3122 Fput (Qrange_error
, Qerror_message
,
3123 make_pure_c_string ("Arithmetic range error"));
3125 Fput (Qsingularity_error
, Qerror_conditions
,
3126 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3127 Fput (Qsingularity_error
, Qerror_message
,
3128 make_pure_c_string ("Arithmetic singularity error"));
3130 Fput (Qoverflow_error
, Qerror_conditions
,
3131 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3132 Fput (Qoverflow_error
, Qerror_message
,
3133 make_pure_c_string ("Arithmetic overflow error"));
3135 Fput (Qunderflow_error
, Qerror_conditions
,
3136 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3137 Fput (Qunderflow_error
, Qerror_message
,
3138 make_pure_c_string ("Arithmetic underflow error"));
3142 staticpro (&Qunbound
);
3144 /* Types that type-of returns. */
3145 DEFSYM (Qinteger
, "integer");
3146 DEFSYM (Qsymbol
, "symbol");
3147 DEFSYM (Qstring
, "string");
3148 DEFSYM (Qcons
, "cons");
3149 DEFSYM (Qmarker
, "marker");
3150 DEFSYM (Qoverlay
, "overlay");
3151 DEFSYM (Qfloat
, "float");
3152 DEFSYM (Qwindow_configuration
, "window-configuration");
3153 DEFSYM (Qprocess
, "process");
3154 DEFSYM (Qwindow
, "window");
3155 /* DEFSYM (Qsubr, "subr"); */
3156 DEFSYM (Qcompiled_function
, "compiled-function");
3157 DEFSYM (Qbuffer
, "buffer");
3158 DEFSYM (Qframe
, "frame");
3159 DEFSYM (Qvector
, "vector");
3160 DEFSYM (Qchar_table
, "char-table");
3161 DEFSYM (Qbool_vector
, "bool-vector");
3162 DEFSYM (Qhash_table
, "hash-table");
3164 DEFSYM (Qfont_spec
, "font-spec");
3165 DEFSYM (Qfont_entity
, "font-entity");
3166 DEFSYM (Qfont_object
, "font-object");
3168 DEFSYM (Qinteractive_form
, "interactive-form");
3170 defsubr (&Sindirect_variable
);
3171 defsubr (&Sinteractive_form
);
3174 defsubr (&Stype_of
);
3179 defsubr (&Sintegerp
);
3180 defsubr (&Sinteger_or_marker_p
);
3181 defsubr (&Snumberp
);
3182 defsubr (&Snumber_or_marker_p
);
3184 defsubr (&Snatnump
);
3185 defsubr (&Ssymbolp
);
3186 defsubr (&Skeywordp
);
3187 defsubr (&Sstringp
);
3188 defsubr (&Smultibyte_string_p
);
3189 defsubr (&Svectorp
);
3190 defsubr (&Schar_table_p
);
3191 defsubr (&Svector_or_char_table_p
);
3192 defsubr (&Sbool_vector_p
);
3194 defsubr (&Ssequencep
);
3195 defsubr (&Sbufferp
);
3196 defsubr (&Smarkerp
);
3198 defsubr (&Sbyte_code_function_p
);
3199 defsubr (&Schar_or_string_p
);
3202 defsubr (&Scar_safe
);
3203 defsubr (&Scdr_safe
);
3206 defsubr (&Ssymbol_function
);
3207 defsubr (&Sindirect_function
);
3208 defsubr (&Ssymbol_plist
);
3209 defsubr (&Ssymbol_name
);
3210 defsubr (&Smakunbound
);
3211 defsubr (&Sfmakunbound
);
3213 defsubr (&Sfboundp
);
3215 defsubr (&Sdefalias
);
3216 defsubr (&Ssetplist
);
3217 defsubr (&Ssymbol_value
);
3219 defsubr (&Sdefault_boundp
);
3220 defsubr (&Sdefault_value
);
3221 defsubr (&Sset_default
);
3222 defsubr (&Ssetq_default
);
3223 defsubr (&Smake_variable_buffer_local
);
3224 defsubr (&Smake_local_variable
);
3225 defsubr (&Skill_local_variable
);
3226 defsubr (&Smake_variable_frame_local
);
3227 defsubr (&Slocal_variable_p
);
3228 defsubr (&Slocal_variable_if_set_p
);
3229 defsubr (&Svariable_binding_locus
);
3230 #if 0 /* XXX Remove this. --lorentey */
3231 defsubr (&Sterminal_local_value
);
3232 defsubr (&Sset_terminal_local_value
);
3236 defsubr (&Snumber_to_string
);
3237 defsubr (&Sstring_to_number
);
3238 defsubr (&Seqlsign
);
3261 defsubr (&Sbyteorder
);
3262 defsubr (&Ssubr_arity
);
3263 defsubr (&Ssubr_name
);
3265 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3267 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3268 doc
: /* The largest value that is representable in a Lisp integer. */);
3269 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3270 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3272 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3273 doc
: /* The smallest value that is representable in a Lisp integer. */);
3274 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3275 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3278 #ifndef FORWARD_SIGNAL_TO_MAIN_THREAD
3279 static void arith_error (int) NO_RETURN
;
3283 arith_error (int signo
)
3285 sigsetmask (SIGEMPTYMASK
);
3287 SIGNAL_THREAD_CHECK (signo
);
3288 xsignal0 (Qarith_error
);
3294 /* Don't do this if just dumping out.
3295 We don't want to call `signal' in this case
3296 so that we don't have trouble with dumping
3297 signal-delivering routines in an inconsistent state. */
3301 #endif /* CANNOT_DUMP */
3302 signal (SIGFPE
, arith_error
);