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, size_t, enum arithop
,
2478 size_t, Lisp_Object
*);
2480 arith_driver (enum arithop code
, size_t nargs
, register Lisp_Object
*args
)
2482 register Lisp_Object val
;
2483 register size_t 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 size_t argnum
, enum arithop code
,
2566 size_t nargs
, register Lisp_Object
*args
)
2568 register Lisp_Object val
;
2571 for (; argnum
< nargs
; argnum
++)
2573 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2574 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2578 next
= XFLOAT_DATA (val
);
2582 args
[argnum
] = val
; /* runs into a compiler bug. */
2583 next
= XINT (args
[argnum
]);
2585 switch (SWITCH_ENUM_CAST (code
))
2591 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2601 if (! IEEE_FLOATING_POINT
&& next
== 0)
2602 xsignal0 (Qarith_error
);
2609 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2611 if (!argnum
|| isnan (next
) || next
> accum
)
2615 if (!argnum
|| isnan (next
) || next
< accum
)
2621 return make_float (accum
);
2625 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2626 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2627 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2628 (size_t nargs
, Lisp_Object
*args
)
2630 return arith_driver (Aadd
, nargs
, args
);
2633 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2634 doc
: /* Negate number or subtract numbers or markers and return the result.
2635 With one arg, negates it. With more than one arg,
2636 subtracts all but the first from the first.
2637 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2638 (size_t nargs
, Lisp_Object
*args
)
2640 return arith_driver (Asub
, nargs
, args
);
2643 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2644 doc
: /* Return product of any number of arguments, which are numbers or markers.
2645 usage: (* &rest NUMBERS-OR-MARKERS) */)
2646 (size_t nargs
, Lisp_Object
*args
)
2648 return arith_driver (Amult
, nargs
, args
);
2651 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2652 doc
: /* Return first argument divided by all the remaining arguments.
2653 The arguments must be numbers or markers.
2654 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2655 (size_t nargs
, Lisp_Object
*args
)
2658 for (argnum
= 2; argnum
< nargs
; argnum
++)
2659 if (FLOATP (args
[argnum
]))
2660 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2661 return arith_driver (Adiv
, nargs
, args
);
2664 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2665 doc
: /* Return remainder of X divided by Y.
2666 Both must be integers or markers. */)
2667 (register Lisp_Object x
, Lisp_Object y
)
2671 CHECK_NUMBER_COERCE_MARKER (x
);
2672 CHECK_NUMBER_COERCE_MARKER (y
);
2674 if (XFASTINT (y
) == 0)
2675 xsignal0 (Qarith_error
);
2677 XSETINT (val
, XINT (x
) % XINT (y
));
2691 /* If the magnitude of the result exceeds that of the divisor, or
2692 the sign of the result does not agree with that of the dividend,
2693 iterate with the reduced value. This does not yield a
2694 particularly accurate result, but at least it will be in the
2695 range promised by fmod. */
2697 r
-= f2
* floor (r
/ f2
);
2698 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2702 #endif /* ! HAVE_FMOD */
2704 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2705 doc
: /* Return X modulo Y.
2706 The result falls between zero (inclusive) and Y (exclusive).
2707 Both X and Y must be numbers or markers. */)
2708 (register Lisp_Object x
, Lisp_Object y
)
2713 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2714 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2716 if (FLOATP (x
) || FLOATP (y
))
2717 return fmod_float (x
, y
);
2723 xsignal0 (Qarith_error
);
2727 /* If the "remainder" comes out with the wrong sign, fix it. */
2728 if (i2
< 0 ? i1
> 0 : i1
< 0)
2735 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2736 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2737 The value is always a number; markers are converted to numbers.
2738 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2739 (size_t nargs
, Lisp_Object
*args
)
2741 return arith_driver (Amax
, nargs
, args
);
2744 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2745 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2746 The value is always a number; markers are converted to numbers.
2747 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2748 (size_t nargs
, Lisp_Object
*args
)
2750 return arith_driver (Amin
, nargs
, args
);
2753 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2754 doc
: /* Return bitwise-and of all the arguments.
2755 Arguments may be integers, or markers converted to integers.
2756 usage: (logand &rest INTS-OR-MARKERS) */)
2757 (size_t nargs
, Lisp_Object
*args
)
2759 return arith_driver (Alogand
, nargs
, args
);
2762 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2763 doc
: /* Return bitwise-or of all the arguments.
2764 Arguments may be integers, or markers converted to integers.
2765 usage: (logior &rest INTS-OR-MARKERS) */)
2766 (size_t nargs
, Lisp_Object
*args
)
2768 return arith_driver (Alogior
, nargs
, args
);
2771 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2772 doc
: /* Return bitwise-exclusive-or of all the arguments.
2773 Arguments may be integers, or markers converted to integers.
2774 usage: (logxor &rest INTS-OR-MARKERS) */)
2775 (size_t nargs
, Lisp_Object
*args
)
2777 return arith_driver (Alogxor
, nargs
, args
);
2780 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2781 doc
: /* Return VALUE with its bits shifted left by COUNT.
2782 If COUNT is negative, shifting is actually to the right.
2783 In this case, the sign bit is duplicated. */)
2784 (register Lisp_Object value
, Lisp_Object count
)
2786 register Lisp_Object val
;
2788 CHECK_NUMBER (value
);
2789 CHECK_NUMBER (count
);
2791 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2793 else if (XINT (count
) > 0)
2794 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2795 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2796 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2798 XSETINT (val
, XINT (value
) >> -XINT (count
));
2802 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2803 doc
: /* Return VALUE with its bits shifted left by COUNT.
2804 If COUNT is negative, shifting is actually to the right.
2805 In this case, zeros are shifted in on the left. */)
2806 (register Lisp_Object value
, Lisp_Object count
)
2808 register Lisp_Object val
;
2810 CHECK_NUMBER (value
);
2811 CHECK_NUMBER (count
);
2813 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2815 else if (XINT (count
) > 0)
2816 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2817 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2820 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2824 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2825 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2826 Markers are converted to integers. */)
2827 (register Lisp_Object number
)
2829 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2831 if (FLOATP (number
))
2832 return (make_float (1.0 + XFLOAT_DATA (number
)));
2834 XSETINT (number
, XINT (number
) + 1);
2838 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2839 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2840 Markers are converted to integers. */)
2841 (register Lisp_Object number
)
2843 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2845 if (FLOATP (number
))
2846 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2848 XSETINT (number
, XINT (number
) - 1);
2852 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2853 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2854 (register Lisp_Object number
)
2856 CHECK_NUMBER (number
);
2857 XSETINT (number
, ~XINT (number
));
2861 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2862 doc
: /* Return the byteorder for the machine.
2863 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2864 lowercase l) for small endian machines. */)
2867 unsigned i
= 0x04030201;
2868 int order
= *(char *)&i
== 1 ? 108 : 66;
2870 return make_number (order
);
2878 Lisp_Object error_tail
, arith_tail
;
2880 Qquote
= intern_c_string ("quote");
2881 Qlambda
= intern_c_string ("lambda");
2882 Qsubr
= intern_c_string ("subr");
2883 Qerror_conditions
= intern_c_string ("error-conditions");
2884 Qerror_message
= intern_c_string ("error-message");
2885 Qtop_level
= intern_c_string ("top-level");
2887 Qerror
= intern_c_string ("error");
2888 Qquit
= intern_c_string ("quit");
2889 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2890 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2891 Qvoid_function
= intern_c_string ("void-function");
2892 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2893 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2894 Qvoid_variable
= intern_c_string ("void-variable");
2895 Qsetting_constant
= intern_c_string ("setting-constant");
2896 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2898 Qinvalid_function
= intern_c_string ("invalid-function");
2899 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2900 Qno_catch
= intern_c_string ("no-catch");
2901 Qend_of_file
= intern_c_string ("end-of-file");
2902 Qarith_error
= intern_c_string ("arith-error");
2903 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2904 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2905 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2906 Qtext_read_only
= intern_c_string ("text-read-only");
2907 Qmark_inactive
= intern_c_string ("mark-inactive");
2909 Qlistp
= intern_c_string ("listp");
2910 Qconsp
= intern_c_string ("consp");
2911 Qsymbolp
= intern_c_string ("symbolp");
2912 Qkeywordp
= intern_c_string ("keywordp");
2913 Qintegerp
= intern_c_string ("integerp");
2914 Qnatnump
= intern_c_string ("natnump");
2915 Qwholenump
= intern_c_string ("wholenump");
2916 Qstringp
= intern_c_string ("stringp");
2917 Qarrayp
= intern_c_string ("arrayp");
2918 Qsequencep
= intern_c_string ("sequencep");
2919 Qbufferp
= intern_c_string ("bufferp");
2920 Qvectorp
= intern_c_string ("vectorp");
2921 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2922 Qmarkerp
= intern_c_string ("markerp");
2923 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2924 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2925 Qboundp
= intern_c_string ("boundp");
2926 Qfboundp
= intern_c_string ("fboundp");
2928 Qfloatp
= intern_c_string ("floatp");
2929 Qnumberp
= intern_c_string ("numberp");
2930 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2932 Qchar_table_p
= intern_c_string ("char-table-p");
2933 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2935 Qsubrp
= intern_c_string ("subrp");
2936 Qunevalled
= intern_c_string ("unevalled");
2937 Qmany
= intern_c_string ("many");
2939 Qcdr
= intern_c_string ("cdr");
2941 /* Handle automatic advice activation */
2942 Qad_advice_info
= intern_c_string ("ad-advice-info");
2943 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2945 error_tail
= pure_cons (Qerror
, Qnil
);
2947 /* ERROR is used as a signaler for random errors for which nothing else is right */
2949 Fput (Qerror
, Qerror_conditions
,
2951 Fput (Qerror
, Qerror_message
,
2952 make_pure_c_string ("error"));
2954 Fput (Qquit
, Qerror_conditions
,
2955 pure_cons (Qquit
, Qnil
));
2956 Fput (Qquit
, Qerror_message
,
2957 make_pure_c_string ("Quit"));
2959 Fput (Qwrong_type_argument
, Qerror_conditions
,
2960 pure_cons (Qwrong_type_argument
, error_tail
));
2961 Fput (Qwrong_type_argument
, Qerror_message
,
2962 make_pure_c_string ("Wrong type argument"));
2964 Fput (Qargs_out_of_range
, Qerror_conditions
,
2965 pure_cons (Qargs_out_of_range
, error_tail
));
2966 Fput (Qargs_out_of_range
, Qerror_message
,
2967 make_pure_c_string ("Args out of range"));
2969 Fput (Qvoid_function
, Qerror_conditions
,
2970 pure_cons (Qvoid_function
, error_tail
));
2971 Fput (Qvoid_function
, Qerror_message
,
2972 make_pure_c_string ("Symbol's function definition is void"));
2974 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2975 pure_cons (Qcyclic_function_indirection
, error_tail
));
2976 Fput (Qcyclic_function_indirection
, Qerror_message
,
2977 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2979 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2980 pure_cons (Qcyclic_variable_indirection
, error_tail
));
2981 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2982 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
2984 Qcircular_list
= intern_c_string ("circular-list");
2985 staticpro (&Qcircular_list
);
2986 Fput (Qcircular_list
, Qerror_conditions
,
2987 pure_cons (Qcircular_list
, error_tail
));
2988 Fput (Qcircular_list
, Qerror_message
,
2989 make_pure_c_string ("List contains a loop"));
2991 Fput (Qvoid_variable
, Qerror_conditions
,
2992 pure_cons (Qvoid_variable
, error_tail
));
2993 Fput (Qvoid_variable
, Qerror_message
,
2994 make_pure_c_string ("Symbol's value as variable is void"));
2996 Fput (Qsetting_constant
, Qerror_conditions
,
2997 pure_cons (Qsetting_constant
, error_tail
));
2998 Fput (Qsetting_constant
, Qerror_message
,
2999 make_pure_c_string ("Attempt to set a constant symbol"));
3001 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3002 pure_cons (Qinvalid_read_syntax
, error_tail
));
3003 Fput (Qinvalid_read_syntax
, Qerror_message
,
3004 make_pure_c_string ("Invalid read syntax"));
3006 Fput (Qinvalid_function
, Qerror_conditions
,
3007 pure_cons (Qinvalid_function
, error_tail
));
3008 Fput (Qinvalid_function
, Qerror_message
,
3009 make_pure_c_string ("Invalid function"));
3011 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3012 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3013 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3014 make_pure_c_string ("Wrong number of arguments"));
3016 Fput (Qno_catch
, Qerror_conditions
,
3017 pure_cons (Qno_catch
, error_tail
));
3018 Fput (Qno_catch
, Qerror_message
,
3019 make_pure_c_string ("No catch for tag"));
3021 Fput (Qend_of_file
, Qerror_conditions
,
3022 pure_cons (Qend_of_file
, error_tail
));
3023 Fput (Qend_of_file
, Qerror_message
,
3024 make_pure_c_string ("End of file during parsing"));
3026 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3027 Fput (Qarith_error
, Qerror_conditions
,
3029 Fput (Qarith_error
, Qerror_message
,
3030 make_pure_c_string ("Arithmetic error"));
3032 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3033 pure_cons (Qbeginning_of_buffer
, error_tail
));
3034 Fput (Qbeginning_of_buffer
, Qerror_message
,
3035 make_pure_c_string ("Beginning of buffer"));
3037 Fput (Qend_of_buffer
, Qerror_conditions
,
3038 pure_cons (Qend_of_buffer
, error_tail
));
3039 Fput (Qend_of_buffer
, Qerror_message
,
3040 make_pure_c_string ("End of buffer"));
3042 Fput (Qbuffer_read_only
, Qerror_conditions
,
3043 pure_cons (Qbuffer_read_only
, error_tail
));
3044 Fput (Qbuffer_read_only
, Qerror_message
,
3045 make_pure_c_string ("Buffer is read-only"));
3047 Fput (Qtext_read_only
, Qerror_conditions
,
3048 pure_cons (Qtext_read_only
, error_tail
));
3049 Fput (Qtext_read_only
, Qerror_message
,
3050 make_pure_c_string ("Text is read-only"));
3052 Qrange_error
= intern_c_string ("range-error");
3053 Qdomain_error
= intern_c_string ("domain-error");
3054 Qsingularity_error
= intern_c_string ("singularity-error");
3055 Qoverflow_error
= intern_c_string ("overflow-error");
3056 Qunderflow_error
= intern_c_string ("underflow-error");
3058 Fput (Qdomain_error
, Qerror_conditions
,
3059 pure_cons (Qdomain_error
, arith_tail
));
3060 Fput (Qdomain_error
, Qerror_message
,
3061 make_pure_c_string ("Arithmetic domain error"));
3063 Fput (Qrange_error
, Qerror_conditions
,
3064 pure_cons (Qrange_error
, arith_tail
));
3065 Fput (Qrange_error
, Qerror_message
,
3066 make_pure_c_string ("Arithmetic range error"));
3068 Fput (Qsingularity_error
, Qerror_conditions
,
3069 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3070 Fput (Qsingularity_error
, Qerror_message
,
3071 make_pure_c_string ("Arithmetic singularity error"));
3073 Fput (Qoverflow_error
, Qerror_conditions
,
3074 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3075 Fput (Qoverflow_error
, Qerror_message
,
3076 make_pure_c_string ("Arithmetic overflow error"));
3078 Fput (Qunderflow_error
, Qerror_conditions
,
3079 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3080 Fput (Qunderflow_error
, Qerror_message
,
3081 make_pure_c_string ("Arithmetic underflow error"));
3083 staticpro (&Qrange_error
);
3084 staticpro (&Qdomain_error
);
3085 staticpro (&Qsingularity_error
);
3086 staticpro (&Qoverflow_error
);
3087 staticpro (&Qunderflow_error
);
3091 staticpro (&Qquote
);
3092 staticpro (&Qlambda
);
3094 staticpro (&Qunbound
);
3095 staticpro (&Qerror_conditions
);
3096 staticpro (&Qerror_message
);
3097 staticpro (&Qtop_level
);
3099 staticpro (&Qerror
);
3101 staticpro (&Qwrong_type_argument
);
3102 staticpro (&Qargs_out_of_range
);
3103 staticpro (&Qvoid_function
);
3104 staticpro (&Qcyclic_function_indirection
);
3105 staticpro (&Qcyclic_variable_indirection
);
3106 staticpro (&Qvoid_variable
);
3107 staticpro (&Qsetting_constant
);
3108 staticpro (&Qinvalid_read_syntax
);
3109 staticpro (&Qwrong_number_of_arguments
);
3110 staticpro (&Qinvalid_function
);
3111 staticpro (&Qno_catch
);
3112 staticpro (&Qend_of_file
);
3113 staticpro (&Qarith_error
);
3114 staticpro (&Qbeginning_of_buffer
);
3115 staticpro (&Qend_of_buffer
);
3116 staticpro (&Qbuffer_read_only
);
3117 staticpro (&Qtext_read_only
);
3118 staticpro (&Qmark_inactive
);
3120 staticpro (&Qlistp
);
3121 staticpro (&Qconsp
);
3122 staticpro (&Qsymbolp
);
3123 staticpro (&Qkeywordp
);
3124 staticpro (&Qintegerp
);
3125 staticpro (&Qnatnump
);
3126 staticpro (&Qwholenump
);
3127 staticpro (&Qstringp
);
3128 staticpro (&Qarrayp
);
3129 staticpro (&Qsequencep
);
3130 staticpro (&Qbufferp
);
3131 staticpro (&Qvectorp
);
3132 staticpro (&Qchar_or_string_p
);
3133 staticpro (&Qmarkerp
);
3134 staticpro (&Qbuffer_or_string_p
);
3135 staticpro (&Qinteger_or_marker_p
);
3136 staticpro (&Qfloatp
);
3137 staticpro (&Qnumberp
);
3138 staticpro (&Qnumber_or_marker_p
);
3139 staticpro (&Qchar_table_p
);
3140 staticpro (&Qvector_or_char_table_p
);
3141 staticpro (&Qsubrp
);
3143 staticpro (&Qunevalled
);
3145 staticpro (&Qboundp
);
3146 staticpro (&Qfboundp
);
3148 staticpro (&Qad_advice_info
);
3149 staticpro (&Qad_activate_internal
);
3151 /* Types that type-of returns. */
3152 Qinteger
= intern_c_string ("integer");
3153 Qsymbol
= intern_c_string ("symbol");
3154 Qstring
= intern_c_string ("string");
3155 Qcons
= intern_c_string ("cons");
3156 Qmarker
= intern_c_string ("marker");
3157 Qoverlay
= intern_c_string ("overlay");
3158 Qfloat
= intern_c_string ("float");
3159 Qwindow_configuration
= intern_c_string ("window-configuration");
3160 Qprocess
= intern_c_string ("process");
3161 Qwindow
= intern_c_string ("window");
3162 /* Qsubr = intern_c_string ("subr"); */
3163 Qcompiled_function
= intern_c_string ("compiled-function");
3164 Qbuffer
= intern_c_string ("buffer");
3165 Qframe
= intern_c_string ("frame");
3166 Qvector
= intern_c_string ("vector");
3167 Qchar_table
= intern_c_string ("char-table");
3168 Qbool_vector
= intern_c_string ("bool-vector");
3169 Qhash_table
= intern_c_string ("hash-table");
3171 DEFSYM (Qfont_spec
, "font-spec");
3172 DEFSYM (Qfont_entity
, "font-entity");
3173 DEFSYM (Qfont_object
, "font-object");
3175 DEFSYM (Qinteractive_form
, "interactive-form");
3177 staticpro (&Qinteger
);
3178 staticpro (&Qsymbol
);
3179 staticpro (&Qstring
);
3181 staticpro (&Qmarker
);
3182 staticpro (&Qoverlay
);
3183 staticpro (&Qfloat
);
3184 staticpro (&Qwindow_configuration
);
3185 staticpro (&Qprocess
);
3186 staticpro (&Qwindow
);
3187 /* staticpro (&Qsubr); */
3188 staticpro (&Qcompiled_function
);
3189 staticpro (&Qbuffer
);
3190 staticpro (&Qframe
);
3191 staticpro (&Qvector
);
3192 staticpro (&Qchar_table
);
3193 staticpro (&Qbool_vector
);
3194 staticpro (&Qhash_table
);
3196 defsubr (&Sindirect_variable
);
3197 defsubr (&Sinteractive_form
);
3200 defsubr (&Stype_of
);
3205 defsubr (&Sintegerp
);
3206 defsubr (&Sinteger_or_marker_p
);
3207 defsubr (&Snumberp
);
3208 defsubr (&Snumber_or_marker_p
);
3210 defsubr (&Snatnump
);
3211 defsubr (&Ssymbolp
);
3212 defsubr (&Skeywordp
);
3213 defsubr (&Sstringp
);
3214 defsubr (&Smultibyte_string_p
);
3215 defsubr (&Svectorp
);
3216 defsubr (&Schar_table_p
);
3217 defsubr (&Svector_or_char_table_p
);
3218 defsubr (&Sbool_vector_p
);
3220 defsubr (&Ssequencep
);
3221 defsubr (&Sbufferp
);
3222 defsubr (&Smarkerp
);
3224 defsubr (&Sbyte_code_function_p
);
3225 defsubr (&Schar_or_string_p
);
3228 defsubr (&Scar_safe
);
3229 defsubr (&Scdr_safe
);
3232 defsubr (&Ssymbol_function
);
3233 defsubr (&Sindirect_function
);
3234 defsubr (&Ssymbol_plist
);
3235 defsubr (&Ssymbol_name
);
3236 defsubr (&Smakunbound
);
3237 defsubr (&Sfmakunbound
);
3239 defsubr (&Sfboundp
);
3241 defsubr (&Sdefalias
);
3242 defsubr (&Ssetplist
);
3243 defsubr (&Ssymbol_value
);
3245 defsubr (&Sdefault_boundp
);
3246 defsubr (&Sdefault_value
);
3247 defsubr (&Sset_default
);
3248 defsubr (&Ssetq_default
);
3249 defsubr (&Smake_variable_buffer_local
);
3250 defsubr (&Smake_local_variable
);
3251 defsubr (&Skill_local_variable
);
3252 defsubr (&Smake_variable_frame_local
);
3253 defsubr (&Slocal_variable_p
);
3254 defsubr (&Slocal_variable_if_set_p
);
3255 defsubr (&Svariable_binding_locus
);
3256 #if 0 /* XXX Remove this. --lorentey */
3257 defsubr (&Sterminal_local_value
);
3258 defsubr (&Sset_terminal_local_value
);
3262 defsubr (&Snumber_to_string
);
3263 defsubr (&Sstring_to_number
);
3264 defsubr (&Seqlsign
);
3287 defsubr (&Sbyteorder
);
3288 defsubr (&Ssubr_arity
);
3289 defsubr (&Ssubr_name
);
3291 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3293 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3294 doc
: /* The largest value that is representable in a Lisp integer. */);
3295 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3296 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3298 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3299 doc
: /* The smallest value that is representable in a Lisp integer. */);
3300 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3301 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3305 arith_error (int signo
)
3307 sigsetmask (SIGEMPTYMASK
);
3309 SIGNAL_THREAD_CHECK (signo
);
3310 xsignal0 (Qarith_error
);
3316 /* Don't do this if just dumping out.
3317 We don't want to call `signal' in this case
3318 so that we don't have trouble with dumping
3319 signal-delivering routines in an inconsistent state. */
3323 #endif /* CANNOT_DUMP */
3324 signal (SIGFPE
, arith_error
);
3327 signal (SIGEMT
, arith_error
);