1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
53 extern double atof (const char *);
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
87 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
96 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
100 circular_list_error (Lisp_Object list
)
102 xsignal (Qcircular_list
, list
);
107 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
109 /* If VALUE is not even a valid Lisp object, we'd want to abort here
110 where we can get a backtrace showing where it came from. We used
111 to try and do that by checking the tagbits, but nowadays all
112 tagbits are potentially valid. */
113 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
116 xsignal2 (Qwrong_type_argument
, predicate
, value
);
120 pure_write_error (void)
122 error ("Attempt to modify read-only object");
126 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
128 xsignal2 (Qargs_out_of_range
, a1
, a2
);
132 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
134 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
137 /* On some machines, XINT needs a temporary location.
138 Here it is, in case it is needed. */
140 int sign_extend_temp
;
142 /* On a few machines, XINT can only be done by calling this. */
145 sign_extend_lisp_int (EMACS_INT num
)
147 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
148 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
150 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
153 /* Data type predicates */
155 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
156 doc
: /* Return t if the two args are the same Lisp object. */)
157 (Lisp_Object obj1
, Lisp_Object obj2
)
164 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
165 doc
: /* Return t if OBJECT is nil. */)
173 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
174 doc
: /* Return a symbol representing the type of OBJECT.
175 The symbol returned names the object's basic type;
176 for example, (type-of 1) returns `integer'. */)
179 switch (XTYPE (object
))
194 switch (XMISCTYPE (object
))
196 case Lisp_Misc_Marker
:
198 case Lisp_Misc_Overlay
:
200 case Lisp_Misc_Float
:
205 case Lisp_Vectorlike
:
206 if (WINDOW_CONFIGURATIONP (object
))
207 return Qwindow_configuration
;
208 if (PROCESSP (object
))
210 if (WINDOWP (object
))
214 if (COMPILEDP (object
))
215 return Qcompiled_function
;
216 if (BUFFERP (object
))
218 if (CHAR_TABLE_P (object
))
220 if (BOOL_VECTOR_P (object
))
224 if (HASH_TABLE_P (object
))
226 if (FONT_SPEC_P (object
))
228 if (FONT_ENTITY_P (object
))
230 if (FONT_OBJECT_P (object
))
242 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
243 doc
: /* Return t if OBJECT is a cons cell. */)
251 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
252 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
260 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
261 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
262 Otherwise, return nil. */)
265 if (CONSP (object
) || NILP (object
))
270 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
271 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
274 if (CONSP (object
) || NILP (object
))
279 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
280 doc
: /* Return t if OBJECT is a symbol. */)
283 if (SYMBOLP (object
))
288 /* Define this in C to avoid unnecessarily consing up the symbol
290 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
291 doc
: /* Return t if OBJECT is a keyword.
292 This means that it is a symbol with a print name beginning with `:'
293 interned in the initial obarray. */)
297 && SREF (SYMBOL_NAME (object
), 0) == ':'
298 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
303 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
304 doc
: /* Return t if OBJECT is a vector. */)
307 if (VECTORP (object
))
312 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
313 doc
: /* Return t if OBJECT is a string. */)
316 if (STRINGP (object
))
321 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
323 doc
: /* Return t if OBJECT is a multibyte string. */)
326 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
331 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
332 doc
: /* Return t if OBJECT is a char-table. */)
335 if (CHAR_TABLE_P (object
))
340 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
341 Svector_or_char_table_p
, 1, 1, 0,
342 doc
: /* Return t if OBJECT is a char-table or vector. */)
345 if (VECTORP (object
) || CHAR_TABLE_P (object
))
350 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
351 doc
: /* Return t if OBJECT is a bool-vector. */)
354 if (BOOL_VECTOR_P (object
))
359 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
360 doc
: /* Return t if OBJECT is an array (string or vector). */)
368 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
369 doc
: /* Return t if OBJECT is a sequence (list or array). */)
370 (register Lisp_Object object
)
372 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
377 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
378 doc
: /* Return t if OBJECT is an editor buffer. */)
381 if (BUFFERP (object
))
386 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
387 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
390 if (MARKERP (object
))
395 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
396 doc
: /* Return t if OBJECT is a built-in function. */)
404 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
406 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
409 if (COMPILEDP (object
))
414 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
415 doc
: /* Return t if OBJECT is a character or a string. */)
416 (register Lisp_Object object
)
418 if (CHARACTERP (object
) || STRINGP (object
))
423 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
424 doc
: /* Return t if OBJECT is an integer. */)
427 if (INTEGERP (object
))
432 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
433 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
434 (register Lisp_Object object
)
436 if (MARKERP (object
) || INTEGERP (object
))
441 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
442 doc
: /* Return t if OBJECT is a nonnegative integer. */)
445 if (NATNUMP (object
))
450 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
451 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
454 if (NUMBERP (object
))
460 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
461 Snumber_or_marker_p
, 1, 1, 0,
462 doc
: /* Return t if OBJECT is a number or a marker. */)
465 if (NUMBERP (object
) || MARKERP (object
))
470 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
471 doc
: /* Return t if OBJECT is a floating point number. */)
480 /* Extract and set components of lists */
482 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
483 doc
: /* Return the car of LIST. If arg is nil, return nil.
484 Error if arg is not nil and not a cons cell. See also `car-safe'.
486 See Info node `(elisp)Cons Cells' for a discussion of related basic
487 Lisp concepts such as car, cdr, cons cell and list. */)
488 (register Lisp_Object list
)
493 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
494 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
497 return CAR_SAFE (object
);
500 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
501 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
502 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
504 See Info node `(elisp)Cons Cells' for a discussion of related basic
505 Lisp concepts such as cdr, car, cons cell and list. */)
506 (register Lisp_Object list
)
511 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
512 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
515 return CDR_SAFE (object
);
518 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
519 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
520 (register Lisp_Object cell
, Lisp_Object newcar
)
524 XSETCAR (cell
, newcar
);
528 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
529 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
530 (register Lisp_Object cell
, Lisp_Object newcdr
)
534 XSETCDR (cell
, newcdr
);
538 /* Extract and set components of symbols */
540 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
541 doc
: /* Return t if SYMBOL's value is not void. */)
542 (register Lisp_Object symbol
)
544 Lisp_Object valcontents
;
545 struct Lisp_Symbol
*sym
;
546 CHECK_SYMBOL (symbol
);
547 sym
= XSYMBOL (symbol
);
550 switch (sym
->redirect
)
552 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
553 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
554 case SYMBOL_LOCALIZED
:
556 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
558 /* In set_internal, we un-forward vars when their value is
563 swap_in_symval_forwarding (sym
, blv
);
564 valcontents
= BLV_VALUE (blv
);
568 case SYMBOL_FORWARDED
:
569 /* In set_internal, we un-forward vars when their value is
575 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
578 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
579 doc
: /* Return t if SYMBOL's function definition is not void. */)
580 (register Lisp_Object symbol
)
582 CHECK_SYMBOL (symbol
);
583 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
586 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
587 doc
: /* Make SYMBOL's value be void.
589 (register Lisp_Object symbol
)
591 CHECK_SYMBOL (symbol
);
592 if (SYMBOL_CONSTANT_P (symbol
))
593 xsignal1 (Qsetting_constant
, symbol
);
594 Fset (symbol
, Qunbound
);
598 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
599 doc
: /* Make SYMBOL's function definition be void.
601 (register Lisp_Object symbol
)
603 CHECK_SYMBOL (symbol
);
604 if (NILP (symbol
) || EQ (symbol
, Qt
))
605 xsignal1 (Qsetting_constant
, symbol
);
606 XSYMBOL (symbol
)->function
= Qunbound
;
610 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
611 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
612 (register Lisp_Object symbol
)
614 CHECK_SYMBOL (symbol
);
615 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
616 return XSYMBOL (symbol
)->function
;
617 xsignal1 (Qvoid_function
, symbol
);
620 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
621 doc
: /* Return SYMBOL's property list. */)
622 (register Lisp_Object symbol
)
624 CHECK_SYMBOL (symbol
);
625 return XSYMBOL (symbol
)->plist
;
628 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
629 doc
: /* Return SYMBOL's name, a string. */)
630 (register Lisp_Object symbol
)
632 register Lisp_Object name
;
634 CHECK_SYMBOL (symbol
);
635 name
= SYMBOL_NAME (symbol
);
639 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
640 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
641 (register Lisp_Object symbol
, Lisp_Object definition
)
643 register Lisp_Object function
;
645 CHECK_SYMBOL (symbol
);
646 if (NILP (symbol
) || EQ (symbol
, Qt
))
647 xsignal1 (Qsetting_constant
, symbol
);
649 function
= XSYMBOL (symbol
)->function
;
651 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
652 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
654 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
655 Fput (symbol
, Qautoload
, XCDR (function
));
657 XSYMBOL (symbol
)->function
= definition
;
658 /* Handle automatic advice activation */
659 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
661 call2 (Qad_activate_internal
, symbol
, Qnil
);
662 definition
= XSYMBOL (symbol
)->function
;
667 extern Lisp_Object Qfunction_documentation
;
669 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
670 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
671 Associates the function with the current load file, if any.
672 The optional third argument DOCSTRING specifies the documentation string
673 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
674 determined by DEFINITION. */)
675 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
677 CHECK_SYMBOL (symbol
);
678 if (CONSP (XSYMBOL (symbol
)->function
)
679 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
680 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
681 definition
= Ffset (symbol
, definition
);
682 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
683 if (!NILP (docstring
))
684 Fput (symbol
, Qfunction_documentation
, docstring
);
688 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
689 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
690 (register Lisp_Object symbol
, Lisp_Object newplist
)
692 CHECK_SYMBOL (symbol
);
693 XSYMBOL (symbol
)->plist
= newplist
;
697 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
698 doc
: /* Return minimum and maximum number of args allowed for SUBR.
699 SUBR must be a built-in function.
700 The returned value is a pair (MIN . MAX). MIN is the minimum number
701 of args. MAX is the maximum number or the symbol `many', for a
702 function with `&rest' args, or `unevalled' for a special form. */)
705 short minargs
, maxargs
;
707 minargs
= XSUBR (subr
)->min_args
;
708 maxargs
= XSUBR (subr
)->max_args
;
710 return Fcons (make_number (minargs
), Qmany
);
711 else if (maxargs
== UNEVALLED
)
712 return Fcons (make_number (minargs
), Qunevalled
);
714 return Fcons (make_number (minargs
), make_number (maxargs
));
717 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
718 doc
: /* Return name of subroutine SUBR.
719 SUBR must be a built-in function. */)
724 name
= XSUBR (subr
)->symbol_name
;
725 return make_string (name
, strlen (name
));
728 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
729 doc
: /* Return the interactive form of CMD or nil if none.
730 If CMD is not a command, the return value is nil.
731 Value, if non-nil, is a list \(interactive SPEC). */)
734 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
736 if (NILP (fun
) || EQ (fun
, Qunbound
))
739 /* Use an `interactive-form' property if present, analogous to the
740 function-documentation property. */
742 while (SYMBOLP (fun
))
744 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
748 fun
= Fsymbol_function (fun
);
753 char *spec
= XSUBR (fun
)->intspec
;
755 return list2 (Qinteractive
,
756 (*spec
!= '(') ? build_string (spec
) :
757 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
759 else if (COMPILEDP (fun
))
761 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
762 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
764 else if (CONSP (fun
))
766 Lisp_Object funcar
= XCAR (fun
);
767 if (EQ (funcar
, Qlambda
))
768 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
769 else if (EQ (funcar
, Qautoload
))
773 do_autoload (fun
, cmd
);
775 return Finteractive_form (cmd
);
782 /***********************************************************************
783 Getting and Setting Values of Symbols
784 ***********************************************************************/
786 /* Return the symbol holding SYMBOL's value. Signal
787 `cyclic-variable-indirection' if SYMBOL's chain of variable
788 indirections contains a loop. */
791 indirect_variable (struct Lisp_Symbol
*symbol
)
793 struct Lisp_Symbol
*tortoise
, *hare
;
795 hare
= tortoise
= symbol
;
797 while (hare
->redirect
== SYMBOL_VARALIAS
)
799 hare
= SYMBOL_ALIAS (hare
);
800 if (hare
->redirect
!= SYMBOL_VARALIAS
)
803 hare
= SYMBOL_ALIAS (hare
);
804 tortoise
= SYMBOL_ALIAS (tortoise
);
806 if (hare
== tortoise
)
809 XSETSYMBOL (tem
, symbol
);
810 xsignal1 (Qcyclic_variable_indirection
, tem
);
818 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
819 doc
: /* Return the variable at the end of OBJECT's variable chain.
820 If OBJECT is a symbol, follow all variable indirections and return the final
821 variable. If OBJECT is not a symbol, just return it.
822 Signal a cyclic-variable-indirection error if there is a loop in the
823 variable chain of symbols. */)
826 if (SYMBOLP (object
))
827 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
832 /* Given the raw contents of a symbol value cell,
833 return the Lisp value of the symbol.
834 This does not handle buffer-local variables; use
835 swap_in_symval_forwarding for that. */
837 #define do_blv_forwarding(blv) \
838 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
841 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
843 register Lisp_Object val
;
844 switch (XFWDTYPE (valcontents
))
847 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
851 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
854 return *XOBJFWD (valcontents
)->objvar
;
856 case Lisp_Fwd_Buffer_Obj
:
857 return PER_BUFFER_VALUE (current_buffer
,
858 XBUFFER_OBJFWD (valcontents
)->offset
);
860 case Lisp_Fwd_Kboard_Obj
:
861 /* We used to simply use current_kboard here, but from Lisp
862 code, it's value is often unexpected. It seems nicer to
863 allow constructions like this to work as intuitively expected:
865 (with-selected-frame frame
866 (define-key local-function-map "\eOP" [f1]))
868 On the other hand, this affects the semantics of
869 last-command and real-last-command, and people may rely on
870 that. I took a quick look at the Lisp codebase, and I
871 don't think anything will break. --lorentey */
872 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
873 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
878 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
879 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
880 buffer-independent contents of the value cell: forwarded just one
881 step past the buffer-localness.
883 BUF non-zero means set the value in buffer BUF instead of the
884 current buffer. This only plays a role for per-buffer variables. */
886 #define store_blv_forwarding(blv, newval, buf) \
888 if ((blv)->forwarded) \
889 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
891 SET_BLV_VALUE (blv, newval); \
895 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
897 switch (XFWDTYPE (valcontents
))
900 CHECK_NUMBER (newval
);
901 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
905 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
909 *XOBJFWD (valcontents
)->objvar
= newval
;
911 /* If this variable is a default for something stored
912 in the buffer itself, such as default-fill-column,
913 find the buffers that don't have local values for it
915 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
916 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
918 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
919 - (char *) &buffer_defaults
);
920 int idx
= PER_BUFFER_IDX (offset
);
927 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
932 buf
= Fcdr (XCAR (tail
));
933 if (!BUFFERP (buf
)) continue;
936 if (! PER_BUFFER_VALUE_P (b
, idx
))
937 PER_BUFFER_VALUE (b
, offset
) = newval
;
942 case Lisp_Fwd_Buffer_Obj
:
944 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
945 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
947 if (!(NILP (type
) || NILP (newval
)
948 || (XINT (type
) == LISP_INT_TAG
950 : XTYPE (newval
) == XINT (type
))))
951 buffer_slot_type_mismatch (newval
, XINT (type
));
954 buf
= current_buffer
;
955 PER_BUFFER_VALUE (buf
, offset
) = newval
;
959 case Lisp_Fwd_Kboard_Obj
:
961 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
962 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
963 *(Lisp_Object
*) p
= newval
;
968 abort (); /* goto def; */
972 /* Set up SYMBOL to refer to its global binding.
973 This makes it safe to alter the status of other bindings. */
976 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
978 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
980 /* Unload the previously loaded binding. */
982 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
984 /* Select the global binding in the symbol. */
985 blv
->valcell
= blv
->defcell
;
987 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
989 /* Indicate that the global binding is set up now. */
991 SET_BLV_FOUND (blv
, 0);
994 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
995 VALCONTENTS is the contents of its value cell,
996 which points to a struct Lisp_Buffer_Local_Value.
998 Return the value forwarded one step past the buffer-local stage.
999 This could be another forwarding pointer. */
1002 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1004 register Lisp_Object tem1
;
1006 eassert (blv
== SYMBOL_BLV (symbol
));
1011 || (blv
->frame_local
1012 ? !EQ (selected_frame
, tem1
)
1013 : current_buffer
!= XBUFFER (tem1
)))
1016 /* Unload the previously loaded binding. */
1017 tem1
= blv
->valcell
;
1019 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1020 /* Choose the new binding. */
1023 XSETSYMBOL (var
, symbol
);
1024 if (blv
->frame_local
)
1026 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1027 blv
->where
= selected_frame
;
1031 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1032 XSETBUFFER (blv
->where
, current_buffer
);
1035 if (!(blv
->found
= !NILP (tem1
)))
1036 tem1
= blv
->defcell
;
1038 /* Load the new binding. */
1039 blv
->valcell
= tem1
;
1041 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1045 /* Find the value of a symbol, returning Qunbound if it's not bound.
1046 This is helpful for code which just wants to get a variable's value
1047 if it has one, without signaling an error.
1048 Note that it must not be possible to quit
1049 within this function. Great care is required for this. */
1052 find_symbol_value (Lisp_Object symbol
)
1054 struct Lisp_Symbol
*sym
;
1056 CHECK_SYMBOL (symbol
);
1057 sym
= XSYMBOL (symbol
);
1060 switch (sym
->redirect
)
1062 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1063 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1064 case SYMBOL_LOCALIZED
:
1066 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1067 swap_in_symval_forwarding (sym
, blv
);
1068 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1071 case SYMBOL_FORWARDED
:
1072 return do_symval_forwarding (SYMBOL_FWD (sym
));
1077 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1078 doc
: /* Return SYMBOL's value. Error if that is void. */)
1079 (Lisp_Object symbol
)
1083 val
= find_symbol_value (symbol
);
1084 if (!EQ (val
, Qunbound
))
1087 xsignal1 (Qvoid_variable
, symbol
);
1090 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1091 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1092 (register Lisp_Object symbol
, Lisp_Object newval
)
1094 set_internal (symbol
, newval
, Qnil
, 0);
1098 /* Return 1 if SYMBOL currently has a let-binding
1099 which was made in the buffer that is now current. */
1102 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1104 struct specbinding
*p
;
1106 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1108 && CONSP (p
->symbol
))
1110 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1111 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1112 if (symbol
== let_bound_symbol
1113 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1117 return p
>= specpdl
;
1121 let_shadows_global_binding_p (Lisp_Object symbol
)
1123 struct specbinding
*p
;
1125 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1126 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1129 return p
>= specpdl
;
1132 /* Store the value NEWVAL into SYMBOL.
1133 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1134 (nil stands for the current buffer/frame).
1136 If BINDFLAG is zero, then if this symbol is supposed to become
1137 local in every buffer where it is set, then we make it local.
1138 If BINDFLAG is nonzero, we don't do that. */
1141 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1143 int voide
= EQ (newval
, Qunbound
);
1144 struct Lisp_Symbol
*sym
;
1147 /* If restoring in a dead buffer, do nothing. */
1148 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1151 CHECK_SYMBOL (symbol
);
1152 if (SYMBOL_CONSTANT_P (symbol
))
1154 if (NILP (Fkeywordp (symbol
))
1155 || !EQ (newval
, Fsymbol_value (symbol
)))
1156 xsignal1 (Qsetting_constant
, symbol
);
1158 /* Allow setting keywords to their own value. */
1162 sym
= XSYMBOL (symbol
);
1165 switch (sym
->redirect
)
1167 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1168 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1169 case SYMBOL_LOCALIZED
:
1171 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1174 if (blv
->frame_local
)
1175 where
= selected_frame
;
1177 XSETBUFFER (where
, current_buffer
);
1179 /* If the current buffer is not the buffer whose binding is
1180 loaded, or if there may be frame-local bindings and the frame
1181 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1182 the default binding is loaded, the loaded binding may be the
1184 if (!EQ (blv
->where
, where
)
1185 /* Also unload a global binding (if the var is local_if_set). */
1186 || (EQ (blv
->valcell
, blv
->defcell
)))
1188 /* The currently loaded binding is not necessarily valid.
1189 We need to unload it, and choose a new binding. */
1191 /* Write out `realvalue' to the old loaded binding. */
1193 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1195 /* Find the new binding. */
1196 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1197 tem1
= Fassq (symbol
,
1199 ? XFRAME (where
)->param_alist
1200 : XBUFFER (where
)->local_var_alist
));
1206 /* This buffer still sees the default value. */
1208 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1209 or if this is `let' rather than `set',
1210 make CURRENT-ALIST-ELEMENT point to itself,
1211 indicating that we're seeing the default value.
1212 Likewise if the variable has been let-bound
1213 in the current buffer. */
1214 if (bindflag
|| !blv
->local_if_set
1215 || let_shadows_buffer_binding_p (sym
))
1218 tem1
= blv
->defcell
;
1220 /* If it's a local_if_set, being set not bound,
1221 and we're not within a let that was made for this buffer,
1222 create a new buffer-local binding for the variable.
1223 That means, give this buffer a new assoc for a local value
1224 and load that binding. */
1227 /* local_if_set is only supported for buffer-local
1228 bindings, not for frame-local bindings. */
1229 eassert (!blv
->frame_local
);
1230 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1231 XBUFFER (where
)->local_var_alist
1232 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1236 /* Record which binding is now loaded. */
1237 blv
->valcell
= tem1
;
1240 /* Store the new value in the cons cell. */
1241 SET_BLV_VALUE (blv
, newval
);
1246 /* If storing void (making the symbol void), forward only through
1247 buffer-local indicator, not through Lisp_Objfwd, etc. */
1250 store_symval_forwarding (blv
->fwd
, newval
,
1252 ? XBUFFER (where
) : current_buffer
);
1256 case SYMBOL_FORWARDED
:
1259 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1260 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1261 if (BUFFER_OBJFWDP (innercontents
))
1263 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1264 int idx
= PER_BUFFER_IDX (offset
);
1267 && !let_shadows_buffer_binding_p (sym
))
1268 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1272 { /* If storing void (making the symbol void), forward only through
1273 buffer-local indicator, not through Lisp_Objfwd, etc. */
1274 sym
->redirect
= SYMBOL_PLAINVAL
;
1275 SET_SYMBOL_VAL (sym
, newval
);
1278 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1286 /* Access or set a buffer-local symbol's default value. */
1288 /* Return the default value of SYMBOL, but don't check for voidness.
1289 Return Qunbound if it is void. */
1292 default_value (Lisp_Object symbol
)
1294 struct Lisp_Symbol
*sym
;
1296 CHECK_SYMBOL (symbol
);
1297 sym
= XSYMBOL (symbol
);
1300 switch (sym
->redirect
)
1302 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1303 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1304 case SYMBOL_LOCALIZED
:
1306 /* If var is set up for a buffer that lacks a local value for it,
1307 the current value is nominally the default value.
1308 But the `realvalue' slot may be more up to date, since
1309 ordinary setq stores just that slot. So use that. */
1310 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1311 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1312 return do_symval_forwarding (blv
->fwd
);
1314 return XCDR (blv
->defcell
);
1316 case SYMBOL_FORWARDED
:
1318 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1320 /* For a built-in buffer-local variable, get the default value
1321 rather than letting do_symval_forwarding get the current value. */
1322 if (BUFFER_OBJFWDP (valcontents
))
1324 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1325 if (PER_BUFFER_IDX (offset
) != 0)
1326 return PER_BUFFER_DEFAULT (offset
);
1329 /* For other variables, get the current value. */
1330 return do_symval_forwarding (valcontents
);
1336 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1337 doc
: /* Return t if SYMBOL has a non-void default value.
1338 This is the value that is seen in buffers that do not have their own values
1339 for this variable. */)
1340 (Lisp_Object symbol
)
1342 register Lisp_Object value
;
1344 value
= default_value (symbol
);
1345 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1348 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1349 doc
: /* Return SYMBOL's default value.
1350 This is the value that is seen in buffers that do not have their own values
1351 for this variable. The default value is meaningful for variables with
1352 local bindings in certain buffers. */)
1353 (Lisp_Object symbol
)
1355 register Lisp_Object value
;
1357 value
= default_value (symbol
);
1358 if (!EQ (value
, Qunbound
))
1361 xsignal1 (Qvoid_variable
, symbol
);
1364 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1365 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1366 The default value is seen in buffers that do not have their own values
1367 for this variable. */)
1368 (Lisp_Object symbol
, Lisp_Object value
)
1370 struct Lisp_Symbol
*sym
;
1372 CHECK_SYMBOL (symbol
);
1373 if (SYMBOL_CONSTANT_P (symbol
))
1375 if (NILP (Fkeywordp (symbol
))
1376 || !EQ (value
, Fdefault_value (symbol
)))
1377 xsignal1 (Qsetting_constant
, symbol
);
1379 /* Allow setting keywords to their own value. */
1382 sym
= XSYMBOL (symbol
);
1385 switch (sym
->redirect
)
1387 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1388 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1389 case SYMBOL_LOCALIZED
:
1391 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1393 /* Store new value into the DEFAULT-VALUE slot. */
1394 XSETCDR (blv
->defcell
, value
);
1396 /* If the default binding is now loaded, set the REALVALUE slot too. */
1397 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1398 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1401 case SYMBOL_FORWARDED
:
1403 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1405 /* Handle variables like case-fold-search that have special slots
1407 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1408 if (BUFFER_OBJFWDP (valcontents
))
1410 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1411 int idx
= PER_BUFFER_IDX (offset
);
1413 PER_BUFFER_DEFAULT (offset
) = value
;
1415 /* If this variable is not always local in all buffers,
1416 set it in the buffers that don't nominally have a local value. */
1421 for (b
= all_buffers
; b
; b
= b
->next
)
1422 if (!PER_BUFFER_VALUE_P (b
, idx
))
1423 PER_BUFFER_VALUE (b
, offset
) = value
;
1428 return Fset (symbol
, value
);
1434 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1435 doc
: /* Set the default value of variable VAR to VALUE.
1436 VAR, the variable name, is literal (not evaluated);
1437 VALUE is an expression: it is evaluated and its value returned.
1438 The default value of a variable is seen in buffers
1439 that do not have their own values for the variable.
1441 More generally, you can use multiple variables and values, as in
1442 (setq-default VAR VALUE VAR VALUE...)
1443 This sets each VAR's default value to the corresponding VALUE.
1444 The VALUE for the Nth VAR can refer to the new default values
1446 usage: (setq-default [VAR VALUE]...) */)
1449 register Lisp_Object args_left
;
1450 register Lisp_Object val
, symbol
;
1451 struct gcpro gcpro1
;
1461 val
= Feval (Fcar (Fcdr (args_left
)));
1462 symbol
= XCAR (args_left
);
1463 Fset_default (symbol
, val
);
1464 args_left
= Fcdr (XCDR (args_left
));
1466 while (!NILP (args_left
));
1472 /* Lisp functions for creating and removing buffer-local variables. */
1477 union Lisp_Fwd
*fwd
;
1480 static struct Lisp_Buffer_Local_Value
*
1481 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1483 struct Lisp_Buffer_Local_Value
*blv
1484 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1488 XSETSYMBOL (symbol
, sym
);
1489 tem
= Fcons (symbol
, (forwarded
1490 ? do_symval_forwarding (valcontents
.fwd
)
1491 : valcontents
.value
));
1493 /* Buffer_Local_Values cannot have as realval a buffer-local
1494 or keyboard-local forwarding. */
1495 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1496 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1497 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1499 blv
->frame_local
= 0;
1500 blv
->local_if_set
= 0;
1503 SET_BLV_FOUND (blv
, 0);
1507 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1508 1, 1, "vMake Variable Buffer Local: ",
1509 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1510 At any time, the value for the current buffer is in effect,
1511 unless the variable has never been set in this buffer,
1512 in which case the default value is in effect.
1513 Note that binding the variable with `let', or setting it while
1514 a `let'-style binding made in this buffer is in effect,
1515 does not make the variable buffer-local. Return VARIABLE.
1517 In most cases it is better to use `make-local-variable',
1518 which makes a variable local in just one buffer.
1520 The function `default-value' gets the default value and `set-default' sets it. */)
1521 (register Lisp_Object variable
)
1523 struct Lisp_Symbol
*sym
;
1524 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1525 union Lisp_Val_Fwd valcontents
;
1528 CHECK_SYMBOL (variable
);
1529 sym
= XSYMBOL (variable
);
1532 switch (sym
->redirect
)
1534 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1535 case SYMBOL_PLAINVAL
:
1536 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1537 if (EQ (valcontents
.value
, Qunbound
))
1538 valcontents
.value
= Qnil
;
1540 case SYMBOL_LOCALIZED
:
1541 blv
= SYMBOL_BLV (sym
);
1542 if (blv
->frame_local
)
1543 error ("Symbol %s may not be buffer-local",
1544 SDATA (SYMBOL_NAME (variable
)));
1546 case SYMBOL_FORWARDED
:
1547 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1548 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1549 error ("Symbol %s may not be buffer-local",
1550 SDATA (SYMBOL_NAME (variable
)));
1551 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1558 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1562 blv
= make_blv (sym
, forwarded
, valcontents
);
1563 sym
->redirect
= SYMBOL_LOCALIZED
;
1564 SET_SYMBOL_BLV (sym
, blv
);
1567 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1568 if (let_shadows_global_binding_p (symbol
))
1569 message ("Making %s buffer-local while let-bound!",
1570 SDATA (SYMBOL_NAME (variable
)));
1574 blv
->local_if_set
= 1;
1578 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1579 1, 1, "vMake Local Variable: ",
1580 doc
: /* Make VARIABLE have a separate value in the current buffer.
1581 Other buffers will continue to share a common default value.
1582 \(The buffer-local value of VARIABLE starts out as the same value
1583 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1586 If the variable is already arranged to become local when set,
1587 this function causes a local value to exist for this buffer,
1588 just as setting the variable would do.
1590 This function returns VARIABLE, and therefore
1591 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1594 See also `make-variable-buffer-local'.
1596 Do not use `make-local-variable' to make a hook variable buffer-local.
1597 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1598 (register Lisp_Object variable
)
1600 register Lisp_Object tem
;
1602 union Lisp_Val_Fwd valcontents
;
1603 struct Lisp_Symbol
*sym
;
1604 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1606 CHECK_SYMBOL (variable
);
1607 sym
= XSYMBOL (variable
);
1610 switch (sym
->redirect
)
1612 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1613 case SYMBOL_PLAINVAL
:
1614 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1615 case SYMBOL_LOCALIZED
:
1616 blv
= SYMBOL_BLV (sym
);
1617 if (blv
->frame_local
)
1618 error ("Symbol %s may not be buffer-local",
1619 SDATA (SYMBOL_NAME (variable
)));
1621 case SYMBOL_FORWARDED
:
1622 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1623 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1624 error ("Symbol %s may not be buffer-local",
1625 SDATA (SYMBOL_NAME (variable
)));
1631 error ("Symbol %s may not be buffer-local",
1632 SDATA (SYMBOL_NAME (variable
)));
1634 if (blv
? blv
->local_if_set
1635 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1637 tem
= Fboundp (variable
);
1638 /* Make sure the symbol has a local value in this particular buffer,
1639 by setting it to the same value it already has. */
1640 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1645 blv
= make_blv (sym
, forwarded
, valcontents
);
1646 sym
->redirect
= SYMBOL_LOCALIZED
;
1647 SET_SYMBOL_BLV (sym
, blv
);
1650 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1651 if (let_shadows_global_binding_p (symbol
))
1652 message ("Making %s local to %s while let-bound!",
1653 SDATA (SYMBOL_NAME (variable
)),
1654 SDATA (current_buffer
->name
));
1658 /* Make sure this buffer has its own value of symbol. */
1659 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1660 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1663 if (let_shadows_buffer_binding_p (sym
))
1664 message ("Making %s buffer-local while locally let-bound!",
1665 SDATA (SYMBOL_NAME (variable
)));
1667 /* Swap out any local binding for some other buffer, and make
1668 sure the current value is permanently recorded, if it's the
1670 find_symbol_value (variable
);
1672 current_buffer
->local_var_alist
1673 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1674 current_buffer
->local_var_alist
);
1676 /* Make sure symbol does not think it is set up for this buffer;
1677 force it to look once again for this buffer's value. */
1678 if (current_buffer
== XBUFFER (blv
->where
))
1680 /* blv->valcell = blv->defcell;
1681 * SET_BLV_FOUND (blv, 0); */
1685 /* If the symbol forwards into a C variable, then load the binding
1686 for this buffer now. If C code modifies the variable before we
1687 load the binding in, then that new value will clobber the default
1688 binding the next time we unload it. */
1690 swap_in_symval_forwarding (sym
, blv
);
1695 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1696 1, 1, "vKill Local Variable: ",
1697 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1698 From now on the default value will apply in this buffer. Return VARIABLE. */)
1699 (register Lisp_Object variable
)
1701 register Lisp_Object tem
;
1702 struct Lisp_Buffer_Local_Value
*blv
;
1703 struct Lisp_Symbol
*sym
;
1705 CHECK_SYMBOL (variable
);
1706 sym
= XSYMBOL (variable
);
1709 switch (sym
->redirect
)
1711 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1712 case SYMBOL_PLAINVAL
: return variable
;
1713 case SYMBOL_FORWARDED
:
1715 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1716 if (BUFFER_OBJFWDP (valcontents
))
1718 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1719 int idx
= PER_BUFFER_IDX (offset
);
1723 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1724 PER_BUFFER_VALUE (current_buffer
, offset
)
1725 = PER_BUFFER_DEFAULT (offset
);
1730 case SYMBOL_LOCALIZED
:
1731 blv
= SYMBOL_BLV (sym
);
1732 if (blv
->frame_local
)
1738 /* Get rid of this buffer's alist element, if any. */
1739 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1740 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1742 current_buffer
->local_var_alist
1743 = Fdelq (tem
, current_buffer
->local_var_alist
);
1745 /* If the symbol is set up with the current buffer's binding
1746 loaded, recompute its value. We have to do it now, or else
1747 forwarded objects won't work right. */
1749 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1750 if (EQ (buf
, blv
->where
))
1753 /* blv->valcell = blv->defcell;
1754 * SET_BLV_FOUND (blv, 0); */
1756 find_symbol_value (variable
);
1763 /* Lisp functions for creating and removing buffer-local variables. */
1765 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1766 when/if this is removed. */
1768 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1769 1, 1, "vMake Variable Frame Local: ",
1770 doc
: /* Enable VARIABLE to have frame-local bindings.
1771 This does not create any frame-local bindings for VARIABLE,
1772 it just makes them possible.
1774 A frame-local binding is actually a frame parameter value.
1775 If a frame F has a value for the frame parameter named VARIABLE,
1776 that also acts as a frame-local binding for VARIABLE in F--
1777 provided this function has been called to enable VARIABLE
1778 to have frame-local bindings at all.
1780 The only way to create a frame-local binding for VARIABLE in a frame
1781 is to set the VARIABLE frame parameter of that frame. See
1782 `modify-frame-parameters' for how to set frame parameters.
1784 Note that since Emacs 23.1, variables cannot be both buffer-local and
1785 frame-local any more (buffer-local bindings used to take precedence over
1786 frame-local bindings). */)
1787 (register Lisp_Object variable
)
1790 union Lisp_Val_Fwd valcontents
;
1791 struct Lisp_Symbol
*sym
;
1792 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1794 CHECK_SYMBOL (variable
);
1795 sym
= XSYMBOL (variable
);
1798 switch (sym
->redirect
)
1800 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1801 case SYMBOL_PLAINVAL
:
1802 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1803 if (EQ (valcontents
.value
, Qunbound
))
1804 valcontents
.value
= Qnil
;
1806 case SYMBOL_LOCALIZED
:
1807 if (SYMBOL_BLV (sym
)->frame_local
)
1810 error ("Symbol %s may not be frame-local",
1811 SDATA (SYMBOL_NAME (variable
)));
1812 case SYMBOL_FORWARDED
:
1813 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1814 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1815 error ("Symbol %s may not be frame-local",
1816 SDATA (SYMBOL_NAME (variable
)));
1822 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1824 blv
= make_blv (sym
, forwarded
, valcontents
);
1825 blv
->frame_local
= 1;
1826 sym
->redirect
= SYMBOL_LOCALIZED
;
1827 SET_SYMBOL_BLV (sym
, blv
);
1830 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1831 if (let_shadows_global_binding_p (symbol
))
1832 message ("Making %s frame-local while let-bound!",
1833 SDATA (SYMBOL_NAME (variable
)));
1838 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1840 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1841 BUFFER defaults to the current buffer. */)
1842 (register Lisp_Object variable
, Lisp_Object buffer
)
1844 register struct buffer
*buf
;
1845 struct Lisp_Symbol
*sym
;
1848 buf
= current_buffer
;
1851 CHECK_BUFFER (buffer
);
1852 buf
= XBUFFER (buffer
);
1855 CHECK_SYMBOL (variable
);
1856 sym
= XSYMBOL (variable
);
1859 switch (sym
->redirect
)
1861 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1862 case SYMBOL_PLAINVAL
: return Qnil
;
1863 case SYMBOL_LOCALIZED
:
1865 Lisp_Object tail
, elt
, tmp
;
1866 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1867 XSETBUFFER (tmp
, buf
);
1869 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1872 if (EQ (variable
, XCAR (elt
)))
1874 eassert (!blv
->frame_local
);
1875 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1879 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1882 case SYMBOL_FORWARDED
:
1884 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1885 if (BUFFER_OBJFWDP (valcontents
))
1887 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1888 int idx
= PER_BUFFER_IDX (offset
);
1889 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1898 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1900 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1901 More precisely, this means that setting the variable \(with `set' or`setq'),
1902 while it does not have a `let'-style binding that was made in BUFFER,
1903 will produce a buffer local binding. See Info node
1904 `(elisp)Creating Buffer-Local'.
1905 BUFFER defaults to the current buffer. */)
1906 (register Lisp_Object variable
, Lisp_Object buffer
)
1908 struct Lisp_Symbol
*sym
;
1910 CHECK_SYMBOL (variable
);
1911 sym
= XSYMBOL (variable
);
1914 switch (sym
->redirect
)
1916 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1917 case SYMBOL_PLAINVAL
: return Qnil
;
1918 case SYMBOL_LOCALIZED
:
1920 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1921 if (blv
->local_if_set
)
1923 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1924 return Flocal_variable_p (variable
, buffer
);
1926 case SYMBOL_FORWARDED
:
1927 /* All BUFFER_OBJFWD slots become local if they are set. */
1928 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1933 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1935 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1936 If the current binding is buffer-local, the value is the current buffer.
1937 If the current binding is frame-local, the value is the selected frame.
1938 If the current binding is global (the default), the value is nil. */)
1939 (register Lisp_Object variable
)
1941 struct Lisp_Symbol
*sym
;
1943 CHECK_SYMBOL (variable
);
1944 sym
= XSYMBOL (variable
);
1946 /* Make sure the current binding is actually swapped in. */
1947 find_symbol_value (variable
);
1950 switch (sym
->redirect
)
1952 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1953 case SYMBOL_PLAINVAL
: return Qnil
;
1954 case SYMBOL_FORWARDED
:
1956 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1957 if (KBOARD_OBJFWDP (valcontents
))
1958 return Fframe_terminal (Fselected_frame ());
1959 else if (!BUFFER_OBJFWDP (valcontents
))
1963 case SYMBOL_LOCALIZED
:
1964 /* For a local variable, record both the symbol and which
1965 buffer's or frame's value we are saving. */
1966 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1967 return Fcurrent_buffer ();
1968 else if (sym
->redirect
== SYMBOL_LOCALIZED
1969 && BLV_FOUND (SYMBOL_BLV (sym
)))
1970 return SYMBOL_BLV (sym
)->where
;
1977 /* This code is disabled now that we use the selected frame to return
1978 keyboard-local-values. */
1980 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1982 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1983 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1984 If SYMBOL is not a terminal-local variable, then return its normal
1985 value, like `symbol-value'.
1987 TERMINAL may be a terminal object, a frame, or nil (meaning the
1988 selected frame's terminal device). */)
1989 (Lisp_Object symbol
, Lisp_Object terminal
)
1992 struct terminal
*t
= get_terminal (terminal
, 1);
1993 push_kboard (t
->kboard
);
1994 result
= Fsymbol_value (symbol
);
1999 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2000 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2001 If VARIABLE is not a terminal-local variable, then set its normal
2002 binding, like `set'.
2004 TERMINAL may be a terminal object, a frame, or nil (meaning the
2005 selected frame's terminal device). */)
2006 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2009 struct terminal
*t
= get_terminal (terminal
, 1);
2010 push_kboard (d
->kboard
);
2011 result
= Fset (symbol
, value
);
2017 /* Find the function at the end of a chain of symbol function indirections. */
2019 /* If OBJECT is a symbol, find the end of its function chain and
2020 return the value found there. If OBJECT is not a symbol, just
2021 return it. If there is a cycle in the function chain, signal a
2022 cyclic-function-indirection error.
2024 This is like Findirect_function, except that it doesn't signal an
2025 error if the chain ends up unbound. */
2027 indirect_function (register Lisp_Object object
)
2029 Lisp_Object tortoise
, hare
;
2031 hare
= tortoise
= object
;
2035 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2037 hare
= XSYMBOL (hare
)->function
;
2038 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2040 hare
= XSYMBOL (hare
)->function
;
2042 tortoise
= XSYMBOL (tortoise
)->function
;
2044 if (EQ (hare
, tortoise
))
2045 xsignal1 (Qcyclic_function_indirection
, object
);
2051 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2052 doc
: /* Return the function at the end of OBJECT's function chain.
2053 If OBJECT is not a symbol, just return it. Otherwise, follow all
2054 function indirections to find the final function binding and return it.
2055 If the final symbol in the chain is unbound, signal a void-function error.
2056 Optional arg NOERROR non-nil means to return nil instead of signalling.
2057 Signal a cyclic-function-indirection error if there is a loop in the
2058 function chain of symbols. */)
2059 (register Lisp_Object object
, Lisp_Object noerror
)
2063 /* Optimize for no indirection. */
2065 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2066 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2067 result
= indirect_function (result
);
2068 if (!EQ (result
, Qunbound
))
2072 xsignal1 (Qvoid_function
, object
);
2077 /* Extract and set vector and string elements */
2079 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2080 doc
: /* Return the element of ARRAY at index IDX.
2081 ARRAY may be a vector, a string, a char-table, a bool-vector,
2082 or a byte-code object. IDX starts at 0. */)
2083 (register Lisp_Object array
, Lisp_Object idx
)
2085 register int idxval
;
2088 idxval
= XINT (idx
);
2089 if (STRINGP (array
))
2093 if (idxval
< 0 || idxval
>= SCHARS (array
))
2094 args_out_of_range (array
, idx
);
2095 if (! STRING_MULTIBYTE (array
))
2096 return make_number ((unsigned char) SREF (array
, idxval
));
2097 idxval_byte
= string_char_to_byte (array
, idxval
);
2099 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2100 return make_number (c
);
2102 else if (BOOL_VECTOR_P (array
))
2106 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2107 args_out_of_range (array
, idx
);
2109 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2110 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2112 else if (CHAR_TABLE_P (array
))
2114 CHECK_CHARACTER (idx
);
2115 return CHAR_TABLE_REF (array
, idxval
);
2120 if (VECTORP (array
))
2121 size
= XVECTOR (array
)->size
;
2122 else if (COMPILEDP (array
))
2123 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2125 wrong_type_argument (Qarrayp
, array
);
2127 if (idxval
< 0 || idxval
>= size
)
2128 args_out_of_range (array
, idx
);
2129 return XVECTOR (array
)->contents
[idxval
];
2133 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2134 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2135 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2136 bool-vector. IDX starts at 0. */)
2137 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2139 register int idxval
;
2142 idxval
= XINT (idx
);
2143 CHECK_ARRAY (array
, Qarrayp
);
2144 CHECK_IMPURE (array
);
2146 if (VECTORP (array
))
2148 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2149 args_out_of_range (array
, idx
);
2150 XVECTOR (array
)->contents
[idxval
] = newelt
;
2152 else if (BOOL_VECTOR_P (array
))
2156 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2157 args_out_of_range (array
, idx
);
2159 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2161 if (! NILP (newelt
))
2162 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2164 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2165 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2167 else if (CHAR_TABLE_P (array
))
2169 CHECK_CHARACTER (idx
);
2170 CHAR_TABLE_SET (array
, idxval
, newelt
);
2172 else if (STRING_MULTIBYTE (array
))
2174 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2175 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2177 if (idxval
< 0 || idxval
>= SCHARS (array
))
2178 args_out_of_range (array
, idx
);
2179 CHECK_CHARACTER (newelt
);
2181 nbytes
= SBYTES (array
);
2183 idxval_byte
= string_char_to_byte (array
, idxval
);
2184 p1
= SDATA (array
) + idxval_byte
;
2185 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2186 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2187 if (prev_bytes
!= new_bytes
)
2189 /* We must relocate the string data. */
2190 int nchars
= SCHARS (array
);
2194 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2195 memcpy (str
, SDATA (array
), nbytes
);
2196 allocate_string_data (XSTRING (array
), nchars
,
2197 nbytes
+ new_bytes
- prev_bytes
);
2198 memcpy (SDATA (array
), str
, idxval_byte
);
2199 p1
= SDATA (array
) + idxval_byte
;
2200 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2201 nbytes
- (idxval_byte
+ prev_bytes
));
2203 clear_string_char_byte_cache ();
2210 if (idxval
< 0 || idxval
>= SCHARS (array
))
2211 args_out_of_range (array
, idx
);
2212 CHECK_NUMBER (newelt
);
2214 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2218 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2219 if (SREF (array
, i
) >= 0x80)
2220 args_out_of_range (array
, newelt
);
2221 /* ARRAY is an ASCII string. Convert it to a multibyte
2222 string, and try `aset' again. */
2223 STRING_SET_MULTIBYTE (array
);
2224 return Faset (array
, idx
, newelt
);
2226 SSET (array
, idxval
, XINT (newelt
));
2232 /* Arithmetic functions */
2234 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2237 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2239 double f1
= 0, f2
= 0;
2242 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2243 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2245 if (FLOATP (num1
) || FLOATP (num2
))
2248 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2249 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2255 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2260 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2265 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2270 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2275 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2280 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2289 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2290 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2291 (register Lisp_Object num1
, Lisp_Object num2
)
2293 return arithcompare (num1
, num2
, equal
);
2296 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2297 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2298 (register Lisp_Object num1
, Lisp_Object num2
)
2300 return arithcompare (num1
, num2
, less
);
2303 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2304 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2305 (register Lisp_Object num1
, Lisp_Object num2
)
2307 return arithcompare (num1
, num2
, grtr
);
2310 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2311 doc
: /* Return t if first arg is less than or equal to second arg.
2312 Both must be numbers or markers. */)
2313 (register Lisp_Object num1
, Lisp_Object num2
)
2315 return arithcompare (num1
, num2
, less_or_equal
);
2318 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2319 doc
: /* Return t if first arg is greater than or equal to second arg.
2320 Both must be numbers or markers. */)
2321 (register Lisp_Object num1
, Lisp_Object num2
)
2323 return arithcompare (num1
, num2
, grtr_or_equal
);
2326 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2327 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2328 (register Lisp_Object num1
, Lisp_Object num2
)
2330 return arithcompare (num1
, num2
, notequal
);
2333 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2334 doc
: /* Return t if NUMBER is zero. */)
2335 (register Lisp_Object number
)
2337 CHECK_NUMBER_OR_FLOAT (number
);
2339 if (FLOATP (number
))
2341 if (XFLOAT_DATA (number
) == 0.0)
2351 /* Convert between long values and pairs of Lisp integers.
2352 Note that long_to_cons returns a single Lisp integer
2353 when the value fits in one. */
2356 long_to_cons (long unsigned int i
)
2358 unsigned long top
= i
>> 16;
2359 unsigned int bot
= i
& 0xFFFF;
2361 return make_number (bot
);
2362 if (top
== (unsigned long)-1 >> 16)
2363 return Fcons (make_number (-1), make_number (bot
));
2364 return Fcons (make_number (top
), make_number (bot
));
2368 cons_to_long (Lisp_Object c
)
2370 Lisp_Object top
, bot
;
2377 return ((XINT (top
) << 16) | XINT (bot
));
2380 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2381 doc
: /* Return the decimal representation of NUMBER as a string.
2382 Uses a minus sign if negative.
2383 NUMBER may be an integer or a floating point number. */)
2384 (Lisp_Object number
)
2386 char buffer
[VALBITS
];
2388 CHECK_NUMBER_OR_FLOAT (number
);
2390 if (FLOATP (number
))
2392 char pigbuf
[350]; /* see comments in float_to_string */
2394 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2395 return build_string (pigbuf
);
2398 if (sizeof (int) == sizeof (EMACS_INT
))
2399 sprintf (buffer
, "%d", (int) XINT (number
));
2400 else if (sizeof (long) == sizeof (EMACS_INT
))
2401 sprintf (buffer
, "%ld", (long) XINT (number
));
2404 return build_string (buffer
);
2408 digit_to_number (int character
, int base
)
2412 if (character
>= '0' && character
<= '9')
2413 digit
= character
- '0';
2414 else if (character
>= 'a' && character
<= 'z')
2415 digit
= character
- 'a' + 10;
2416 else if (character
>= 'A' && character
<= 'Z')
2417 digit
= character
- 'A' + 10;
2427 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2428 doc
: /* Parse STRING as a decimal number and return the number.
2429 This parses both integers and floating point numbers.
2430 It ignores leading spaces and tabs, and all trailing chars.
2432 If BASE, interpret STRING as a number in that base. If BASE isn't
2433 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2434 If the base used is not 10, STRING is always parsed as integer. */)
2435 (register Lisp_Object string
, Lisp_Object base
)
2437 register unsigned char *p
;
2442 CHECK_STRING (string
);
2448 CHECK_NUMBER (base
);
2450 if (b
< 2 || b
> 16)
2451 xsignal1 (Qargs_out_of_range
, base
);
2454 /* Skip any whitespace at the front of the number. Some versions of
2455 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2457 while (*p
== ' ' || *p
== '\t')
2468 if (isfloat_string (p
, 1) && b
== 10)
2469 val
= make_float (sign
* atof (p
));
2476 int digit
= digit_to_number (*p
++, b
);
2482 val
= make_fixnum_or_float (sign
* v
);
2502 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2503 int, Lisp_Object
*);
2504 extern Lisp_Object
fmod_float (Lisp_Object
, Lisp_Object
);
2507 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2509 register Lisp_Object val
;
2510 register int argnum
;
2511 register EMACS_INT accum
= 0;
2512 register EMACS_INT next
;
2514 switch (SWITCH_ENUM_CAST (code
))
2532 for (argnum
= 0; argnum
< nargs
; argnum
++)
2534 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2536 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2539 return float_arith_driver ((double) accum
, argnum
, code
,
2542 next
= XINT (args
[argnum
]);
2543 switch (SWITCH_ENUM_CAST (code
))
2549 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2560 xsignal0 (Qarith_error
);
2574 if (!argnum
|| next
> accum
)
2578 if (!argnum
|| next
< accum
)
2584 XSETINT (val
, accum
);
2589 #define isnan(x) ((x) != (x))
2592 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2594 register Lisp_Object val
;
2597 for (; argnum
< nargs
; argnum
++)
2599 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2600 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2604 next
= XFLOAT_DATA (val
);
2608 args
[argnum
] = val
; /* runs into a compiler bug. */
2609 next
= XINT (args
[argnum
]);
2611 switch (SWITCH_ENUM_CAST (code
))
2617 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2627 if (! IEEE_FLOATING_POINT
&& next
== 0)
2628 xsignal0 (Qarith_error
);
2635 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2637 if (!argnum
|| isnan (next
) || next
> accum
)
2641 if (!argnum
|| isnan (next
) || next
< accum
)
2647 return make_float (accum
);
2651 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2652 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2653 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2654 (int nargs
, Lisp_Object
*args
)
2656 return arith_driver (Aadd
, nargs
, args
);
2659 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2660 doc
: /* Negate number or subtract numbers or markers and return the result.
2661 With one arg, negates it. With more than one arg,
2662 subtracts all but the first from the first.
2663 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2664 (int nargs
, Lisp_Object
*args
)
2666 return arith_driver (Asub
, nargs
, args
);
2669 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2670 doc
: /* Return product of any number of arguments, which are numbers or markers.
2671 usage: (* &rest NUMBERS-OR-MARKERS) */)
2672 (int nargs
, Lisp_Object
*args
)
2674 return arith_driver (Amult
, nargs
, args
);
2677 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2678 doc
: /* Return first argument divided by all the remaining arguments.
2679 The arguments must be numbers or markers.
2680 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2681 (int nargs
, Lisp_Object
*args
)
2684 for (argnum
= 2; argnum
< nargs
; argnum
++)
2685 if (FLOATP (args
[argnum
]))
2686 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2687 return arith_driver (Adiv
, nargs
, args
);
2690 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2691 doc
: /* Return remainder of X divided by Y.
2692 Both must be integers or markers. */)
2693 (register Lisp_Object x
, Lisp_Object y
)
2697 CHECK_NUMBER_COERCE_MARKER (x
);
2698 CHECK_NUMBER_COERCE_MARKER (y
);
2700 if (XFASTINT (y
) == 0)
2701 xsignal0 (Qarith_error
);
2703 XSETINT (val
, XINT (x
) % XINT (y
));
2717 /* If the magnitude of the result exceeds that of the divisor, or
2718 the sign of the result does not agree with that of the dividend,
2719 iterate with the reduced value. This does not yield a
2720 particularly accurate result, but at least it will be in the
2721 range promised by fmod. */
2723 r
-= f2
* floor (r
/ f2
);
2724 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2728 #endif /* ! HAVE_FMOD */
2730 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2731 doc
: /* Return X modulo Y.
2732 The result falls between zero (inclusive) and Y (exclusive).
2733 Both X and Y must be numbers or markers. */)
2734 (register Lisp_Object x
, Lisp_Object y
)
2739 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2740 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2742 if (FLOATP (x
) || FLOATP (y
))
2743 return fmod_float (x
, y
);
2749 xsignal0 (Qarith_error
);
2753 /* If the "remainder" comes out with the wrong sign, fix it. */
2754 if (i2
< 0 ? i1
> 0 : i1
< 0)
2761 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2762 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2763 The value is always a number; markers are converted to numbers.
2764 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2765 (int nargs
, Lisp_Object
*args
)
2767 return arith_driver (Amax
, nargs
, args
);
2770 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2771 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2772 The value is always a number; markers are converted to numbers.
2773 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2774 (int nargs
, Lisp_Object
*args
)
2776 return arith_driver (Amin
, nargs
, args
);
2779 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2780 doc
: /* Return bitwise-and of all the arguments.
2781 Arguments may be integers, or markers converted to integers.
2782 usage: (logand &rest INTS-OR-MARKERS) */)
2783 (int nargs
, Lisp_Object
*args
)
2785 return arith_driver (Alogand
, nargs
, args
);
2788 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2789 doc
: /* Return bitwise-or of all the arguments.
2790 Arguments may be integers, or markers converted to integers.
2791 usage: (logior &rest INTS-OR-MARKERS) */)
2792 (int nargs
, Lisp_Object
*args
)
2794 return arith_driver (Alogior
, nargs
, args
);
2797 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2798 doc
: /* Return bitwise-exclusive-or of all the arguments.
2799 Arguments may be integers, or markers converted to integers.
2800 usage: (logxor &rest INTS-OR-MARKERS) */)
2801 (int nargs
, Lisp_Object
*args
)
2803 return arith_driver (Alogxor
, nargs
, args
);
2806 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2807 doc
: /* Return VALUE with its bits shifted left by COUNT.
2808 If COUNT is negative, shifting is actually to the right.
2809 In this case, the sign bit is duplicated. */)
2810 (register Lisp_Object value
, Lisp_Object count
)
2812 register Lisp_Object val
;
2814 CHECK_NUMBER (value
);
2815 CHECK_NUMBER (count
);
2817 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2819 else if (XINT (count
) > 0)
2820 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2821 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2822 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2824 XSETINT (val
, XINT (value
) >> -XINT (count
));
2828 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2829 doc
: /* Return VALUE with its bits shifted left by COUNT.
2830 If COUNT is negative, shifting is actually to the right.
2831 In this case, zeros are shifted in on the left. */)
2832 (register Lisp_Object value
, Lisp_Object count
)
2834 register Lisp_Object val
;
2836 CHECK_NUMBER (value
);
2837 CHECK_NUMBER (count
);
2839 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2841 else if (XINT (count
) > 0)
2842 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2843 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2846 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2850 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2851 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2852 Markers are converted to integers. */)
2853 (register Lisp_Object number
)
2855 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2857 if (FLOATP (number
))
2858 return (make_float (1.0 + XFLOAT_DATA (number
)));
2860 XSETINT (number
, XINT (number
) + 1);
2864 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2865 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2866 Markers are converted to integers. */)
2867 (register Lisp_Object number
)
2869 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2871 if (FLOATP (number
))
2872 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2874 XSETINT (number
, XINT (number
) - 1);
2878 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2879 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2880 (register Lisp_Object number
)
2882 CHECK_NUMBER (number
);
2883 XSETINT (number
, ~XINT (number
));
2887 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2888 doc
: /* Return the byteorder for the machine.
2889 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2890 lowercase l) for small endian machines. */)
2893 unsigned i
= 0x04030201;
2894 int order
= *(char *)&i
== 1 ? 108 : 66;
2896 return make_number (order
);
2904 Lisp_Object error_tail
, arith_tail
;
2906 Qquote
= intern_c_string ("quote");
2907 Qlambda
= intern_c_string ("lambda");
2908 Qsubr
= intern_c_string ("subr");
2909 Qerror_conditions
= intern_c_string ("error-conditions");
2910 Qerror_message
= intern_c_string ("error-message");
2911 Qtop_level
= intern_c_string ("top-level");
2913 Qerror
= intern_c_string ("error");
2914 Qquit
= intern_c_string ("quit");
2915 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2916 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2917 Qvoid_function
= intern_c_string ("void-function");
2918 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2919 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2920 Qvoid_variable
= intern_c_string ("void-variable");
2921 Qsetting_constant
= intern_c_string ("setting-constant");
2922 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2924 Qinvalid_function
= intern_c_string ("invalid-function");
2925 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2926 Qno_catch
= intern_c_string ("no-catch");
2927 Qend_of_file
= intern_c_string ("end-of-file");
2928 Qarith_error
= intern_c_string ("arith-error");
2929 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2930 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2931 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2932 Qtext_read_only
= intern_c_string ("text-read-only");
2933 Qmark_inactive
= intern_c_string ("mark-inactive");
2935 Qlistp
= intern_c_string ("listp");
2936 Qconsp
= intern_c_string ("consp");
2937 Qsymbolp
= intern_c_string ("symbolp");
2938 Qkeywordp
= intern_c_string ("keywordp");
2939 Qintegerp
= intern_c_string ("integerp");
2940 Qnatnump
= intern_c_string ("natnump");
2941 Qwholenump
= intern_c_string ("wholenump");
2942 Qstringp
= intern_c_string ("stringp");
2943 Qarrayp
= intern_c_string ("arrayp");
2944 Qsequencep
= intern_c_string ("sequencep");
2945 Qbufferp
= intern_c_string ("bufferp");
2946 Qvectorp
= intern_c_string ("vectorp");
2947 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2948 Qmarkerp
= intern_c_string ("markerp");
2949 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2950 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2951 Qboundp
= intern_c_string ("boundp");
2952 Qfboundp
= intern_c_string ("fboundp");
2954 Qfloatp
= intern_c_string ("floatp");
2955 Qnumberp
= intern_c_string ("numberp");
2956 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2958 Qchar_table_p
= intern_c_string ("char-table-p");
2959 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2961 Qsubrp
= intern_c_string ("subrp");
2962 Qunevalled
= intern_c_string ("unevalled");
2963 Qmany
= intern_c_string ("many");
2965 Qcdr
= intern_c_string ("cdr");
2967 /* Handle automatic advice activation */
2968 Qad_advice_info
= intern_c_string ("ad-advice-info");
2969 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2971 error_tail
= pure_cons (Qerror
, Qnil
);
2973 /* ERROR is used as a signaler for random errors for which nothing else is right */
2975 Fput (Qerror
, Qerror_conditions
,
2977 Fput (Qerror
, Qerror_message
,
2978 make_pure_c_string ("error"));
2980 Fput (Qquit
, Qerror_conditions
,
2981 pure_cons (Qquit
, Qnil
));
2982 Fput (Qquit
, Qerror_message
,
2983 make_pure_c_string ("Quit"));
2985 Fput (Qwrong_type_argument
, Qerror_conditions
,
2986 pure_cons (Qwrong_type_argument
, error_tail
));
2987 Fput (Qwrong_type_argument
, Qerror_message
,
2988 make_pure_c_string ("Wrong type argument"));
2990 Fput (Qargs_out_of_range
, Qerror_conditions
,
2991 pure_cons (Qargs_out_of_range
, error_tail
));
2992 Fput (Qargs_out_of_range
, Qerror_message
,
2993 make_pure_c_string ("Args out of range"));
2995 Fput (Qvoid_function
, Qerror_conditions
,
2996 pure_cons (Qvoid_function
, error_tail
));
2997 Fput (Qvoid_function
, Qerror_message
,
2998 make_pure_c_string ("Symbol's function definition is void"));
3000 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3001 pure_cons (Qcyclic_function_indirection
, error_tail
));
3002 Fput (Qcyclic_function_indirection
, Qerror_message
,
3003 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3005 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3006 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3007 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3008 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3010 Qcircular_list
= intern_c_string ("circular-list");
3011 staticpro (&Qcircular_list
);
3012 Fput (Qcircular_list
, Qerror_conditions
,
3013 pure_cons (Qcircular_list
, error_tail
));
3014 Fput (Qcircular_list
, Qerror_message
,
3015 make_pure_c_string ("List contains a loop"));
3017 Fput (Qvoid_variable
, Qerror_conditions
,
3018 pure_cons (Qvoid_variable
, error_tail
));
3019 Fput (Qvoid_variable
, Qerror_message
,
3020 make_pure_c_string ("Symbol's value as variable is void"));
3022 Fput (Qsetting_constant
, Qerror_conditions
,
3023 pure_cons (Qsetting_constant
, error_tail
));
3024 Fput (Qsetting_constant
, Qerror_message
,
3025 make_pure_c_string ("Attempt to set a constant symbol"));
3027 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3028 pure_cons (Qinvalid_read_syntax
, error_tail
));
3029 Fput (Qinvalid_read_syntax
, Qerror_message
,
3030 make_pure_c_string ("Invalid read syntax"));
3032 Fput (Qinvalid_function
, Qerror_conditions
,
3033 pure_cons (Qinvalid_function
, error_tail
));
3034 Fput (Qinvalid_function
, Qerror_message
,
3035 make_pure_c_string ("Invalid function"));
3037 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3038 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3039 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3040 make_pure_c_string ("Wrong number of arguments"));
3042 Fput (Qno_catch
, Qerror_conditions
,
3043 pure_cons (Qno_catch
, error_tail
));
3044 Fput (Qno_catch
, Qerror_message
,
3045 make_pure_c_string ("No catch for tag"));
3047 Fput (Qend_of_file
, Qerror_conditions
,
3048 pure_cons (Qend_of_file
, error_tail
));
3049 Fput (Qend_of_file
, Qerror_message
,
3050 make_pure_c_string ("End of file during parsing"));
3052 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3053 Fput (Qarith_error
, Qerror_conditions
,
3055 Fput (Qarith_error
, Qerror_message
,
3056 make_pure_c_string ("Arithmetic error"));
3058 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3059 pure_cons (Qbeginning_of_buffer
, error_tail
));
3060 Fput (Qbeginning_of_buffer
, Qerror_message
,
3061 make_pure_c_string ("Beginning of buffer"));
3063 Fput (Qend_of_buffer
, Qerror_conditions
,
3064 pure_cons (Qend_of_buffer
, error_tail
));
3065 Fput (Qend_of_buffer
, Qerror_message
,
3066 make_pure_c_string ("End of buffer"));
3068 Fput (Qbuffer_read_only
, Qerror_conditions
,
3069 pure_cons (Qbuffer_read_only
, error_tail
));
3070 Fput (Qbuffer_read_only
, Qerror_message
,
3071 make_pure_c_string ("Buffer is read-only"));
3073 Fput (Qtext_read_only
, Qerror_conditions
,
3074 pure_cons (Qtext_read_only
, error_tail
));
3075 Fput (Qtext_read_only
, Qerror_message
,
3076 make_pure_c_string ("Text is read-only"));
3078 Qrange_error
= intern_c_string ("range-error");
3079 Qdomain_error
= intern_c_string ("domain-error");
3080 Qsingularity_error
= intern_c_string ("singularity-error");
3081 Qoverflow_error
= intern_c_string ("overflow-error");
3082 Qunderflow_error
= intern_c_string ("underflow-error");
3084 Fput (Qdomain_error
, Qerror_conditions
,
3085 pure_cons (Qdomain_error
, arith_tail
));
3086 Fput (Qdomain_error
, Qerror_message
,
3087 make_pure_c_string ("Arithmetic domain error"));
3089 Fput (Qrange_error
, Qerror_conditions
,
3090 pure_cons (Qrange_error
, arith_tail
));
3091 Fput (Qrange_error
, Qerror_message
,
3092 make_pure_c_string ("Arithmetic range error"));
3094 Fput (Qsingularity_error
, Qerror_conditions
,
3095 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3096 Fput (Qsingularity_error
, Qerror_message
,
3097 make_pure_c_string ("Arithmetic singularity error"));
3099 Fput (Qoverflow_error
, Qerror_conditions
,
3100 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3101 Fput (Qoverflow_error
, Qerror_message
,
3102 make_pure_c_string ("Arithmetic overflow error"));
3104 Fput (Qunderflow_error
, Qerror_conditions
,
3105 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3106 Fput (Qunderflow_error
, Qerror_message
,
3107 make_pure_c_string ("Arithmetic underflow error"));
3109 staticpro (&Qrange_error
);
3110 staticpro (&Qdomain_error
);
3111 staticpro (&Qsingularity_error
);
3112 staticpro (&Qoverflow_error
);
3113 staticpro (&Qunderflow_error
);
3117 staticpro (&Qquote
);
3118 staticpro (&Qlambda
);
3120 staticpro (&Qunbound
);
3121 staticpro (&Qerror_conditions
);
3122 staticpro (&Qerror_message
);
3123 staticpro (&Qtop_level
);
3125 staticpro (&Qerror
);
3127 staticpro (&Qwrong_type_argument
);
3128 staticpro (&Qargs_out_of_range
);
3129 staticpro (&Qvoid_function
);
3130 staticpro (&Qcyclic_function_indirection
);
3131 staticpro (&Qcyclic_variable_indirection
);
3132 staticpro (&Qvoid_variable
);
3133 staticpro (&Qsetting_constant
);
3134 staticpro (&Qinvalid_read_syntax
);
3135 staticpro (&Qwrong_number_of_arguments
);
3136 staticpro (&Qinvalid_function
);
3137 staticpro (&Qno_catch
);
3138 staticpro (&Qend_of_file
);
3139 staticpro (&Qarith_error
);
3140 staticpro (&Qbeginning_of_buffer
);
3141 staticpro (&Qend_of_buffer
);
3142 staticpro (&Qbuffer_read_only
);
3143 staticpro (&Qtext_read_only
);
3144 staticpro (&Qmark_inactive
);
3146 staticpro (&Qlistp
);
3147 staticpro (&Qconsp
);
3148 staticpro (&Qsymbolp
);
3149 staticpro (&Qkeywordp
);
3150 staticpro (&Qintegerp
);
3151 staticpro (&Qnatnump
);
3152 staticpro (&Qwholenump
);
3153 staticpro (&Qstringp
);
3154 staticpro (&Qarrayp
);
3155 staticpro (&Qsequencep
);
3156 staticpro (&Qbufferp
);
3157 staticpro (&Qvectorp
);
3158 staticpro (&Qchar_or_string_p
);
3159 staticpro (&Qmarkerp
);
3160 staticpro (&Qbuffer_or_string_p
);
3161 staticpro (&Qinteger_or_marker_p
);
3162 staticpro (&Qfloatp
);
3163 staticpro (&Qnumberp
);
3164 staticpro (&Qnumber_or_marker_p
);
3165 staticpro (&Qchar_table_p
);
3166 staticpro (&Qvector_or_char_table_p
);
3167 staticpro (&Qsubrp
);
3169 staticpro (&Qunevalled
);
3171 staticpro (&Qboundp
);
3172 staticpro (&Qfboundp
);
3174 staticpro (&Qad_advice_info
);
3175 staticpro (&Qad_activate_internal
);
3177 /* Types that type-of returns. */
3178 Qinteger
= intern_c_string ("integer");
3179 Qsymbol
= intern_c_string ("symbol");
3180 Qstring
= intern_c_string ("string");
3181 Qcons
= intern_c_string ("cons");
3182 Qmarker
= intern_c_string ("marker");
3183 Qoverlay
= intern_c_string ("overlay");
3184 Qfloat
= intern_c_string ("float");
3185 Qwindow_configuration
= intern_c_string ("window-configuration");
3186 Qprocess
= intern_c_string ("process");
3187 Qwindow
= intern_c_string ("window");
3188 /* Qsubr = intern_c_string ("subr"); */
3189 Qcompiled_function
= intern_c_string ("compiled-function");
3190 Qbuffer
= intern_c_string ("buffer");
3191 Qframe
= intern_c_string ("frame");
3192 Qvector
= intern_c_string ("vector");
3193 Qchar_table
= intern_c_string ("char-table");
3194 Qbool_vector
= intern_c_string ("bool-vector");
3195 Qhash_table
= intern_c_string ("hash-table");
3197 DEFSYM (Qfont_spec
, "font-spec");
3198 DEFSYM (Qfont_entity
, "font-entity");
3199 DEFSYM (Qfont_object
, "font-object");
3201 DEFSYM (Qinteractive_form
, "interactive-form");
3203 staticpro (&Qinteger
);
3204 staticpro (&Qsymbol
);
3205 staticpro (&Qstring
);
3207 staticpro (&Qmarker
);
3208 staticpro (&Qoverlay
);
3209 staticpro (&Qfloat
);
3210 staticpro (&Qwindow_configuration
);
3211 staticpro (&Qprocess
);
3212 staticpro (&Qwindow
);
3213 /* staticpro (&Qsubr); */
3214 staticpro (&Qcompiled_function
);
3215 staticpro (&Qbuffer
);
3216 staticpro (&Qframe
);
3217 staticpro (&Qvector
);
3218 staticpro (&Qchar_table
);
3219 staticpro (&Qbool_vector
);
3220 staticpro (&Qhash_table
);
3222 defsubr (&Sindirect_variable
);
3223 defsubr (&Sinteractive_form
);
3226 defsubr (&Stype_of
);
3231 defsubr (&Sintegerp
);
3232 defsubr (&Sinteger_or_marker_p
);
3233 defsubr (&Snumberp
);
3234 defsubr (&Snumber_or_marker_p
);
3236 defsubr (&Snatnump
);
3237 defsubr (&Ssymbolp
);
3238 defsubr (&Skeywordp
);
3239 defsubr (&Sstringp
);
3240 defsubr (&Smultibyte_string_p
);
3241 defsubr (&Svectorp
);
3242 defsubr (&Schar_table_p
);
3243 defsubr (&Svector_or_char_table_p
);
3244 defsubr (&Sbool_vector_p
);
3246 defsubr (&Ssequencep
);
3247 defsubr (&Sbufferp
);
3248 defsubr (&Smarkerp
);
3250 defsubr (&Sbyte_code_function_p
);
3251 defsubr (&Schar_or_string_p
);
3254 defsubr (&Scar_safe
);
3255 defsubr (&Scdr_safe
);
3258 defsubr (&Ssymbol_function
);
3259 defsubr (&Sindirect_function
);
3260 defsubr (&Ssymbol_plist
);
3261 defsubr (&Ssymbol_name
);
3262 defsubr (&Smakunbound
);
3263 defsubr (&Sfmakunbound
);
3265 defsubr (&Sfboundp
);
3267 defsubr (&Sdefalias
);
3268 defsubr (&Ssetplist
);
3269 defsubr (&Ssymbol_value
);
3271 defsubr (&Sdefault_boundp
);
3272 defsubr (&Sdefault_value
);
3273 defsubr (&Sset_default
);
3274 defsubr (&Ssetq_default
);
3275 defsubr (&Smake_variable_buffer_local
);
3276 defsubr (&Smake_local_variable
);
3277 defsubr (&Skill_local_variable
);
3278 defsubr (&Smake_variable_frame_local
);
3279 defsubr (&Slocal_variable_p
);
3280 defsubr (&Slocal_variable_if_set_p
);
3281 defsubr (&Svariable_binding_locus
);
3282 #if 0 /* XXX Remove this. --lorentey */
3283 defsubr (&Sterminal_local_value
);
3284 defsubr (&Sset_terminal_local_value
);
3288 defsubr (&Snumber_to_string
);
3289 defsubr (&Sstring_to_number
);
3290 defsubr (&Seqlsign
);
3313 defsubr (&Sbyteorder
);
3314 defsubr (&Ssubr_arity
);
3315 defsubr (&Ssubr_name
);
3317 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3319 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3320 doc
: /* The largest value that is representable in a Lisp integer. */);
3321 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3322 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3324 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3325 doc
: /* The smallest value that is representable in a Lisp integer. */);
3326 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3327 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3331 arith_error (int signo
)
3333 sigsetmask (SIGEMPTYMASK
);
3335 SIGNAL_THREAD_CHECK (signo
);
3336 xsignal0 (Qarith_error
);
3342 /* Don't do this if just dumping out.
3343 We don't want to call `signal' in this case
3344 so that we don't have trouble with dumping
3345 signal-delivering routines in an inconsistent state. */
3349 #endif /* CANNOT_DUMP */
3350 signal (SIGFPE
, arith_error
);
3353 signal (SIGEMT
, arith_error
);
3357 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3358 (do not change this comment) */