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/>. */
27 #include "character.h"
31 #include "syssignal.h"
32 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
52 extern double atof (const char *);
55 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
56 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
57 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
58 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
59 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
60 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
61 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
62 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
63 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
64 Lisp_Object Qtext_read_only
;
66 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
67 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
68 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
69 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
70 Lisp_Object Qboundp
, Qfboundp
;
71 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
74 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
76 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
77 Lisp_Object Qoverflow_error
, Qunderflow_error
;
80 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
83 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
;
87 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
98 circular_list_error (Lisp_Object list
)
100 xsignal (Qcircular_list
, list
);
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
, Qlambda
))
749 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
750 else if (EQ (funcar
, Qautoload
))
754 do_autoload (fun
, cmd
);
756 return Finteractive_form (cmd
);
763 /***********************************************************************
764 Getting and Setting Values of Symbols
765 ***********************************************************************/
767 /* Return the symbol holding SYMBOL's value. Signal
768 `cyclic-variable-indirection' if SYMBOL's chain of variable
769 indirections contains a loop. */
772 indirect_variable (struct Lisp_Symbol
*symbol
)
774 struct Lisp_Symbol
*tortoise
, *hare
;
776 hare
= tortoise
= symbol
;
778 while (hare
->redirect
== SYMBOL_VARALIAS
)
780 hare
= SYMBOL_ALIAS (hare
);
781 if (hare
->redirect
!= SYMBOL_VARALIAS
)
784 hare
= SYMBOL_ALIAS (hare
);
785 tortoise
= SYMBOL_ALIAS (tortoise
);
787 if (hare
== tortoise
)
790 XSETSYMBOL (tem
, symbol
);
791 xsignal1 (Qcyclic_variable_indirection
, tem
);
799 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
800 doc
: /* Return the variable at the end of OBJECT's variable chain.
801 If OBJECT is a symbol, follow all variable indirections and return the final
802 variable. If OBJECT is not a symbol, just return it.
803 Signal a cyclic-variable-indirection error if there is a loop in the
804 variable chain of symbols. */)
807 if (SYMBOLP (object
))
809 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
810 XSETSYMBOL (object
, sym
);
816 /* Given the raw contents of a symbol value cell,
817 return the Lisp value of the symbol.
818 This does not handle buffer-local variables; use
819 swap_in_symval_forwarding for that. */
822 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
824 register Lisp_Object val
;
825 switch (XFWDTYPE (valcontents
))
828 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
832 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
835 return *XOBJFWD (valcontents
)->objvar
;
837 case Lisp_Fwd_Buffer_Obj
:
838 return PER_BUFFER_VALUE (current_buffer
,
839 XBUFFER_OBJFWD (valcontents
)->offset
);
841 case Lisp_Fwd_Kboard_Obj
:
842 /* We used to simply use current_kboard here, but from Lisp
843 code, it's value is often unexpected. It seems nicer to
844 allow constructions like this to work as intuitively expected:
846 (with-selected-frame frame
847 (define-key local-function-map "\eOP" [f1]))
849 On the other hand, this affects the semantics of
850 last-command and real-last-command, and people may rely on
851 that. I took a quick look at the Lisp codebase, and I
852 don't think anything will break. --lorentey */
853 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
854 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
859 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
860 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
861 buffer-independent contents of the value cell: forwarded just one
862 step past the buffer-localness.
864 BUF non-zero means set the value in buffer BUF instead of the
865 current buffer. This only plays a role for per-buffer variables. */
868 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
870 switch (XFWDTYPE (valcontents
))
873 CHECK_NUMBER (newval
);
874 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
878 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
882 *XOBJFWD (valcontents
)->objvar
= newval
;
884 /* If this variable is a default for something stored
885 in the buffer itself, such as default-fill-column,
886 find the buffers that don't have local values for it
888 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
889 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
891 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
892 - (char *) &buffer_defaults
);
893 int idx
= PER_BUFFER_IDX (offset
);
900 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
905 lbuf
= Fcdr (XCAR (tail
));
906 if (!BUFFERP (lbuf
)) continue;
909 if (! PER_BUFFER_VALUE_P (b
, idx
))
910 PER_BUFFER_VALUE (b
, offset
) = newval
;
915 case Lisp_Fwd_Buffer_Obj
:
917 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
918 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
920 if (!(NILP (type
) || NILP (newval
)
921 || (XINT (type
) == LISP_INT_TAG
923 : XTYPE (newval
) == XINT (type
))))
924 buffer_slot_type_mismatch (newval
, XINT (type
));
927 buf
= current_buffer
;
928 PER_BUFFER_VALUE (buf
, offset
) = newval
;
932 case Lisp_Fwd_Kboard_Obj
:
934 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
935 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
936 *(Lisp_Object
*) p
= newval
;
941 abort (); /* goto def; */
945 /* Set up SYMBOL to refer to its global binding.
946 This makes it safe to alter the status of other bindings. */
949 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
951 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
953 /* Unload the previously loaded binding. */
955 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
957 /* Select the global binding in the symbol. */
958 blv
->valcell
= blv
->defcell
;
960 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
962 /* Indicate that the global binding is set up now. */
964 SET_BLV_FOUND (blv
, 0);
967 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
968 VALCONTENTS is the contents of its value cell,
969 which points to a struct Lisp_Buffer_Local_Value.
971 Return the value forwarded one step past the buffer-local stage.
972 This could be another forwarding pointer. */
975 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
977 register Lisp_Object tem1
;
979 eassert (blv
== SYMBOL_BLV (symbol
));
985 ? !EQ (selected_frame
, tem1
)
986 : current_buffer
!= XBUFFER (tem1
)))
989 /* Unload the previously loaded binding. */
992 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
993 /* Choose the new binding. */
996 XSETSYMBOL (var
, symbol
);
997 if (blv
->frame_local
)
999 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1000 blv
->where
= selected_frame
;
1004 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1005 XSETBUFFER (blv
->where
, current_buffer
);
1008 if (!(blv
->found
= !NILP (tem1
)))
1009 tem1
= blv
->defcell
;
1011 /* Load the new binding. */
1012 blv
->valcell
= tem1
;
1014 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1018 /* Find the value of a symbol, returning Qunbound if it's not bound.
1019 This is helpful for code which just wants to get a variable's value
1020 if it has one, without signaling an error.
1021 Note that it must not be possible to quit
1022 within this function. Great care is required for this. */
1025 find_symbol_value (Lisp_Object symbol
)
1027 struct Lisp_Symbol
*sym
;
1029 CHECK_SYMBOL (symbol
);
1030 sym
= XSYMBOL (symbol
);
1033 switch (sym
->redirect
)
1035 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1036 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1037 case SYMBOL_LOCALIZED
:
1039 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1040 swap_in_symval_forwarding (sym
, blv
);
1041 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1044 case SYMBOL_FORWARDED
:
1045 return do_symval_forwarding (SYMBOL_FWD (sym
));
1050 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1051 doc
: /* Return SYMBOL's value. Error if that is void. */)
1052 (Lisp_Object symbol
)
1056 val
= find_symbol_value (symbol
);
1057 if (!EQ (val
, Qunbound
))
1060 xsignal1 (Qvoid_variable
, symbol
);
1063 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1064 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1065 (register Lisp_Object symbol
, Lisp_Object newval
)
1067 set_internal (symbol
, newval
, Qnil
, 0);
1071 /* Return 1 if SYMBOL currently has a let-binding
1072 which was made in the buffer that is now current. */
1075 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1077 struct specbinding
*p
;
1079 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1081 && CONSP (p
->symbol
))
1083 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1084 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1085 if (symbol
== let_bound_symbol
1086 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1090 return p
>= specpdl
;
1094 let_shadows_global_binding_p (Lisp_Object symbol
)
1096 struct specbinding
*p
;
1098 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1099 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1102 return p
>= specpdl
;
1105 /* Store the value NEWVAL into SYMBOL.
1106 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1107 (nil stands for the current buffer/frame).
1109 If BINDFLAG is zero, then if this symbol is supposed to become
1110 local in every buffer where it is set, then we make it local.
1111 If BINDFLAG is nonzero, we don't do that. */
1114 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1116 int voide
= EQ (newval
, Qunbound
);
1117 struct Lisp_Symbol
*sym
;
1120 /* If restoring in a dead buffer, do nothing. */
1121 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1124 CHECK_SYMBOL (symbol
);
1125 if (SYMBOL_CONSTANT_P (symbol
))
1127 if (NILP (Fkeywordp (symbol
))
1128 || !EQ (newval
, Fsymbol_value (symbol
)))
1129 xsignal1 (Qsetting_constant
, symbol
);
1131 /* Allow setting keywords to their own value. */
1135 sym
= XSYMBOL (symbol
);
1138 switch (sym
->redirect
)
1140 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1141 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1142 case SYMBOL_LOCALIZED
:
1144 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1147 if (blv
->frame_local
)
1148 where
= selected_frame
;
1150 XSETBUFFER (where
, current_buffer
);
1152 /* If the current buffer is not the buffer whose binding is
1153 loaded, or if there may be frame-local bindings and the frame
1154 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1155 the default binding is loaded, the loaded binding may be the
1157 if (!EQ (blv
->where
, where
)
1158 /* Also unload a global binding (if the var is local_if_set). */
1159 || (EQ (blv
->valcell
, blv
->defcell
)))
1161 /* The currently loaded binding is not necessarily valid.
1162 We need to unload it, and choose a new binding. */
1164 /* Write out `realvalue' to the old loaded binding. */
1166 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1168 /* Find the new binding. */
1169 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1170 tem1
= Fassq (symbol
,
1172 ? XFRAME (where
)->param_alist
1173 : BVAR (XBUFFER (where
), local_var_alist
)));
1179 /* This buffer still sees the default value. */
1181 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1182 or if this is `let' rather than `set',
1183 make CURRENT-ALIST-ELEMENT point to itself,
1184 indicating that we're seeing the default value.
1185 Likewise if the variable has been let-bound
1186 in the current buffer. */
1187 if (bindflag
|| !blv
->local_if_set
1188 || let_shadows_buffer_binding_p (sym
))
1191 tem1
= blv
->defcell
;
1193 /* If it's a local_if_set, being set not bound,
1194 and we're not within a let that was made for this buffer,
1195 create a new buffer-local binding for the variable.
1196 That means, give this buffer a new assoc for a local value
1197 and load that binding. */
1200 /* local_if_set is only supported for buffer-local
1201 bindings, not for frame-local bindings. */
1202 eassert (!blv
->frame_local
);
1203 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1204 BVAR (XBUFFER (where
), local_var_alist
)
1205 = Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
));
1209 /* Record which binding is now loaded. */
1210 blv
->valcell
= tem1
;
1213 /* Store the new value in the cons cell. */
1214 SET_BLV_VALUE (blv
, newval
);
1219 /* If storing void (making the symbol void), forward only through
1220 buffer-local indicator, not through Lisp_Objfwd, etc. */
1223 store_symval_forwarding (blv
->fwd
, newval
,
1225 ? XBUFFER (where
) : current_buffer
);
1229 case SYMBOL_FORWARDED
:
1232 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1233 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1234 if (BUFFER_OBJFWDP (innercontents
))
1236 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1237 int idx
= PER_BUFFER_IDX (offset
);
1240 && !let_shadows_buffer_binding_p (sym
))
1241 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1245 { /* If storing void (making the symbol void), forward only through
1246 buffer-local indicator, not through Lisp_Objfwd, etc. */
1247 sym
->redirect
= SYMBOL_PLAINVAL
;
1248 SET_SYMBOL_VAL (sym
, newval
);
1251 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1259 /* Access or set a buffer-local symbol's default value. */
1261 /* Return the default value of SYMBOL, but don't check for voidness.
1262 Return Qunbound if it is void. */
1265 default_value (Lisp_Object symbol
)
1267 struct Lisp_Symbol
*sym
;
1269 CHECK_SYMBOL (symbol
);
1270 sym
= XSYMBOL (symbol
);
1273 switch (sym
->redirect
)
1275 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1276 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1277 case SYMBOL_LOCALIZED
:
1279 /* If var is set up for a buffer that lacks a local value for it,
1280 the current value is nominally the default value.
1281 But the `realvalue' slot may be more up to date, since
1282 ordinary setq stores just that slot. So use that. */
1283 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1284 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1285 return do_symval_forwarding (blv
->fwd
);
1287 return XCDR (blv
->defcell
);
1289 case SYMBOL_FORWARDED
:
1291 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1293 /* For a built-in buffer-local variable, get the default value
1294 rather than letting do_symval_forwarding get the current value. */
1295 if (BUFFER_OBJFWDP (valcontents
))
1297 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1298 if (PER_BUFFER_IDX (offset
) != 0)
1299 return PER_BUFFER_DEFAULT (offset
);
1302 /* For other variables, get the current value. */
1303 return do_symval_forwarding (valcontents
);
1309 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1310 doc
: /* Return t if SYMBOL has a non-void default value.
1311 This is the value that is seen in buffers that do not have their own values
1312 for this variable. */)
1313 (Lisp_Object symbol
)
1315 register Lisp_Object value
;
1317 value
= default_value (symbol
);
1318 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1321 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1322 doc
: /* Return SYMBOL's default value.
1323 This is the value that is seen in buffers that do not have their own values
1324 for this variable. The default value is meaningful for variables with
1325 local bindings in certain buffers. */)
1326 (Lisp_Object symbol
)
1328 register Lisp_Object value
;
1330 value
= default_value (symbol
);
1331 if (!EQ (value
, Qunbound
))
1334 xsignal1 (Qvoid_variable
, symbol
);
1337 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1338 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1339 The default value is seen in buffers that do not have their own values
1340 for this variable. */)
1341 (Lisp_Object symbol
, Lisp_Object value
)
1343 struct Lisp_Symbol
*sym
;
1345 CHECK_SYMBOL (symbol
);
1346 if (SYMBOL_CONSTANT_P (symbol
))
1348 if (NILP (Fkeywordp (symbol
))
1349 || !EQ (value
, Fdefault_value (symbol
)))
1350 xsignal1 (Qsetting_constant
, symbol
);
1352 /* Allow setting keywords to their own value. */
1355 sym
= XSYMBOL (symbol
);
1358 switch (sym
->redirect
)
1360 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1361 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1362 case SYMBOL_LOCALIZED
:
1364 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1366 /* Store new value into the DEFAULT-VALUE slot. */
1367 XSETCDR (blv
->defcell
, value
);
1369 /* If the default binding is now loaded, set the REALVALUE slot too. */
1370 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1371 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1374 case SYMBOL_FORWARDED
:
1376 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1378 /* Handle variables like case-fold-search that have special slots
1380 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1381 if (BUFFER_OBJFWDP (valcontents
))
1383 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1384 int idx
= PER_BUFFER_IDX (offset
);
1386 PER_BUFFER_DEFAULT (offset
) = value
;
1388 /* If this variable is not always local in all buffers,
1389 set it in the buffers that don't nominally have a local value. */
1394 for (b
= all_buffers
; b
; b
= b
->next
)
1395 if (!PER_BUFFER_VALUE_P (b
, idx
))
1396 PER_BUFFER_VALUE (b
, offset
) = value
;
1401 return Fset (symbol
, value
);
1407 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1408 doc
: /* Set the default value of variable VAR to VALUE.
1409 VAR, the variable name, is literal (not evaluated);
1410 VALUE is an expression: it is evaluated and its value returned.
1411 The default value of a variable is seen in buffers
1412 that do not have their own values for the variable.
1414 More generally, you can use multiple variables and values, as in
1415 (setq-default VAR VALUE VAR VALUE...)
1416 This sets each VAR's default value to the corresponding VALUE.
1417 The VALUE for the Nth VAR can refer to the new default values
1419 usage: (setq-default [VAR VALUE]...) */)
1422 register Lisp_Object args_left
;
1423 register Lisp_Object val
, symbol
;
1424 struct gcpro gcpro1
;
1434 val
= Feval (Fcar (Fcdr (args_left
)));
1435 symbol
= XCAR (args_left
);
1436 Fset_default (symbol
, val
);
1437 args_left
= Fcdr (XCDR (args_left
));
1439 while (!NILP (args_left
));
1445 /* Lisp functions for creating and removing buffer-local variables. */
1450 union Lisp_Fwd
*fwd
;
1453 static struct Lisp_Buffer_Local_Value
*
1454 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1456 struct Lisp_Buffer_Local_Value
*blv
1457 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1461 XSETSYMBOL (symbol
, sym
);
1462 tem
= Fcons (symbol
, (forwarded
1463 ? do_symval_forwarding (valcontents
.fwd
)
1464 : valcontents
.value
));
1466 /* Buffer_Local_Values cannot have as realval a buffer-local
1467 or keyboard-local forwarding. */
1468 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1469 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1470 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1472 blv
->frame_local
= 0;
1473 blv
->local_if_set
= 0;
1476 SET_BLV_FOUND (blv
, 0);
1480 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1481 1, 1, "vMake Variable Buffer Local: ",
1482 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1483 At any time, the value for the current buffer is in effect,
1484 unless the variable has never been set in this buffer,
1485 in which case the default value is in effect.
1486 Note that binding the variable with `let', or setting it while
1487 a `let'-style binding made in this buffer is in effect,
1488 does not make the variable buffer-local. Return VARIABLE.
1490 In most cases it is better to use `make-local-variable',
1491 which makes a variable local in just one buffer.
1493 The function `default-value' gets the default value and `set-default' sets it. */)
1494 (register Lisp_Object variable
)
1496 struct Lisp_Symbol
*sym
;
1497 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1498 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1499 int forwarded
IF_LINT (= 0);
1501 CHECK_SYMBOL (variable
);
1502 sym
= XSYMBOL (variable
);
1505 switch (sym
->redirect
)
1507 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1508 case SYMBOL_PLAINVAL
:
1509 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1510 if (EQ (valcontents
.value
, Qunbound
))
1511 valcontents
.value
= Qnil
;
1513 case SYMBOL_LOCALIZED
:
1514 blv
= SYMBOL_BLV (sym
);
1515 if (blv
->frame_local
)
1516 error ("Symbol %s may not be buffer-local",
1517 SDATA (SYMBOL_NAME (variable
)));
1519 case SYMBOL_FORWARDED
:
1520 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1521 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1522 error ("Symbol %s may not be buffer-local",
1523 SDATA (SYMBOL_NAME (variable
)));
1524 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1531 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1535 blv
= make_blv (sym
, forwarded
, valcontents
);
1536 sym
->redirect
= SYMBOL_LOCALIZED
;
1537 SET_SYMBOL_BLV (sym
, blv
);
1540 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1541 if (let_shadows_global_binding_p (symbol
))
1542 message ("Making %s buffer-local while let-bound!",
1543 SDATA (SYMBOL_NAME (variable
)));
1547 blv
->local_if_set
= 1;
1551 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1552 1, 1, "vMake Local Variable: ",
1553 doc
: /* Make VARIABLE have a separate value in the current buffer.
1554 Other buffers will continue to share a common default value.
1555 \(The buffer-local value of VARIABLE starts out as the same value
1556 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1559 If the variable is already arranged to become local when set,
1560 this function causes a local value to exist for this buffer,
1561 just as setting the variable would do.
1563 This function returns VARIABLE, and therefore
1564 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1567 See also `make-variable-buffer-local'.
1569 Do not use `make-local-variable' to make a hook variable buffer-local.
1570 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1571 (register Lisp_Object variable
)
1573 register Lisp_Object tem
;
1574 int forwarded
IF_LINT (= 0);
1575 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1576 struct Lisp_Symbol
*sym
;
1577 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1579 CHECK_SYMBOL (variable
);
1580 sym
= XSYMBOL (variable
);
1583 switch (sym
->redirect
)
1585 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1586 case SYMBOL_PLAINVAL
:
1587 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1588 case SYMBOL_LOCALIZED
:
1589 blv
= SYMBOL_BLV (sym
);
1590 if (blv
->frame_local
)
1591 error ("Symbol %s may not be buffer-local",
1592 SDATA (SYMBOL_NAME (variable
)));
1594 case SYMBOL_FORWARDED
:
1595 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1596 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1597 error ("Symbol %s may not be buffer-local",
1598 SDATA (SYMBOL_NAME (variable
)));
1604 error ("Symbol %s may not be buffer-local",
1605 SDATA (SYMBOL_NAME (variable
)));
1607 if (blv
? blv
->local_if_set
1608 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1610 tem
= Fboundp (variable
);
1611 /* Make sure the symbol has a local value in this particular buffer,
1612 by setting it to the same value it already has. */
1613 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1618 blv
= make_blv (sym
, forwarded
, valcontents
);
1619 sym
->redirect
= SYMBOL_LOCALIZED
;
1620 SET_SYMBOL_BLV (sym
, blv
);
1623 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1624 if (let_shadows_global_binding_p (symbol
))
1625 message ("Making %s local to %s while let-bound!",
1626 SDATA (SYMBOL_NAME (variable
)),
1627 SDATA (BVAR (current_buffer
, name
)));
1631 /* Make sure this buffer has its own value of symbol. */
1632 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1633 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1636 if (let_shadows_buffer_binding_p (sym
))
1637 message ("Making %s buffer-local while locally let-bound!",
1638 SDATA (SYMBOL_NAME (variable
)));
1640 /* Swap out any local binding for some other buffer, and make
1641 sure the current value is permanently recorded, if it's the
1643 find_symbol_value (variable
);
1645 BVAR (current_buffer
, local_var_alist
)
1646 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1647 BVAR (current_buffer
, local_var_alist
));
1649 /* Make sure symbol does not think it is set up for this buffer;
1650 force it to look once again for this buffer's value. */
1651 if (current_buffer
== XBUFFER (blv
->where
))
1653 /* blv->valcell = blv->defcell;
1654 * SET_BLV_FOUND (blv, 0); */
1658 /* If the symbol forwards into a C variable, then load the binding
1659 for this buffer now. If C code modifies the variable before we
1660 load the binding in, then that new value will clobber the default
1661 binding the next time we unload it. */
1663 swap_in_symval_forwarding (sym
, blv
);
1668 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1669 1, 1, "vKill Local Variable: ",
1670 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1671 From now on the default value will apply in this buffer. Return VARIABLE. */)
1672 (register Lisp_Object variable
)
1674 register Lisp_Object tem
;
1675 struct Lisp_Buffer_Local_Value
*blv
;
1676 struct Lisp_Symbol
*sym
;
1678 CHECK_SYMBOL (variable
);
1679 sym
= XSYMBOL (variable
);
1682 switch (sym
->redirect
)
1684 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1685 case SYMBOL_PLAINVAL
: return variable
;
1686 case SYMBOL_FORWARDED
:
1688 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1689 if (BUFFER_OBJFWDP (valcontents
))
1691 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1692 int idx
= PER_BUFFER_IDX (offset
);
1696 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1697 PER_BUFFER_VALUE (current_buffer
, offset
)
1698 = PER_BUFFER_DEFAULT (offset
);
1703 case SYMBOL_LOCALIZED
:
1704 blv
= SYMBOL_BLV (sym
);
1705 if (blv
->frame_local
)
1711 /* Get rid of this buffer's alist element, if any. */
1712 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1713 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1715 BVAR (current_buffer
, local_var_alist
)
1716 = Fdelq (tem
, BVAR (current_buffer
, local_var_alist
));
1718 /* If the symbol is set up with the current buffer's binding
1719 loaded, recompute its value. We have to do it now, or else
1720 forwarded objects won't work right. */
1722 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1723 if (EQ (buf
, blv
->where
))
1726 /* blv->valcell = blv->defcell;
1727 * SET_BLV_FOUND (blv, 0); */
1729 find_symbol_value (variable
);
1736 /* Lisp functions for creating and removing buffer-local variables. */
1738 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1739 when/if this is removed. */
1741 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1742 1, 1, "vMake Variable Frame Local: ",
1743 doc
: /* Enable VARIABLE to have frame-local bindings.
1744 This does not create any frame-local bindings for VARIABLE,
1745 it just makes them possible.
1747 A frame-local binding is actually a frame parameter value.
1748 If a frame F has a value for the frame parameter named VARIABLE,
1749 that also acts as a frame-local binding for VARIABLE in F--
1750 provided this function has been called to enable VARIABLE
1751 to have frame-local bindings at all.
1753 The only way to create a frame-local binding for VARIABLE in a frame
1754 is to set the VARIABLE frame parameter of that frame. See
1755 `modify-frame-parameters' for how to set frame parameters.
1757 Note that since Emacs 23.1, variables cannot be both buffer-local and
1758 frame-local any more (buffer-local bindings used to take precedence over
1759 frame-local bindings). */)
1760 (register Lisp_Object variable
)
1763 union Lisp_Val_Fwd valcontents
;
1764 struct Lisp_Symbol
*sym
;
1765 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1767 CHECK_SYMBOL (variable
);
1768 sym
= XSYMBOL (variable
);
1771 switch (sym
->redirect
)
1773 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1774 case SYMBOL_PLAINVAL
:
1775 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1776 if (EQ (valcontents
.value
, Qunbound
))
1777 valcontents
.value
= Qnil
;
1779 case SYMBOL_LOCALIZED
:
1780 if (SYMBOL_BLV (sym
)->frame_local
)
1783 error ("Symbol %s may not be frame-local",
1784 SDATA (SYMBOL_NAME (variable
)));
1785 case SYMBOL_FORWARDED
:
1786 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1787 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1788 error ("Symbol %s may not be frame-local",
1789 SDATA (SYMBOL_NAME (variable
)));
1795 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1797 blv
= make_blv (sym
, forwarded
, valcontents
);
1798 blv
->frame_local
= 1;
1799 sym
->redirect
= SYMBOL_LOCALIZED
;
1800 SET_SYMBOL_BLV (sym
, blv
);
1803 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1804 if (let_shadows_global_binding_p (symbol
))
1805 message ("Making %s frame-local while let-bound!",
1806 SDATA (SYMBOL_NAME (variable
)));
1811 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1813 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1814 BUFFER defaults to the current buffer. */)
1815 (register Lisp_Object variable
, Lisp_Object buffer
)
1817 register struct buffer
*buf
;
1818 struct Lisp_Symbol
*sym
;
1821 buf
= current_buffer
;
1824 CHECK_BUFFER (buffer
);
1825 buf
= XBUFFER (buffer
);
1828 CHECK_SYMBOL (variable
);
1829 sym
= XSYMBOL (variable
);
1832 switch (sym
->redirect
)
1834 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1835 case SYMBOL_PLAINVAL
: return Qnil
;
1836 case SYMBOL_LOCALIZED
:
1838 Lisp_Object tail
, elt
, tmp
;
1839 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1840 XSETBUFFER (tmp
, buf
);
1841 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1843 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1846 if (EQ (variable
, XCAR (elt
)))
1848 eassert (!blv
->frame_local
);
1849 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1853 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1856 case SYMBOL_FORWARDED
:
1858 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1859 if (BUFFER_OBJFWDP (valcontents
))
1861 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1862 int idx
= PER_BUFFER_IDX (offset
);
1863 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1872 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1874 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1875 More precisely, this means that setting the variable \(with `set' or`setq'),
1876 while it does not have a `let'-style binding that was made in BUFFER,
1877 will produce a buffer local binding. See Info node
1878 `(elisp)Creating Buffer-Local'.
1879 BUFFER defaults to the current buffer. */)
1880 (register Lisp_Object variable
, Lisp_Object buffer
)
1882 struct Lisp_Symbol
*sym
;
1884 CHECK_SYMBOL (variable
);
1885 sym
= XSYMBOL (variable
);
1888 switch (sym
->redirect
)
1890 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1891 case SYMBOL_PLAINVAL
: return Qnil
;
1892 case SYMBOL_LOCALIZED
:
1894 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1895 if (blv
->local_if_set
)
1897 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1898 return Flocal_variable_p (variable
, buffer
);
1900 case SYMBOL_FORWARDED
:
1901 /* All BUFFER_OBJFWD slots become local if they are set. */
1902 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1907 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1909 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1910 If the current binding is buffer-local, the value is the current buffer.
1911 If the current binding is frame-local, the value is the selected frame.
1912 If the current binding is global (the default), the value is nil. */)
1913 (register Lisp_Object variable
)
1915 struct Lisp_Symbol
*sym
;
1917 CHECK_SYMBOL (variable
);
1918 sym
= XSYMBOL (variable
);
1920 /* Make sure the current binding is actually swapped in. */
1921 find_symbol_value (variable
);
1924 switch (sym
->redirect
)
1926 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1927 case SYMBOL_PLAINVAL
: return Qnil
;
1928 case SYMBOL_FORWARDED
:
1930 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1931 if (KBOARD_OBJFWDP (valcontents
))
1932 return Fframe_terminal (Fselected_frame ());
1933 else if (!BUFFER_OBJFWDP (valcontents
))
1937 case SYMBOL_LOCALIZED
:
1938 /* For a local variable, record both the symbol and which
1939 buffer's or frame's value we are saving. */
1940 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1941 return Fcurrent_buffer ();
1942 else if (sym
->redirect
== SYMBOL_LOCALIZED
1943 && BLV_FOUND (SYMBOL_BLV (sym
)))
1944 return SYMBOL_BLV (sym
)->where
;
1951 /* This code is disabled now that we use the selected frame to return
1952 keyboard-local-values. */
1954 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1956 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1957 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1958 If SYMBOL is not a terminal-local variable, then return its normal
1959 value, like `symbol-value'.
1961 TERMINAL may be a terminal object, a frame, or nil (meaning the
1962 selected frame's terminal device). */)
1963 (Lisp_Object symbol
, Lisp_Object terminal
)
1966 struct terminal
*t
= get_terminal (terminal
, 1);
1967 push_kboard (t
->kboard
);
1968 result
= Fsymbol_value (symbol
);
1973 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1974 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1975 If VARIABLE is not a terminal-local variable, then set its normal
1976 binding, like `set'.
1978 TERMINAL may be a terminal object, a frame, or nil (meaning the
1979 selected frame's terminal device). */)
1980 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1983 struct terminal
*t
= get_terminal (terminal
, 1);
1984 push_kboard (d
->kboard
);
1985 result
= Fset (symbol
, value
);
1991 /* Find the function at the end of a chain of symbol function indirections. */
1993 /* If OBJECT is a symbol, find the end of its function chain and
1994 return the value found there. If OBJECT is not a symbol, just
1995 return it. If there is a cycle in the function chain, signal a
1996 cyclic-function-indirection error.
1998 This is like Findirect_function, except that it doesn't signal an
1999 error if the chain ends up unbound. */
2001 indirect_function (register Lisp_Object object
)
2003 Lisp_Object tortoise
, hare
;
2005 hare
= tortoise
= object
;
2009 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2011 hare
= XSYMBOL (hare
)->function
;
2012 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2014 hare
= XSYMBOL (hare
)->function
;
2016 tortoise
= XSYMBOL (tortoise
)->function
;
2018 if (EQ (hare
, tortoise
))
2019 xsignal1 (Qcyclic_function_indirection
, object
);
2025 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2026 doc
: /* Return the function at the end of OBJECT's function chain.
2027 If OBJECT is not a symbol, just return it. Otherwise, follow all
2028 function indirections to find the final function binding and return it.
2029 If the final symbol in the chain is unbound, signal a void-function error.
2030 Optional arg NOERROR non-nil means to return nil instead of signalling.
2031 Signal a cyclic-function-indirection error if there is a loop in the
2032 function chain of symbols. */)
2033 (register Lisp_Object object
, Lisp_Object noerror
)
2037 /* Optimize for no indirection. */
2039 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2040 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2041 result
= indirect_function (result
);
2042 if (!EQ (result
, Qunbound
))
2046 xsignal1 (Qvoid_function
, object
);
2051 /* Extract and set vector and string elements */
2053 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2054 doc
: /* Return the element of ARRAY at index IDX.
2055 ARRAY may be a vector, a string, a char-table, a bool-vector,
2056 or a byte-code object. IDX starts at 0. */)
2057 (register Lisp_Object array
, Lisp_Object idx
)
2059 register EMACS_INT idxval
;
2062 idxval
= XINT (idx
);
2063 if (STRINGP (array
))
2066 EMACS_INT idxval_byte
;
2068 if (idxval
< 0 || idxval
>= SCHARS (array
))
2069 args_out_of_range (array
, idx
);
2070 if (! STRING_MULTIBYTE (array
))
2071 return make_number ((unsigned char) SREF (array
, idxval
));
2072 idxval_byte
= string_char_to_byte (array
, idxval
);
2074 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2075 return make_number (c
);
2077 else if (BOOL_VECTOR_P (array
))
2081 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2082 args_out_of_range (array
, idx
);
2084 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2085 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2087 else if (CHAR_TABLE_P (array
))
2089 CHECK_CHARACTER (idx
);
2090 return CHAR_TABLE_REF (array
, idxval
);
2095 if (VECTORP (array
))
2096 size
= XVECTOR (array
)->size
;
2097 else if (COMPILEDP (array
))
2098 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2100 wrong_type_argument (Qarrayp
, array
);
2102 if (idxval
< 0 || idxval
>= size
)
2103 args_out_of_range (array
, idx
);
2104 return XVECTOR (array
)->contents
[idxval
];
2108 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2109 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2110 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2111 bool-vector. IDX starts at 0. */)
2112 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2114 register EMACS_INT idxval
;
2117 idxval
= XINT (idx
);
2118 CHECK_ARRAY (array
, Qarrayp
);
2119 CHECK_IMPURE (array
);
2121 if (VECTORP (array
))
2123 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2124 args_out_of_range (array
, idx
);
2125 XVECTOR (array
)->contents
[idxval
] = newelt
;
2127 else if (BOOL_VECTOR_P (array
))
2131 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2132 args_out_of_range (array
, idx
);
2134 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2136 if (! NILP (newelt
))
2137 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2139 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2140 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2142 else if (CHAR_TABLE_P (array
))
2144 CHECK_CHARACTER (idx
);
2145 CHAR_TABLE_SET (array
, idxval
, newelt
);
2147 else if (STRING_MULTIBYTE (array
))
2149 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2150 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2152 if (idxval
< 0 || idxval
>= SCHARS (array
))
2153 args_out_of_range (array
, idx
);
2154 CHECK_CHARACTER (newelt
);
2156 nbytes
= SBYTES (array
);
2158 idxval_byte
= string_char_to_byte (array
, idxval
);
2159 p1
= SDATA (array
) + idxval_byte
;
2160 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2161 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2162 if (prev_bytes
!= new_bytes
)
2164 /* We must relocate the string data. */
2165 EMACS_INT nchars
= SCHARS (array
);
2169 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2170 memcpy (str
, SDATA (array
), nbytes
);
2171 allocate_string_data (XSTRING (array
), nchars
,
2172 nbytes
+ new_bytes
- prev_bytes
);
2173 memcpy (SDATA (array
), str
, idxval_byte
);
2174 p1
= SDATA (array
) + idxval_byte
;
2175 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2176 nbytes
- (idxval_byte
+ prev_bytes
));
2178 clear_string_char_byte_cache ();
2185 if (idxval
< 0 || idxval
>= SCHARS (array
))
2186 args_out_of_range (array
, idx
);
2187 CHECK_NUMBER (newelt
);
2189 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2193 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2194 if (SREF (array
, i
) >= 0x80)
2195 args_out_of_range (array
, newelt
);
2196 /* ARRAY is an ASCII string. Convert it to a multibyte
2197 string, and try `aset' again. */
2198 STRING_SET_MULTIBYTE (array
);
2199 return Faset (array
, idx
, newelt
);
2201 SSET (array
, idxval
, XINT (newelt
));
2207 /* Arithmetic functions */
2209 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2212 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2214 double f1
= 0, f2
= 0;
2217 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2218 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2220 if (FLOATP (num1
) || FLOATP (num2
))
2223 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2224 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2230 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2235 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2240 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2245 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2250 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2255 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2264 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2265 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2266 (register Lisp_Object num1
, Lisp_Object num2
)
2268 return arithcompare (num1
, num2
, equal
);
2271 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2272 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2273 (register Lisp_Object num1
, Lisp_Object num2
)
2275 return arithcompare (num1
, num2
, less
);
2278 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2279 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2280 (register Lisp_Object num1
, Lisp_Object num2
)
2282 return arithcompare (num1
, num2
, grtr
);
2285 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2286 doc
: /* Return t if first arg is less than or equal to second arg.
2287 Both must be numbers or markers. */)
2288 (register Lisp_Object num1
, Lisp_Object num2
)
2290 return arithcompare (num1
, num2
, less_or_equal
);
2293 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2294 doc
: /* Return t if first arg is greater than or equal to second arg.
2295 Both must be numbers or markers. */)
2296 (register Lisp_Object num1
, Lisp_Object num2
)
2298 return arithcompare (num1
, num2
, grtr_or_equal
);
2301 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2302 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2303 (register Lisp_Object num1
, Lisp_Object num2
)
2305 return arithcompare (num1
, num2
, notequal
);
2308 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2309 doc
: /* Return t if NUMBER is zero. */)
2310 (register Lisp_Object number
)
2312 CHECK_NUMBER_OR_FLOAT (number
);
2314 if (FLOATP (number
))
2316 if (XFLOAT_DATA (number
) == 0.0)
2326 /* Convert between long values and pairs of Lisp integers.
2327 Note that long_to_cons returns a single Lisp integer
2328 when the value fits in one. */
2331 long_to_cons (long unsigned int i
)
2333 unsigned long top
= i
>> 16;
2334 unsigned int bot
= i
& 0xFFFF;
2336 return make_number (bot
);
2337 if (top
== (unsigned long)-1 >> 16)
2338 return Fcons (make_number (-1), make_number (bot
));
2339 return Fcons (make_number (top
), make_number (bot
));
2343 cons_to_long (Lisp_Object c
)
2345 Lisp_Object top
, bot
;
2352 return ((XINT (top
) << 16) | XINT (bot
));
2355 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2356 doc
: /* Return the decimal representation of NUMBER as a string.
2357 Uses a minus sign if negative.
2358 NUMBER may be an integer or a floating point number. */)
2359 (Lisp_Object number
)
2361 char buffer
[VALBITS
];
2363 CHECK_NUMBER_OR_FLOAT (number
);
2365 if (FLOATP (number
))
2367 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2369 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2370 return build_string (pigbuf
);
2373 if (sizeof (int) == sizeof (EMACS_INT
))
2374 sprintf (buffer
, "%d", (int) XINT (number
));
2375 else if (sizeof (long) == sizeof (EMACS_INT
))
2376 sprintf (buffer
, "%ld", (long) XINT (number
));
2379 return build_string (buffer
);
2383 digit_to_number (int character
, int base
)
2387 if (character
>= '0' && character
<= '9')
2388 digit
= character
- '0';
2389 else if (character
>= 'a' && character
<= 'z')
2390 digit
= character
- 'a' + 10;
2391 else if (character
>= 'A' && character
<= 'Z')
2392 digit
= character
- 'A' + 10;
2402 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2403 doc
: /* Parse STRING as a decimal number and return the number.
2404 This parses both integers and floating point numbers.
2405 It ignores leading spaces and tabs, and all trailing chars.
2407 If BASE, interpret STRING as a number in that base. If BASE isn't
2408 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2409 If the base used is not 10, STRING is always parsed as integer. */)
2410 (register Lisp_Object string
, Lisp_Object base
)
2417 CHECK_STRING (string
);
2423 CHECK_NUMBER (base
);
2425 if (b
< 2 || b
> 16)
2426 xsignal1 (Qargs_out_of_range
, base
);
2429 /* Skip any whitespace at the front of the number. Some versions of
2430 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2431 p
= SSDATA (string
);
2432 while (*p
== ' ' || *p
== '\t')
2443 if (isfloat_string (p
, 1) && b
== 10)
2444 val
= make_float (sign
* atof (p
));
2451 int digit
= digit_to_number (*p
++, b
);
2457 val
= make_fixnum_or_float (sign
* v
);
2477 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2478 int, Lisp_Object
*);
2480 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2482 register Lisp_Object val
;
2483 register int argnum
;
2484 register EMACS_INT accum
= 0;
2485 register EMACS_INT next
;
2487 switch (SWITCH_ENUM_CAST (code
))
2505 for (argnum
= 0; argnum
< nargs
; argnum
++)
2507 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2509 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2512 return float_arith_driver ((double) accum
, argnum
, code
,
2515 next
= XINT (args
[argnum
]);
2516 switch (SWITCH_ENUM_CAST (code
))
2522 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2533 xsignal0 (Qarith_error
);
2547 if (!argnum
|| next
> accum
)
2551 if (!argnum
|| next
< accum
)
2557 XSETINT (val
, accum
);
2562 #define isnan(x) ((x) != (x))
2565 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2567 register Lisp_Object val
;
2570 for (; argnum
< nargs
; argnum
++)
2572 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2573 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2577 next
= XFLOAT_DATA (val
);
2581 args
[argnum
] = val
; /* runs into a compiler bug. */
2582 next
= XINT (args
[argnum
]);
2584 switch (SWITCH_ENUM_CAST (code
))
2590 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2600 if (! IEEE_FLOATING_POINT
&& next
== 0)
2601 xsignal0 (Qarith_error
);
2608 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2610 if (!argnum
|| isnan (next
) || next
> accum
)
2614 if (!argnum
|| isnan (next
) || next
< accum
)
2620 return make_float (accum
);
2624 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2625 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2626 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2627 (int nargs
, Lisp_Object
*args
)
2629 return arith_driver (Aadd
, nargs
, args
);
2632 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2633 doc
: /* Negate number or subtract numbers or markers and return the result.
2634 With one arg, negates it. With more than one arg,
2635 subtracts all but the first from the first.
2636 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2637 (int nargs
, Lisp_Object
*args
)
2639 return arith_driver (Asub
, nargs
, args
);
2642 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2643 doc
: /* Return product of any number of arguments, which are numbers or markers.
2644 usage: (* &rest NUMBERS-OR-MARKERS) */)
2645 (int nargs
, Lisp_Object
*args
)
2647 return arith_driver (Amult
, nargs
, args
);
2650 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2651 doc
: /* Return first argument divided by all the remaining arguments.
2652 The arguments must be numbers or markers.
2653 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2654 (int nargs
, Lisp_Object
*args
)
2657 for (argnum
= 2; argnum
< nargs
; argnum
++)
2658 if (FLOATP (args
[argnum
]))
2659 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2660 return arith_driver (Adiv
, nargs
, args
);
2663 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2664 doc
: /* Return remainder of X divided by Y.
2665 Both must be integers or markers. */)
2666 (register Lisp_Object x
, Lisp_Object y
)
2670 CHECK_NUMBER_COERCE_MARKER (x
);
2671 CHECK_NUMBER_COERCE_MARKER (y
);
2673 if (XFASTINT (y
) == 0)
2674 xsignal0 (Qarith_error
);
2676 XSETINT (val
, XINT (x
) % XINT (y
));
2690 /* If the magnitude of the result exceeds that of the divisor, or
2691 the sign of the result does not agree with that of the dividend,
2692 iterate with the reduced value. This does not yield a
2693 particularly accurate result, but at least it will be in the
2694 range promised by fmod. */
2696 r
-= f2
* floor (r
/ f2
);
2697 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2701 #endif /* ! HAVE_FMOD */
2703 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2704 doc
: /* Return X modulo Y.
2705 The result falls between zero (inclusive) and Y (exclusive).
2706 Both X and Y must be numbers or markers. */)
2707 (register Lisp_Object x
, Lisp_Object y
)
2712 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2713 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2715 if (FLOATP (x
) || FLOATP (y
))
2716 return fmod_float (x
, y
);
2722 xsignal0 (Qarith_error
);
2726 /* If the "remainder" comes out with the wrong sign, fix it. */
2727 if (i2
< 0 ? i1
> 0 : i1
< 0)
2734 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2735 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2736 The value is always a number; markers are converted to numbers.
2737 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2738 (int nargs
, Lisp_Object
*args
)
2740 return arith_driver (Amax
, nargs
, args
);
2743 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2744 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2745 The value is always a number; markers are converted to numbers.
2746 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2747 (int nargs
, Lisp_Object
*args
)
2749 return arith_driver (Amin
, nargs
, args
);
2752 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2753 doc
: /* Return bitwise-and of all the arguments.
2754 Arguments may be integers, or markers converted to integers.
2755 usage: (logand &rest INTS-OR-MARKERS) */)
2756 (int nargs
, Lisp_Object
*args
)
2758 return arith_driver (Alogand
, nargs
, args
);
2761 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2762 doc
: /* Return bitwise-or of all the arguments.
2763 Arguments may be integers, or markers converted to integers.
2764 usage: (logior &rest INTS-OR-MARKERS) */)
2765 (int nargs
, Lisp_Object
*args
)
2767 return arith_driver (Alogior
, nargs
, args
);
2770 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2771 doc
: /* Return bitwise-exclusive-or of all the arguments.
2772 Arguments may be integers, or markers converted to integers.
2773 usage: (logxor &rest INTS-OR-MARKERS) */)
2774 (int nargs
, Lisp_Object
*args
)
2776 return arith_driver (Alogxor
, nargs
, args
);
2779 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2780 doc
: /* Return VALUE with its bits shifted left by COUNT.
2781 If COUNT is negative, shifting is actually to the right.
2782 In this case, the sign bit is duplicated. */)
2783 (register Lisp_Object value
, Lisp_Object count
)
2785 register Lisp_Object val
;
2787 CHECK_NUMBER (value
);
2788 CHECK_NUMBER (count
);
2790 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2792 else if (XINT (count
) > 0)
2793 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2794 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2795 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2797 XSETINT (val
, XINT (value
) >> -XINT (count
));
2801 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2802 doc
: /* Return VALUE with its bits shifted left by COUNT.
2803 If COUNT is negative, shifting is actually to the right.
2804 In this case, zeros are shifted in on the left. */)
2805 (register Lisp_Object value
, Lisp_Object count
)
2807 register Lisp_Object val
;
2809 CHECK_NUMBER (value
);
2810 CHECK_NUMBER (count
);
2812 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2814 else if (XINT (count
) > 0)
2815 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2816 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2819 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2823 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2824 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2825 Markers are converted to integers. */)
2826 (register Lisp_Object number
)
2828 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2830 if (FLOATP (number
))
2831 return (make_float (1.0 + XFLOAT_DATA (number
)));
2833 XSETINT (number
, XINT (number
) + 1);
2837 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2838 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2839 Markers are converted to integers. */)
2840 (register Lisp_Object number
)
2842 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2844 if (FLOATP (number
))
2845 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2847 XSETINT (number
, XINT (number
) - 1);
2851 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2852 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2853 (register Lisp_Object number
)
2855 CHECK_NUMBER (number
);
2856 XSETINT (number
, ~XINT (number
));
2860 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2861 doc
: /* Return the byteorder for the machine.
2862 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2863 lowercase l) for small endian machines. */)
2866 unsigned i
= 0x04030201;
2867 int order
= *(char *)&i
== 1 ? 108 : 66;
2869 return make_number (order
);
2877 Lisp_Object error_tail
, arith_tail
;
2879 Qquote
= intern_c_string ("quote");
2880 Qlambda
= intern_c_string ("lambda");
2881 Qsubr
= intern_c_string ("subr");
2882 Qerror_conditions
= intern_c_string ("error-conditions");
2883 Qerror_message
= intern_c_string ("error-message");
2884 Qtop_level
= intern_c_string ("top-level");
2886 Qerror
= intern_c_string ("error");
2887 Qquit
= intern_c_string ("quit");
2888 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2889 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2890 Qvoid_function
= intern_c_string ("void-function");
2891 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2892 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2893 Qvoid_variable
= intern_c_string ("void-variable");
2894 Qsetting_constant
= intern_c_string ("setting-constant");
2895 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2897 Qinvalid_function
= intern_c_string ("invalid-function");
2898 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2899 Qno_catch
= intern_c_string ("no-catch");
2900 Qend_of_file
= intern_c_string ("end-of-file");
2901 Qarith_error
= intern_c_string ("arith-error");
2902 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2903 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2904 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2905 Qtext_read_only
= intern_c_string ("text-read-only");
2906 Qmark_inactive
= intern_c_string ("mark-inactive");
2908 Qlistp
= intern_c_string ("listp");
2909 Qconsp
= intern_c_string ("consp");
2910 Qsymbolp
= intern_c_string ("symbolp");
2911 Qkeywordp
= intern_c_string ("keywordp");
2912 Qintegerp
= intern_c_string ("integerp");
2913 Qnatnump
= intern_c_string ("natnump");
2914 Qwholenump
= intern_c_string ("wholenump");
2915 Qstringp
= intern_c_string ("stringp");
2916 Qarrayp
= intern_c_string ("arrayp");
2917 Qsequencep
= intern_c_string ("sequencep");
2918 Qbufferp
= intern_c_string ("bufferp");
2919 Qvectorp
= intern_c_string ("vectorp");
2920 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2921 Qmarkerp
= intern_c_string ("markerp");
2922 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2923 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2924 Qboundp
= intern_c_string ("boundp");
2925 Qfboundp
= intern_c_string ("fboundp");
2927 Qfloatp
= intern_c_string ("floatp");
2928 Qnumberp
= intern_c_string ("numberp");
2929 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2931 Qchar_table_p
= intern_c_string ("char-table-p");
2932 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2934 Qsubrp
= intern_c_string ("subrp");
2935 Qunevalled
= intern_c_string ("unevalled");
2936 Qmany
= intern_c_string ("many");
2938 Qcdr
= intern_c_string ("cdr");
2940 /* Handle automatic advice activation */
2941 Qad_advice_info
= intern_c_string ("ad-advice-info");
2942 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2944 error_tail
= pure_cons (Qerror
, Qnil
);
2946 /* ERROR is used as a signaler for random errors for which nothing else is right */
2948 Fput (Qerror
, Qerror_conditions
,
2950 Fput (Qerror
, Qerror_message
,
2951 make_pure_c_string ("error"));
2953 Fput (Qquit
, Qerror_conditions
,
2954 pure_cons (Qquit
, Qnil
));
2955 Fput (Qquit
, Qerror_message
,
2956 make_pure_c_string ("Quit"));
2958 Fput (Qwrong_type_argument
, Qerror_conditions
,
2959 pure_cons (Qwrong_type_argument
, error_tail
));
2960 Fput (Qwrong_type_argument
, Qerror_message
,
2961 make_pure_c_string ("Wrong type argument"));
2963 Fput (Qargs_out_of_range
, Qerror_conditions
,
2964 pure_cons (Qargs_out_of_range
, error_tail
));
2965 Fput (Qargs_out_of_range
, Qerror_message
,
2966 make_pure_c_string ("Args out of range"));
2968 Fput (Qvoid_function
, Qerror_conditions
,
2969 pure_cons (Qvoid_function
, error_tail
));
2970 Fput (Qvoid_function
, Qerror_message
,
2971 make_pure_c_string ("Symbol's function definition is void"));
2973 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2974 pure_cons (Qcyclic_function_indirection
, error_tail
));
2975 Fput (Qcyclic_function_indirection
, Qerror_message
,
2976 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2978 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2979 pure_cons (Qcyclic_variable_indirection
, error_tail
));
2980 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2981 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
2983 Qcircular_list
= intern_c_string ("circular-list");
2984 staticpro (&Qcircular_list
);
2985 Fput (Qcircular_list
, Qerror_conditions
,
2986 pure_cons (Qcircular_list
, error_tail
));
2987 Fput (Qcircular_list
, Qerror_message
,
2988 make_pure_c_string ("List contains a loop"));
2990 Fput (Qvoid_variable
, Qerror_conditions
,
2991 pure_cons (Qvoid_variable
, error_tail
));
2992 Fput (Qvoid_variable
, Qerror_message
,
2993 make_pure_c_string ("Symbol's value as variable is void"));
2995 Fput (Qsetting_constant
, Qerror_conditions
,
2996 pure_cons (Qsetting_constant
, error_tail
));
2997 Fput (Qsetting_constant
, Qerror_message
,
2998 make_pure_c_string ("Attempt to set a constant symbol"));
3000 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3001 pure_cons (Qinvalid_read_syntax
, error_tail
));
3002 Fput (Qinvalid_read_syntax
, Qerror_message
,
3003 make_pure_c_string ("Invalid read syntax"));
3005 Fput (Qinvalid_function
, Qerror_conditions
,
3006 pure_cons (Qinvalid_function
, error_tail
));
3007 Fput (Qinvalid_function
, Qerror_message
,
3008 make_pure_c_string ("Invalid function"));
3010 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3011 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3012 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3013 make_pure_c_string ("Wrong number of arguments"));
3015 Fput (Qno_catch
, Qerror_conditions
,
3016 pure_cons (Qno_catch
, error_tail
));
3017 Fput (Qno_catch
, Qerror_message
,
3018 make_pure_c_string ("No catch for tag"));
3020 Fput (Qend_of_file
, Qerror_conditions
,
3021 pure_cons (Qend_of_file
, error_tail
));
3022 Fput (Qend_of_file
, Qerror_message
,
3023 make_pure_c_string ("End of file during parsing"));
3025 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3026 Fput (Qarith_error
, Qerror_conditions
,
3028 Fput (Qarith_error
, Qerror_message
,
3029 make_pure_c_string ("Arithmetic error"));
3031 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3032 pure_cons (Qbeginning_of_buffer
, error_tail
));
3033 Fput (Qbeginning_of_buffer
, Qerror_message
,
3034 make_pure_c_string ("Beginning of buffer"));
3036 Fput (Qend_of_buffer
, Qerror_conditions
,
3037 pure_cons (Qend_of_buffer
, error_tail
));
3038 Fput (Qend_of_buffer
, Qerror_message
,
3039 make_pure_c_string ("End of buffer"));
3041 Fput (Qbuffer_read_only
, Qerror_conditions
,
3042 pure_cons (Qbuffer_read_only
, error_tail
));
3043 Fput (Qbuffer_read_only
, Qerror_message
,
3044 make_pure_c_string ("Buffer is read-only"));
3046 Fput (Qtext_read_only
, Qerror_conditions
,
3047 pure_cons (Qtext_read_only
, error_tail
));
3048 Fput (Qtext_read_only
, Qerror_message
,
3049 make_pure_c_string ("Text is read-only"));
3051 Qrange_error
= intern_c_string ("range-error");
3052 Qdomain_error
= intern_c_string ("domain-error");
3053 Qsingularity_error
= intern_c_string ("singularity-error");
3054 Qoverflow_error
= intern_c_string ("overflow-error");
3055 Qunderflow_error
= intern_c_string ("underflow-error");
3057 Fput (Qdomain_error
, Qerror_conditions
,
3058 pure_cons (Qdomain_error
, arith_tail
));
3059 Fput (Qdomain_error
, Qerror_message
,
3060 make_pure_c_string ("Arithmetic domain error"));
3062 Fput (Qrange_error
, Qerror_conditions
,
3063 pure_cons (Qrange_error
, arith_tail
));
3064 Fput (Qrange_error
, Qerror_message
,
3065 make_pure_c_string ("Arithmetic range error"));
3067 Fput (Qsingularity_error
, Qerror_conditions
,
3068 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3069 Fput (Qsingularity_error
, Qerror_message
,
3070 make_pure_c_string ("Arithmetic singularity error"));
3072 Fput (Qoverflow_error
, Qerror_conditions
,
3073 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3074 Fput (Qoverflow_error
, Qerror_message
,
3075 make_pure_c_string ("Arithmetic overflow error"));
3077 Fput (Qunderflow_error
, Qerror_conditions
,
3078 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3079 Fput (Qunderflow_error
, Qerror_message
,
3080 make_pure_c_string ("Arithmetic underflow error"));
3082 staticpro (&Qrange_error
);
3083 staticpro (&Qdomain_error
);
3084 staticpro (&Qsingularity_error
);
3085 staticpro (&Qoverflow_error
);
3086 staticpro (&Qunderflow_error
);
3090 staticpro (&Qquote
);
3091 staticpro (&Qlambda
);
3093 staticpro (&Qunbound
);
3094 staticpro (&Qerror_conditions
);
3095 staticpro (&Qerror_message
);
3096 staticpro (&Qtop_level
);
3098 staticpro (&Qerror
);
3100 staticpro (&Qwrong_type_argument
);
3101 staticpro (&Qargs_out_of_range
);
3102 staticpro (&Qvoid_function
);
3103 staticpro (&Qcyclic_function_indirection
);
3104 staticpro (&Qcyclic_variable_indirection
);
3105 staticpro (&Qvoid_variable
);
3106 staticpro (&Qsetting_constant
);
3107 staticpro (&Qinvalid_read_syntax
);
3108 staticpro (&Qwrong_number_of_arguments
);
3109 staticpro (&Qinvalid_function
);
3110 staticpro (&Qno_catch
);
3111 staticpro (&Qend_of_file
);
3112 staticpro (&Qarith_error
);
3113 staticpro (&Qbeginning_of_buffer
);
3114 staticpro (&Qend_of_buffer
);
3115 staticpro (&Qbuffer_read_only
);
3116 staticpro (&Qtext_read_only
);
3117 staticpro (&Qmark_inactive
);
3119 staticpro (&Qlistp
);
3120 staticpro (&Qconsp
);
3121 staticpro (&Qsymbolp
);
3122 staticpro (&Qkeywordp
);
3123 staticpro (&Qintegerp
);
3124 staticpro (&Qnatnump
);
3125 staticpro (&Qwholenump
);
3126 staticpro (&Qstringp
);
3127 staticpro (&Qarrayp
);
3128 staticpro (&Qsequencep
);
3129 staticpro (&Qbufferp
);
3130 staticpro (&Qvectorp
);
3131 staticpro (&Qchar_or_string_p
);
3132 staticpro (&Qmarkerp
);
3133 staticpro (&Qbuffer_or_string_p
);
3134 staticpro (&Qinteger_or_marker_p
);
3135 staticpro (&Qfloatp
);
3136 staticpro (&Qnumberp
);
3137 staticpro (&Qnumber_or_marker_p
);
3138 staticpro (&Qchar_table_p
);
3139 staticpro (&Qvector_or_char_table_p
);
3140 staticpro (&Qsubrp
);
3142 staticpro (&Qunevalled
);
3144 staticpro (&Qboundp
);
3145 staticpro (&Qfboundp
);
3147 staticpro (&Qad_advice_info
);
3148 staticpro (&Qad_activate_internal
);
3150 /* Types that type-of returns. */
3151 Qinteger
= intern_c_string ("integer");
3152 Qsymbol
= intern_c_string ("symbol");
3153 Qstring
= intern_c_string ("string");
3154 Qcons
= intern_c_string ("cons");
3155 Qmarker
= intern_c_string ("marker");
3156 Qoverlay
= intern_c_string ("overlay");
3157 Qfloat
= intern_c_string ("float");
3158 Qwindow_configuration
= intern_c_string ("window-configuration");
3159 Qprocess
= intern_c_string ("process");
3160 Qwindow
= intern_c_string ("window");
3161 /* Qsubr = intern_c_string ("subr"); */
3162 Qcompiled_function
= intern_c_string ("compiled-function");
3163 Qbuffer
= intern_c_string ("buffer");
3164 Qframe
= intern_c_string ("frame");
3165 Qvector
= intern_c_string ("vector");
3166 Qchar_table
= intern_c_string ("char-table");
3167 Qbool_vector
= intern_c_string ("bool-vector");
3168 Qhash_table
= intern_c_string ("hash-table");
3170 DEFSYM (Qfont_spec
, "font-spec");
3171 DEFSYM (Qfont_entity
, "font-entity");
3172 DEFSYM (Qfont_object
, "font-object");
3174 DEFSYM (Qinteractive_form
, "interactive-form");
3176 staticpro (&Qinteger
);
3177 staticpro (&Qsymbol
);
3178 staticpro (&Qstring
);
3180 staticpro (&Qmarker
);
3181 staticpro (&Qoverlay
);
3182 staticpro (&Qfloat
);
3183 staticpro (&Qwindow_configuration
);
3184 staticpro (&Qprocess
);
3185 staticpro (&Qwindow
);
3186 /* staticpro (&Qsubr); */
3187 staticpro (&Qcompiled_function
);
3188 staticpro (&Qbuffer
);
3189 staticpro (&Qframe
);
3190 staticpro (&Qvector
);
3191 staticpro (&Qchar_table
);
3192 staticpro (&Qbool_vector
);
3193 staticpro (&Qhash_table
);
3195 defsubr (&Sindirect_variable
);
3196 defsubr (&Sinteractive_form
);
3199 defsubr (&Stype_of
);
3204 defsubr (&Sintegerp
);
3205 defsubr (&Sinteger_or_marker_p
);
3206 defsubr (&Snumberp
);
3207 defsubr (&Snumber_or_marker_p
);
3209 defsubr (&Snatnump
);
3210 defsubr (&Ssymbolp
);
3211 defsubr (&Skeywordp
);
3212 defsubr (&Sstringp
);
3213 defsubr (&Smultibyte_string_p
);
3214 defsubr (&Svectorp
);
3215 defsubr (&Schar_table_p
);
3216 defsubr (&Svector_or_char_table_p
);
3217 defsubr (&Sbool_vector_p
);
3219 defsubr (&Ssequencep
);
3220 defsubr (&Sbufferp
);
3221 defsubr (&Smarkerp
);
3223 defsubr (&Sbyte_code_function_p
);
3224 defsubr (&Schar_or_string_p
);
3227 defsubr (&Scar_safe
);
3228 defsubr (&Scdr_safe
);
3231 defsubr (&Ssymbol_function
);
3232 defsubr (&Sindirect_function
);
3233 defsubr (&Ssymbol_plist
);
3234 defsubr (&Ssymbol_name
);
3235 defsubr (&Smakunbound
);
3236 defsubr (&Sfmakunbound
);
3238 defsubr (&Sfboundp
);
3240 defsubr (&Sdefalias
);
3241 defsubr (&Ssetplist
);
3242 defsubr (&Ssymbol_value
);
3244 defsubr (&Sdefault_boundp
);
3245 defsubr (&Sdefault_value
);
3246 defsubr (&Sset_default
);
3247 defsubr (&Ssetq_default
);
3248 defsubr (&Smake_variable_buffer_local
);
3249 defsubr (&Smake_local_variable
);
3250 defsubr (&Skill_local_variable
);
3251 defsubr (&Smake_variable_frame_local
);
3252 defsubr (&Slocal_variable_p
);
3253 defsubr (&Slocal_variable_if_set_p
);
3254 defsubr (&Svariable_binding_locus
);
3255 #if 0 /* XXX Remove this. --lorentey */
3256 defsubr (&Sterminal_local_value
);
3257 defsubr (&Sset_terminal_local_value
);
3261 defsubr (&Snumber_to_string
);
3262 defsubr (&Sstring_to_number
);
3263 defsubr (&Seqlsign
);
3286 defsubr (&Sbyteorder
);
3287 defsubr (&Ssubr_arity
);
3288 defsubr (&Ssubr_name
);
3290 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3292 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3293 doc
: /* The largest value that is representable in a Lisp integer. */);
3294 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3295 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3297 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3298 doc
: /* The smallest value that is representable in a Lisp integer. */);
3299 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3300 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3304 arith_error (int signo
)
3306 sigsetmask (SIGEMPTYMASK
);
3308 SIGNAL_THREAD_CHECK (signo
);
3309 xsignal0 (Qarith_error
);
3315 /* Don't do this if just dumping out.
3316 We don't want to call `signal' in this case
3317 so that we don't have trouble with dumping
3318 signal-delivering routines in an inconsistent state. */
3322 #endif /* CANNOT_DUMP */
3323 signal (SIGFPE
, arith_error
);
3326 signal (SIGEMT
, arith_error
);