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
;
86 static Lisp_Object Qfloat
, Qwindow_configuration
;
88 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
89 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
90 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
91 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
93 Lisp_Object Qinteractive_form
;
95 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
97 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
101 circular_list_error (Lisp_Object list
)
103 xsignal (Qcircular_list
, list
);
108 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
110 /* If VALUE is not even a valid Lisp object, we'd want to abort here
111 where we can get a backtrace showing where it came from. We used
112 to try and do that by checking the tagbits, but nowadays all
113 tagbits are potentially valid. */
114 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
117 xsignal2 (Qwrong_type_argument
, predicate
, value
);
121 pure_write_error (void)
123 error ("Attempt to modify read-only object");
127 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
129 xsignal2 (Qargs_out_of_range
, a1
, a2
);
133 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
135 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
138 /* On some machines, XINT needs a temporary location.
139 Here it is, in case it is needed. */
141 int sign_extend_temp
;
143 /* On a few machines, XINT can only be done by calling this. */
146 sign_extend_lisp_int (EMACS_INT num
)
148 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
149 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
151 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
154 /* Data type predicates */
156 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
157 doc
: /* Return t if the two args are the same Lisp object. */)
158 (Lisp_Object obj1
, Lisp_Object obj2
)
165 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
166 doc
: /* Return t if OBJECT is nil. */)
174 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
175 doc
: /* Return a symbol representing the type of OBJECT.
176 The symbol returned names the object's basic type;
177 for example, (type-of 1) returns `integer'. */)
180 switch (XTYPE (object
))
195 switch (XMISCTYPE (object
))
197 case Lisp_Misc_Marker
:
199 case Lisp_Misc_Overlay
:
201 case Lisp_Misc_Float
:
206 case Lisp_Vectorlike
:
207 if (WINDOW_CONFIGURATIONP (object
))
208 return Qwindow_configuration
;
209 if (PROCESSP (object
))
211 if (WINDOWP (object
))
215 if (COMPILEDP (object
))
216 return Qcompiled_function
;
217 if (BUFFERP (object
))
219 if (CHAR_TABLE_P (object
))
221 if (BOOL_VECTOR_P (object
))
225 if (HASH_TABLE_P (object
))
227 if (FONT_SPEC_P (object
))
229 if (FONT_ENTITY_P (object
))
231 if (FONT_OBJECT_P (object
))
243 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
244 doc
: /* Return t if OBJECT is a cons cell. */)
252 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
253 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
261 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
262 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
263 Otherwise, return nil. */)
266 if (CONSP (object
) || NILP (object
))
271 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
272 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
275 if (CONSP (object
) || NILP (object
))
280 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
281 doc
: /* Return t if OBJECT is a symbol. */)
284 if (SYMBOLP (object
))
289 /* Define this in C to avoid unnecessarily consing up the symbol
291 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
292 doc
: /* Return t if OBJECT is a keyword.
293 This means that it is a symbol with a print name beginning with `:'
294 interned in the initial obarray. */)
298 && SREF (SYMBOL_NAME (object
), 0) == ':'
299 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
304 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
305 doc
: /* Return t if OBJECT is a vector. */)
308 if (VECTORP (object
))
313 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
314 doc
: /* Return t if OBJECT is a string. */)
317 if (STRINGP (object
))
322 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
324 doc
: /* Return t if OBJECT is a multibyte string. */)
327 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
332 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
333 doc
: /* Return t if OBJECT is a char-table. */)
336 if (CHAR_TABLE_P (object
))
341 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
342 Svector_or_char_table_p
, 1, 1, 0,
343 doc
: /* Return t if OBJECT is a char-table or vector. */)
346 if (VECTORP (object
) || CHAR_TABLE_P (object
))
351 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a bool-vector. */)
355 if (BOOL_VECTOR_P (object
))
360 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
361 doc
: /* Return t if OBJECT is an array (string or vector). */)
369 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a sequence (list or array). */)
371 (register Lisp_Object object
)
373 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
378 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
379 doc
: /* Return t if OBJECT is an editor buffer. */)
382 if (BUFFERP (object
))
387 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
388 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
391 if (MARKERP (object
))
396 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
397 doc
: /* Return t if OBJECT is a built-in function. */)
405 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
407 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
410 if (COMPILEDP (object
))
415 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
416 doc
: /* Return t if OBJECT is a character or a string. */)
417 (register Lisp_Object object
)
419 if (CHARACTERP (object
) || STRINGP (object
))
424 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is an integer. */)
428 if (INTEGERP (object
))
433 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
434 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
435 (register Lisp_Object object
)
437 if (MARKERP (object
) || INTEGERP (object
))
442 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
443 doc
: /* Return t if OBJECT is a nonnegative integer. */)
446 if (NATNUMP (object
))
451 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
452 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
455 if (NUMBERP (object
))
461 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
462 Snumber_or_marker_p
, 1, 1, 0,
463 doc
: /* Return t if OBJECT is a number or a marker. */)
466 if (NUMBERP (object
) || MARKERP (object
))
471 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
472 doc
: /* Return t if OBJECT is a floating point number. */)
481 /* Extract and set components of lists */
483 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
484 doc
: /* Return the car of LIST. If arg is nil, return nil.
485 Error if arg is not nil and not a cons cell. See also `car-safe'.
487 See Info node `(elisp)Cons Cells' for a discussion of related basic
488 Lisp concepts such as car, cdr, cons cell and list. */)
489 (register Lisp_Object list
)
494 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
495 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
498 return CAR_SAFE (object
);
501 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
502 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
503 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
505 See Info node `(elisp)Cons Cells' for a discussion of related basic
506 Lisp concepts such as cdr, car, cons cell and list. */)
507 (register Lisp_Object list
)
512 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
513 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
516 return CDR_SAFE (object
);
519 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
520 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
521 (register Lisp_Object cell
, Lisp_Object newcar
)
525 XSETCAR (cell
, newcar
);
529 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
530 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
531 (register Lisp_Object cell
, Lisp_Object newcdr
)
535 XSETCDR (cell
, newcdr
);
539 /* Extract and set components of symbols */
541 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
542 doc
: /* Return t if SYMBOL's value is not void. */)
543 (register Lisp_Object symbol
)
545 Lisp_Object valcontents
;
546 struct Lisp_Symbol
*sym
;
547 CHECK_SYMBOL (symbol
);
548 sym
= XSYMBOL (symbol
);
551 switch (sym
->redirect
)
553 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
554 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
555 case SYMBOL_LOCALIZED
:
557 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
559 /* In set_internal, we un-forward vars when their value is
564 swap_in_symval_forwarding (sym
, blv
);
565 valcontents
= BLV_VALUE (blv
);
569 case SYMBOL_FORWARDED
:
570 /* In set_internal, we un-forward vars when their value is
576 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
579 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
580 doc
: /* Return t if SYMBOL's function definition is not void. */)
581 (register Lisp_Object symbol
)
583 CHECK_SYMBOL (symbol
);
584 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
587 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
588 doc
: /* Make SYMBOL's value be void.
590 (register Lisp_Object symbol
)
592 CHECK_SYMBOL (symbol
);
593 if (SYMBOL_CONSTANT_P (symbol
))
594 xsignal1 (Qsetting_constant
, symbol
);
595 Fset (symbol
, Qunbound
);
599 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
600 doc
: /* Make SYMBOL's function definition be void.
602 (register Lisp_Object symbol
)
604 CHECK_SYMBOL (symbol
);
605 if (NILP (symbol
) || EQ (symbol
, Qt
))
606 xsignal1 (Qsetting_constant
, symbol
);
607 XSYMBOL (symbol
)->function
= Qunbound
;
611 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
612 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
613 (register Lisp_Object symbol
)
615 CHECK_SYMBOL (symbol
);
616 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
617 return XSYMBOL (symbol
)->function
;
618 xsignal1 (Qvoid_function
, symbol
);
621 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
622 doc
: /* Return SYMBOL's property list. */)
623 (register Lisp_Object symbol
)
625 CHECK_SYMBOL (symbol
);
626 return XSYMBOL (symbol
)->plist
;
629 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
630 doc
: /* Return SYMBOL's name, a string. */)
631 (register Lisp_Object symbol
)
633 register Lisp_Object name
;
635 CHECK_SYMBOL (symbol
);
636 name
= SYMBOL_NAME (symbol
);
640 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
641 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
642 (register Lisp_Object symbol
, Lisp_Object definition
)
644 register Lisp_Object function
;
646 CHECK_SYMBOL (symbol
);
647 if (NILP (symbol
) || EQ (symbol
, Qt
))
648 xsignal1 (Qsetting_constant
, symbol
);
650 function
= XSYMBOL (symbol
)->function
;
652 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
653 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
655 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
656 Fput (symbol
, Qautoload
, XCDR (function
));
658 XSYMBOL (symbol
)->function
= definition
;
659 /* Handle automatic advice activation */
660 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
662 call2 (Qad_activate_internal
, symbol
, Qnil
);
663 definition
= XSYMBOL (symbol
)->function
;
668 extern Lisp_Object Qfunction_documentation
;
670 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
671 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
672 Associates the function with the current load file, if any.
673 The optional third argument DOCSTRING specifies the documentation string
674 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
675 determined by DEFINITION. */)
676 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
678 CHECK_SYMBOL (symbol
);
679 if (CONSP (XSYMBOL (symbol
)->function
)
680 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
681 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
682 definition
= Ffset (symbol
, definition
);
683 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
684 if (!NILP (docstring
))
685 Fput (symbol
, Qfunction_documentation
, docstring
);
689 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
690 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
691 (register Lisp_Object symbol
, Lisp_Object newplist
)
693 CHECK_SYMBOL (symbol
);
694 XSYMBOL (symbol
)->plist
= newplist
;
698 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
699 doc
: /* Return minimum and maximum number of args allowed for SUBR.
700 SUBR must be a built-in function.
701 The returned value is a pair (MIN . MAX). MIN is the minimum number
702 of args. MAX is the maximum number or the symbol `many', for a
703 function with `&rest' args, or `unevalled' for a special form. */)
706 short minargs
, maxargs
;
708 minargs
= XSUBR (subr
)->min_args
;
709 maxargs
= XSUBR (subr
)->max_args
;
711 return Fcons (make_number (minargs
), Qmany
);
712 else if (maxargs
== UNEVALLED
)
713 return Fcons (make_number (minargs
), Qunevalled
);
715 return Fcons (make_number (minargs
), make_number (maxargs
));
718 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
719 doc
: /* Return name of subroutine SUBR.
720 SUBR must be a built-in function. */)
725 name
= XSUBR (subr
)->symbol_name
;
726 return make_string (name
, strlen (name
));
729 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
730 doc
: /* Return the interactive form of CMD or nil if none.
731 If CMD is not a command, the return value is nil.
732 Value, if non-nil, is a list \(interactive SPEC). */)
735 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
737 if (NILP (fun
) || EQ (fun
, Qunbound
))
740 /* Use an `interactive-form' property if present, analogous to the
741 function-documentation property. */
743 while (SYMBOLP (fun
))
745 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
749 fun
= Fsymbol_function (fun
);
754 const char *spec
= XSUBR (fun
)->intspec
;
756 return list2 (Qinteractive
,
757 (*spec
!= '(') ? build_string (spec
) :
758 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
760 else if (COMPILEDP (fun
))
762 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
763 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
765 else if (CONSP (fun
))
767 Lisp_Object funcar
= XCAR (fun
);
768 if (EQ (funcar
, Qlambda
))
769 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
770 else if (EQ (funcar
, Qautoload
))
774 do_autoload (fun
, cmd
);
776 return Finteractive_form (cmd
);
783 /***********************************************************************
784 Getting and Setting Values of Symbols
785 ***********************************************************************/
787 /* Return the symbol holding SYMBOL's value. Signal
788 `cyclic-variable-indirection' if SYMBOL's chain of variable
789 indirections contains a loop. */
792 indirect_variable (struct Lisp_Symbol
*symbol
)
794 struct Lisp_Symbol
*tortoise
, *hare
;
796 hare
= tortoise
= symbol
;
798 while (hare
->redirect
== SYMBOL_VARALIAS
)
800 hare
= SYMBOL_ALIAS (hare
);
801 if (hare
->redirect
!= SYMBOL_VARALIAS
)
804 hare
= SYMBOL_ALIAS (hare
);
805 tortoise
= SYMBOL_ALIAS (tortoise
);
807 if (hare
== tortoise
)
810 XSETSYMBOL (tem
, symbol
);
811 xsignal1 (Qcyclic_variable_indirection
, tem
);
819 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
820 doc
: /* Return the variable at the end of OBJECT's variable chain.
821 If OBJECT is a symbol, follow all variable indirections and return the final
822 variable. If OBJECT is not a symbol, just return it.
823 Signal a cyclic-variable-indirection error if there is a loop in the
824 variable chain of symbols. */)
827 if (SYMBOLP (object
))
828 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
833 /* Given the raw contents of a symbol value cell,
834 return the Lisp value of the symbol.
835 This does not handle buffer-local variables; use
836 swap_in_symval_forwarding for that. */
838 #define do_blv_forwarding(blv) \
839 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
842 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
844 register Lisp_Object val
;
845 switch (XFWDTYPE (valcontents
))
848 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
852 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
855 return *XOBJFWD (valcontents
)->objvar
;
857 case Lisp_Fwd_Buffer_Obj
:
858 return PER_BUFFER_VALUE (current_buffer
,
859 XBUFFER_OBJFWD (valcontents
)->offset
);
861 case Lisp_Fwd_Kboard_Obj
:
862 /* We used to simply use current_kboard here, but from Lisp
863 code, it's value is often unexpected. It seems nicer to
864 allow constructions like this to work as intuitively expected:
866 (with-selected-frame frame
867 (define-key local-function-map "\eOP" [f1]))
869 On the other hand, this affects the semantics of
870 last-command and real-last-command, and people may rely on
871 that. I took a quick look at the Lisp codebase, and I
872 don't think anything will break. --lorentey */
873 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
874 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
879 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
880 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
881 buffer-independent contents of the value cell: forwarded just one
882 step past the buffer-localness.
884 BUF non-zero means set the value in buffer BUF instead of the
885 current buffer. This only plays a role for per-buffer variables. */
887 #define store_blv_forwarding(blv, newval, buf) \
889 if ((blv)->forwarded) \
890 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
892 SET_BLV_VALUE (blv, newval); \
896 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
898 switch (XFWDTYPE (valcontents
))
901 CHECK_NUMBER (newval
);
902 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
906 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
910 *XOBJFWD (valcontents
)->objvar
= newval
;
912 /* If this variable is a default for something stored
913 in the buffer itself, such as default-fill-column,
914 find the buffers that don't have local values for it
916 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
917 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
919 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
920 - (char *) &buffer_defaults
);
921 int idx
= PER_BUFFER_IDX (offset
);
928 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
933 buf
= Fcdr (XCAR (tail
));
934 if (!BUFFERP (buf
)) continue;
937 if (! PER_BUFFER_VALUE_P (b
, idx
))
938 PER_BUFFER_VALUE (b
, offset
) = newval
;
943 case Lisp_Fwd_Buffer_Obj
:
945 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
946 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
948 if (!(NILP (type
) || NILP (newval
)
949 || (XINT (type
) == LISP_INT_TAG
951 : XTYPE (newval
) == XINT (type
))))
952 buffer_slot_type_mismatch (newval
, XINT (type
));
955 buf
= current_buffer
;
956 PER_BUFFER_VALUE (buf
, offset
) = newval
;
960 case Lisp_Fwd_Kboard_Obj
:
962 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
963 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
964 *(Lisp_Object
*) p
= newval
;
969 abort (); /* goto def; */
973 /* Set up SYMBOL to refer to its global binding.
974 This makes it safe to alter the status of other bindings. */
977 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
979 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
981 /* Unload the previously loaded binding. */
983 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
985 /* Select the global binding in the symbol. */
986 blv
->valcell
= blv
->defcell
;
988 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
990 /* Indicate that the global binding is set up now. */
992 SET_BLV_FOUND (blv
, 0);
995 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
996 VALCONTENTS is the contents of its value cell,
997 which points to a struct Lisp_Buffer_Local_Value.
999 Return the value forwarded one step past the buffer-local stage.
1000 This could be another forwarding pointer. */
1003 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1005 register Lisp_Object tem1
;
1007 eassert (blv
== SYMBOL_BLV (symbol
));
1012 || (blv
->frame_local
1013 ? !EQ (selected_frame
, tem1
)
1014 : current_buffer
!= XBUFFER (tem1
)))
1017 /* Unload the previously loaded binding. */
1018 tem1
= blv
->valcell
;
1020 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1021 /* Choose the new binding. */
1024 XSETSYMBOL (var
, symbol
);
1025 if (blv
->frame_local
)
1027 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1028 blv
->where
= selected_frame
;
1032 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1033 XSETBUFFER (blv
->where
, current_buffer
);
1036 if (!(blv
->found
= !NILP (tem1
)))
1037 tem1
= blv
->defcell
;
1039 /* Load the new binding. */
1040 blv
->valcell
= tem1
;
1042 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1046 /* Find the value of a symbol, returning Qunbound if it's not bound.
1047 This is helpful for code which just wants to get a variable's value
1048 if it has one, without signaling an error.
1049 Note that it must not be possible to quit
1050 within this function. Great care is required for this. */
1053 find_symbol_value (Lisp_Object symbol
)
1055 struct Lisp_Symbol
*sym
;
1057 CHECK_SYMBOL (symbol
);
1058 sym
= XSYMBOL (symbol
);
1061 switch (sym
->redirect
)
1063 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1064 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1065 case SYMBOL_LOCALIZED
:
1067 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1068 swap_in_symval_forwarding (sym
, blv
);
1069 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1072 case SYMBOL_FORWARDED
:
1073 return do_symval_forwarding (SYMBOL_FWD (sym
));
1078 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1079 doc
: /* Return SYMBOL's value. Error if that is void. */)
1080 (Lisp_Object symbol
)
1084 val
= find_symbol_value (symbol
);
1085 if (!EQ (val
, Qunbound
))
1088 xsignal1 (Qvoid_variable
, symbol
);
1091 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1092 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1093 (register Lisp_Object symbol
, Lisp_Object newval
)
1095 set_internal (symbol
, newval
, Qnil
, 0);
1099 /* Return 1 if SYMBOL currently has a let-binding
1100 which was made in the buffer that is now current. */
1103 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1105 struct specbinding
*p
;
1107 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1109 && CONSP (p
->symbol
))
1111 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1112 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1113 if (symbol
== let_bound_symbol
1114 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1118 return p
>= specpdl
;
1122 let_shadows_global_binding_p (Lisp_Object symbol
)
1124 struct specbinding
*p
;
1126 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1127 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1130 return p
>= specpdl
;
1133 /* Store the value NEWVAL into SYMBOL.
1134 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1135 (nil stands for the current buffer/frame).
1137 If BINDFLAG is zero, then if this symbol is supposed to become
1138 local in every buffer where it is set, then we make it local.
1139 If BINDFLAG is nonzero, we don't do that. */
1142 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1144 int voide
= EQ (newval
, Qunbound
);
1145 struct Lisp_Symbol
*sym
;
1148 /* If restoring in a dead buffer, do nothing. */
1149 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1152 CHECK_SYMBOL (symbol
);
1153 if (SYMBOL_CONSTANT_P (symbol
))
1155 if (NILP (Fkeywordp (symbol
))
1156 || !EQ (newval
, Fsymbol_value (symbol
)))
1157 xsignal1 (Qsetting_constant
, symbol
);
1159 /* Allow setting keywords to their own value. */
1163 sym
= XSYMBOL (symbol
);
1166 switch (sym
->redirect
)
1168 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1169 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1170 case SYMBOL_LOCALIZED
:
1172 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1175 if (blv
->frame_local
)
1176 where
= selected_frame
;
1178 XSETBUFFER (where
, current_buffer
);
1180 /* If the current buffer is not the buffer whose binding is
1181 loaded, or if there may be frame-local bindings and the frame
1182 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1183 the default binding is loaded, the loaded binding may be the
1185 if (!EQ (blv
->where
, where
)
1186 /* Also unload a global binding (if the var is local_if_set). */
1187 || (EQ (blv
->valcell
, blv
->defcell
)))
1189 /* The currently loaded binding is not necessarily valid.
1190 We need to unload it, and choose a new binding. */
1192 /* Write out `realvalue' to the old loaded binding. */
1194 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1196 /* Find the new binding. */
1197 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1198 tem1
= Fassq (symbol
,
1200 ? XFRAME (where
)->param_alist
1201 : XBUFFER (where
)->local_var_alist
));
1207 /* This buffer still sees the default value. */
1209 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1210 or if this is `let' rather than `set',
1211 make CURRENT-ALIST-ELEMENT point to itself,
1212 indicating that we're seeing the default value.
1213 Likewise if the variable has been let-bound
1214 in the current buffer. */
1215 if (bindflag
|| !blv
->local_if_set
1216 || let_shadows_buffer_binding_p (sym
))
1219 tem1
= blv
->defcell
;
1221 /* If it's a local_if_set, being set not bound,
1222 and we're not within a let that was made for this buffer,
1223 create a new buffer-local binding for the variable.
1224 That means, give this buffer a new assoc for a local value
1225 and load that binding. */
1228 /* local_if_set is only supported for buffer-local
1229 bindings, not for frame-local bindings. */
1230 eassert (!blv
->frame_local
);
1231 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1232 XBUFFER (where
)->local_var_alist
1233 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1237 /* Record which binding is now loaded. */
1238 blv
->valcell
= tem1
;
1241 /* Store the new value in the cons cell. */
1242 SET_BLV_VALUE (blv
, newval
);
1247 /* If storing void (making the symbol void), forward only through
1248 buffer-local indicator, not through Lisp_Objfwd, etc. */
1251 store_symval_forwarding (blv
->fwd
, newval
,
1253 ? XBUFFER (where
) : current_buffer
);
1257 case SYMBOL_FORWARDED
:
1260 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1261 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1262 if (BUFFER_OBJFWDP (innercontents
))
1264 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1265 int idx
= PER_BUFFER_IDX (offset
);
1268 && !let_shadows_buffer_binding_p (sym
))
1269 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1273 { /* If storing void (making the symbol void), forward only through
1274 buffer-local indicator, not through Lisp_Objfwd, etc. */
1275 sym
->redirect
= SYMBOL_PLAINVAL
;
1276 SET_SYMBOL_VAL (sym
, newval
);
1279 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1287 /* Access or set a buffer-local symbol's default value. */
1289 /* Return the default value of SYMBOL, but don't check for voidness.
1290 Return Qunbound if it is void. */
1293 default_value (Lisp_Object symbol
)
1295 struct Lisp_Symbol
*sym
;
1297 CHECK_SYMBOL (symbol
);
1298 sym
= XSYMBOL (symbol
);
1301 switch (sym
->redirect
)
1303 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1304 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1305 case SYMBOL_LOCALIZED
:
1307 /* If var is set up for a buffer that lacks a local value for it,
1308 the current value is nominally the default value.
1309 But the `realvalue' slot may be more up to date, since
1310 ordinary setq stores just that slot. So use that. */
1311 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1312 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1313 return do_symval_forwarding (blv
->fwd
);
1315 return XCDR (blv
->defcell
);
1317 case SYMBOL_FORWARDED
:
1319 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1321 /* For a built-in buffer-local variable, get the default value
1322 rather than letting do_symval_forwarding get the current value. */
1323 if (BUFFER_OBJFWDP (valcontents
))
1325 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1326 if (PER_BUFFER_IDX (offset
) != 0)
1327 return PER_BUFFER_DEFAULT (offset
);
1330 /* For other variables, get the current value. */
1331 return do_symval_forwarding (valcontents
);
1337 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1338 doc
: /* Return t if SYMBOL has a non-void default value.
1339 This is the value that is seen in buffers that do not have their own values
1340 for this variable. */)
1341 (Lisp_Object symbol
)
1343 register Lisp_Object value
;
1345 value
= default_value (symbol
);
1346 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1349 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1350 doc
: /* Return SYMBOL's default value.
1351 This is the value that is seen in buffers that do not have their own values
1352 for this variable. The default value is meaningful for variables with
1353 local bindings in certain buffers. */)
1354 (Lisp_Object symbol
)
1356 register Lisp_Object value
;
1358 value
= default_value (symbol
);
1359 if (!EQ (value
, Qunbound
))
1362 xsignal1 (Qvoid_variable
, symbol
);
1365 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1366 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1367 The default value is seen in buffers that do not have their own values
1368 for this variable. */)
1369 (Lisp_Object symbol
, Lisp_Object value
)
1371 struct Lisp_Symbol
*sym
;
1373 CHECK_SYMBOL (symbol
);
1374 if (SYMBOL_CONSTANT_P (symbol
))
1376 if (NILP (Fkeywordp (symbol
))
1377 || !EQ (value
, Fdefault_value (symbol
)))
1378 xsignal1 (Qsetting_constant
, symbol
);
1380 /* Allow setting keywords to their own value. */
1383 sym
= XSYMBOL (symbol
);
1386 switch (sym
->redirect
)
1388 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1389 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1390 case SYMBOL_LOCALIZED
:
1392 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1394 /* Store new value into the DEFAULT-VALUE slot. */
1395 XSETCDR (blv
->defcell
, value
);
1397 /* If the default binding is now loaded, set the REALVALUE slot too. */
1398 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1399 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1402 case SYMBOL_FORWARDED
:
1404 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1406 /* Handle variables like case-fold-search that have special slots
1408 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1409 if (BUFFER_OBJFWDP (valcontents
))
1411 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1412 int idx
= PER_BUFFER_IDX (offset
);
1414 PER_BUFFER_DEFAULT (offset
) = value
;
1416 /* If this variable is not always local in all buffers,
1417 set it in the buffers that don't nominally have a local value. */
1422 for (b
= all_buffers
; b
; b
= b
->next
)
1423 if (!PER_BUFFER_VALUE_P (b
, idx
))
1424 PER_BUFFER_VALUE (b
, offset
) = value
;
1429 return Fset (symbol
, value
);
1435 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1436 doc
: /* Set the default value of variable VAR to VALUE.
1437 VAR, the variable name, is literal (not evaluated);
1438 VALUE is an expression: it is evaluated and its value returned.
1439 The default value of a variable is seen in buffers
1440 that do not have their own values for the variable.
1442 More generally, you can use multiple variables and values, as in
1443 (setq-default VAR VALUE VAR VALUE...)
1444 This sets each VAR's default value to the corresponding VALUE.
1445 The VALUE for the Nth VAR can refer to the new default values
1447 usage: (setq-default [VAR VALUE]...) */)
1450 register Lisp_Object args_left
;
1451 register Lisp_Object val
, symbol
;
1452 struct gcpro gcpro1
;
1462 val
= Feval (Fcar (Fcdr (args_left
)));
1463 symbol
= XCAR (args_left
);
1464 Fset_default (symbol
, val
);
1465 args_left
= Fcdr (XCDR (args_left
));
1467 while (!NILP (args_left
));
1473 /* Lisp functions for creating and removing buffer-local variables. */
1478 union Lisp_Fwd
*fwd
;
1481 static struct Lisp_Buffer_Local_Value
*
1482 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1484 struct Lisp_Buffer_Local_Value
*blv
1485 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1489 XSETSYMBOL (symbol
, sym
);
1490 tem
= Fcons (symbol
, (forwarded
1491 ? do_symval_forwarding (valcontents
.fwd
)
1492 : valcontents
.value
));
1494 /* Buffer_Local_Values cannot have as realval a buffer-local
1495 or keyboard-local forwarding. */
1496 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1497 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1498 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1500 blv
->frame_local
= 0;
1501 blv
->local_if_set
= 0;
1504 SET_BLV_FOUND (blv
, 0);
1508 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1509 1, 1, "vMake Variable Buffer Local: ",
1510 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1511 At any time, the value for the current buffer is in effect,
1512 unless the variable has never been set in this buffer,
1513 in which case the default value is in effect.
1514 Note that binding the variable with `let', or setting it while
1515 a `let'-style binding made in this buffer is in effect,
1516 does not make the variable buffer-local. Return VARIABLE.
1518 In most cases it is better to use `make-local-variable',
1519 which makes a variable local in just one buffer.
1521 The function `default-value' gets the default value and `set-default' sets it. */)
1522 (register Lisp_Object variable
)
1524 struct Lisp_Symbol
*sym
;
1525 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1526 union Lisp_Val_Fwd valcontents
;
1529 CHECK_SYMBOL (variable
);
1530 sym
= XSYMBOL (variable
);
1533 switch (sym
->redirect
)
1535 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1536 case SYMBOL_PLAINVAL
:
1537 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1538 if (EQ (valcontents
.value
, Qunbound
))
1539 valcontents
.value
= Qnil
;
1541 case SYMBOL_LOCALIZED
:
1542 blv
= SYMBOL_BLV (sym
);
1543 if (blv
->frame_local
)
1544 error ("Symbol %s may not be buffer-local",
1545 SDATA (SYMBOL_NAME (variable
)));
1547 case SYMBOL_FORWARDED
:
1548 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1549 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1550 error ("Symbol %s may not be buffer-local",
1551 SDATA (SYMBOL_NAME (variable
)));
1552 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1559 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1563 blv
= make_blv (sym
, forwarded
, valcontents
);
1564 sym
->redirect
= SYMBOL_LOCALIZED
;
1565 SET_SYMBOL_BLV (sym
, blv
);
1568 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1569 if (let_shadows_global_binding_p (symbol
))
1570 message ("Making %s buffer-local while let-bound!",
1571 SDATA (SYMBOL_NAME (variable
)));
1575 blv
->local_if_set
= 1;
1579 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1580 1, 1, "vMake Local Variable: ",
1581 doc
: /* Make VARIABLE have a separate value in the current buffer.
1582 Other buffers will continue to share a common default value.
1583 \(The buffer-local value of VARIABLE starts out as the same value
1584 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1587 If the variable is already arranged to become local when set,
1588 this function causes a local value to exist for this buffer,
1589 just as setting the variable would do.
1591 This function returns VARIABLE, and therefore
1592 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1595 See also `make-variable-buffer-local'.
1597 Do not use `make-local-variable' to make a hook variable buffer-local.
1598 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1599 (register Lisp_Object variable
)
1601 register Lisp_Object tem
;
1603 union Lisp_Val_Fwd valcontents
;
1604 struct Lisp_Symbol
*sym
;
1605 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1607 CHECK_SYMBOL (variable
);
1608 sym
= XSYMBOL (variable
);
1611 switch (sym
->redirect
)
1613 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1614 case SYMBOL_PLAINVAL
:
1615 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1616 case SYMBOL_LOCALIZED
:
1617 blv
= SYMBOL_BLV (sym
);
1618 if (blv
->frame_local
)
1619 error ("Symbol %s may not be buffer-local",
1620 SDATA (SYMBOL_NAME (variable
)));
1622 case SYMBOL_FORWARDED
:
1623 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1624 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1625 error ("Symbol %s may not be buffer-local",
1626 SDATA (SYMBOL_NAME (variable
)));
1632 error ("Symbol %s may not be buffer-local",
1633 SDATA (SYMBOL_NAME (variable
)));
1635 if (blv
? blv
->local_if_set
1636 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1638 tem
= Fboundp (variable
);
1639 /* Make sure the symbol has a local value in this particular buffer,
1640 by setting it to the same value it already has. */
1641 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1646 blv
= make_blv (sym
, forwarded
, valcontents
);
1647 sym
->redirect
= SYMBOL_LOCALIZED
;
1648 SET_SYMBOL_BLV (sym
, blv
);
1651 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1652 if (let_shadows_global_binding_p (symbol
))
1653 message ("Making %s local to %s while let-bound!",
1654 SDATA (SYMBOL_NAME (variable
)),
1655 SDATA (current_buffer
->name
));
1659 /* Make sure this buffer has its own value of symbol. */
1660 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1661 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1664 if (let_shadows_buffer_binding_p (sym
))
1665 message ("Making %s buffer-local while locally let-bound!",
1666 SDATA (SYMBOL_NAME (variable
)));
1668 /* Swap out any local binding for some other buffer, and make
1669 sure the current value is permanently recorded, if it's the
1671 find_symbol_value (variable
);
1673 current_buffer
->local_var_alist
1674 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1675 current_buffer
->local_var_alist
);
1677 /* Make sure symbol does not think it is set up for this buffer;
1678 force it to look once again for this buffer's value. */
1679 if (current_buffer
== XBUFFER (blv
->where
))
1681 /* blv->valcell = blv->defcell;
1682 * SET_BLV_FOUND (blv, 0); */
1686 /* If the symbol forwards into a C variable, then load the binding
1687 for this buffer now. If C code modifies the variable before we
1688 load the binding in, then that new value will clobber the default
1689 binding the next time we unload it. */
1691 swap_in_symval_forwarding (sym
, blv
);
1696 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1697 1, 1, "vKill Local Variable: ",
1698 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1699 From now on the default value will apply in this buffer. Return VARIABLE. */)
1700 (register Lisp_Object variable
)
1702 register Lisp_Object tem
;
1703 struct Lisp_Buffer_Local_Value
*blv
;
1704 struct Lisp_Symbol
*sym
;
1706 CHECK_SYMBOL (variable
);
1707 sym
= XSYMBOL (variable
);
1710 switch (sym
->redirect
)
1712 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1713 case SYMBOL_PLAINVAL
: return variable
;
1714 case SYMBOL_FORWARDED
:
1716 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1717 if (BUFFER_OBJFWDP (valcontents
))
1719 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1720 int idx
= PER_BUFFER_IDX (offset
);
1724 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1725 PER_BUFFER_VALUE (current_buffer
, offset
)
1726 = PER_BUFFER_DEFAULT (offset
);
1731 case SYMBOL_LOCALIZED
:
1732 blv
= SYMBOL_BLV (sym
);
1733 if (blv
->frame_local
)
1739 /* Get rid of this buffer's alist element, if any. */
1740 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1741 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1743 current_buffer
->local_var_alist
1744 = Fdelq (tem
, current_buffer
->local_var_alist
);
1746 /* If the symbol is set up with the current buffer's binding
1747 loaded, recompute its value. We have to do it now, or else
1748 forwarded objects won't work right. */
1750 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1751 if (EQ (buf
, blv
->where
))
1754 /* blv->valcell = blv->defcell;
1755 * SET_BLV_FOUND (blv, 0); */
1757 find_symbol_value (variable
);
1764 /* Lisp functions for creating and removing buffer-local variables. */
1766 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1767 when/if this is removed. */
1769 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1770 1, 1, "vMake Variable Frame Local: ",
1771 doc
: /* Enable VARIABLE to have frame-local bindings.
1772 This does not create any frame-local bindings for VARIABLE,
1773 it just makes them possible.
1775 A frame-local binding is actually a frame parameter value.
1776 If a frame F has a value for the frame parameter named VARIABLE,
1777 that also acts as a frame-local binding for VARIABLE in F--
1778 provided this function has been called to enable VARIABLE
1779 to have frame-local bindings at all.
1781 The only way to create a frame-local binding for VARIABLE in a frame
1782 is to set the VARIABLE frame parameter of that frame. See
1783 `modify-frame-parameters' for how to set frame parameters.
1785 Note that since Emacs 23.1, variables cannot be both buffer-local and
1786 frame-local any more (buffer-local bindings used to take precedence over
1787 frame-local bindings). */)
1788 (register Lisp_Object variable
)
1791 union Lisp_Val_Fwd valcontents
;
1792 struct Lisp_Symbol
*sym
;
1793 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1795 CHECK_SYMBOL (variable
);
1796 sym
= XSYMBOL (variable
);
1799 switch (sym
->redirect
)
1801 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1802 case SYMBOL_PLAINVAL
:
1803 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1804 if (EQ (valcontents
.value
, Qunbound
))
1805 valcontents
.value
= Qnil
;
1807 case SYMBOL_LOCALIZED
:
1808 if (SYMBOL_BLV (sym
)->frame_local
)
1811 error ("Symbol %s may not be frame-local",
1812 SDATA (SYMBOL_NAME (variable
)));
1813 case SYMBOL_FORWARDED
:
1814 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1815 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1816 error ("Symbol %s may not be frame-local",
1817 SDATA (SYMBOL_NAME (variable
)));
1823 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1825 blv
= make_blv (sym
, forwarded
, valcontents
);
1826 blv
->frame_local
= 1;
1827 sym
->redirect
= SYMBOL_LOCALIZED
;
1828 SET_SYMBOL_BLV (sym
, blv
);
1831 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1832 if (let_shadows_global_binding_p (symbol
))
1833 message ("Making %s frame-local while let-bound!",
1834 SDATA (SYMBOL_NAME (variable
)));
1839 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1841 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1842 BUFFER defaults to the current buffer. */)
1843 (register Lisp_Object variable
, Lisp_Object buffer
)
1845 register struct buffer
*buf
;
1846 struct Lisp_Symbol
*sym
;
1849 buf
= current_buffer
;
1852 CHECK_BUFFER (buffer
);
1853 buf
= XBUFFER (buffer
);
1856 CHECK_SYMBOL (variable
);
1857 sym
= XSYMBOL (variable
);
1860 switch (sym
->redirect
)
1862 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1863 case SYMBOL_PLAINVAL
: return Qnil
;
1864 case SYMBOL_LOCALIZED
:
1866 Lisp_Object tail
, elt
, tmp
;
1867 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1868 XSETBUFFER (tmp
, buf
);
1869 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1871 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1874 if (EQ (variable
, XCAR (elt
)))
1876 eassert (!blv
->frame_local
);
1877 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1881 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1884 case SYMBOL_FORWARDED
:
1886 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1887 if (BUFFER_OBJFWDP (valcontents
))
1889 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1890 int idx
= PER_BUFFER_IDX (offset
);
1891 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1900 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1902 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1903 More precisely, this means that setting the variable \(with `set' or`setq'),
1904 while it does not have a `let'-style binding that was made in BUFFER,
1905 will produce a buffer local binding. See Info node
1906 `(elisp)Creating Buffer-Local'.
1907 BUFFER defaults to the current buffer. */)
1908 (register Lisp_Object variable
, Lisp_Object buffer
)
1910 struct Lisp_Symbol
*sym
;
1912 CHECK_SYMBOL (variable
);
1913 sym
= XSYMBOL (variable
);
1916 switch (sym
->redirect
)
1918 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1919 case SYMBOL_PLAINVAL
: return Qnil
;
1920 case SYMBOL_LOCALIZED
:
1922 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1923 if (blv
->local_if_set
)
1925 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1926 return Flocal_variable_p (variable
, buffer
);
1928 case SYMBOL_FORWARDED
:
1929 /* All BUFFER_OBJFWD slots become local if they are set. */
1930 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1935 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1937 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1938 If the current binding is buffer-local, the value is the current buffer.
1939 If the current binding is frame-local, the value is the selected frame.
1940 If the current binding is global (the default), the value is nil. */)
1941 (register Lisp_Object variable
)
1943 struct Lisp_Symbol
*sym
;
1945 CHECK_SYMBOL (variable
);
1946 sym
= XSYMBOL (variable
);
1948 /* Make sure the current binding is actually swapped in. */
1949 find_symbol_value (variable
);
1952 switch (sym
->redirect
)
1954 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1955 case SYMBOL_PLAINVAL
: return Qnil
;
1956 case SYMBOL_FORWARDED
:
1958 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1959 if (KBOARD_OBJFWDP (valcontents
))
1960 return Fframe_terminal (Fselected_frame ());
1961 else if (!BUFFER_OBJFWDP (valcontents
))
1965 case SYMBOL_LOCALIZED
:
1966 /* For a local variable, record both the symbol and which
1967 buffer's or frame's value we are saving. */
1968 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1969 return Fcurrent_buffer ();
1970 else if (sym
->redirect
== SYMBOL_LOCALIZED
1971 && BLV_FOUND (SYMBOL_BLV (sym
)))
1972 return SYMBOL_BLV (sym
)->where
;
1979 /* This code is disabled now that we use the selected frame to return
1980 keyboard-local-values. */
1982 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1984 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1985 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1986 If SYMBOL is not a terminal-local variable, then return its normal
1987 value, like `symbol-value'.
1989 TERMINAL may be a terminal object, a frame, or nil (meaning the
1990 selected frame's terminal device). */)
1991 (Lisp_Object symbol
, Lisp_Object terminal
)
1994 struct terminal
*t
= get_terminal (terminal
, 1);
1995 push_kboard (t
->kboard
);
1996 result
= Fsymbol_value (symbol
);
2001 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2002 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2003 If VARIABLE is not a terminal-local variable, then set its normal
2004 binding, like `set'.
2006 TERMINAL may be a terminal object, a frame, or nil (meaning the
2007 selected frame's terminal device). */)
2008 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2011 struct terminal
*t
= get_terminal (terminal
, 1);
2012 push_kboard (d
->kboard
);
2013 result
= Fset (symbol
, value
);
2019 /* Find the function at the end of a chain of symbol function indirections. */
2021 /* If OBJECT is a symbol, find the end of its function chain and
2022 return the value found there. If OBJECT is not a symbol, just
2023 return it. If there is a cycle in the function chain, signal a
2024 cyclic-function-indirection error.
2026 This is like Findirect_function, except that it doesn't signal an
2027 error if the chain ends up unbound. */
2029 indirect_function (register Lisp_Object object
)
2031 Lisp_Object tortoise
, hare
;
2033 hare
= tortoise
= object
;
2037 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2039 hare
= XSYMBOL (hare
)->function
;
2040 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2042 hare
= XSYMBOL (hare
)->function
;
2044 tortoise
= XSYMBOL (tortoise
)->function
;
2046 if (EQ (hare
, tortoise
))
2047 xsignal1 (Qcyclic_function_indirection
, object
);
2053 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2054 doc
: /* Return the function at the end of OBJECT's function chain.
2055 If OBJECT is not a symbol, just return it. Otherwise, follow all
2056 function indirections to find the final function binding and return it.
2057 If the final symbol in the chain is unbound, signal a void-function error.
2058 Optional arg NOERROR non-nil means to return nil instead of signalling.
2059 Signal a cyclic-function-indirection error if there is a loop in the
2060 function chain of symbols. */)
2061 (register Lisp_Object object
, Lisp_Object noerror
)
2065 /* Optimize for no indirection. */
2067 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2068 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2069 result
= indirect_function (result
);
2070 if (!EQ (result
, Qunbound
))
2074 xsignal1 (Qvoid_function
, object
);
2079 /* Extract and set vector and string elements */
2081 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2082 doc
: /* Return the element of ARRAY at index IDX.
2083 ARRAY may be a vector, a string, a char-table, a bool-vector,
2084 or a byte-code object. IDX starts at 0. */)
2085 (register Lisp_Object array
, Lisp_Object idx
)
2087 register int idxval
;
2090 idxval
= XINT (idx
);
2091 if (STRINGP (array
))
2095 if (idxval
< 0 || idxval
>= SCHARS (array
))
2096 args_out_of_range (array
, idx
);
2097 if (! STRING_MULTIBYTE (array
))
2098 return make_number ((unsigned char) SREF (array
, idxval
));
2099 idxval_byte
= string_char_to_byte (array
, idxval
);
2101 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2102 return make_number (c
);
2104 else if (BOOL_VECTOR_P (array
))
2108 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2109 args_out_of_range (array
, idx
);
2111 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2112 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2114 else if (CHAR_TABLE_P (array
))
2116 CHECK_CHARACTER (idx
);
2117 return CHAR_TABLE_REF (array
, idxval
);
2122 if (VECTORP (array
))
2123 size
= XVECTOR (array
)->size
;
2124 else if (COMPILEDP (array
))
2125 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2127 wrong_type_argument (Qarrayp
, array
);
2129 if (idxval
< 0 || idxval
>= size
)
2130 args_out_of_range (array
, idx
);
2131 return XVECTOR (array
)->contents
[idxval
];
2135 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2136 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2137 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2138 bool-vector. IDX starts at 0. */)
2139 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2141 register int idxval
;
2144 idxval
= XINT (idx
);
2145 CHECK_ARRAY (array
, Qarrayp
);
2146 CHECK_IMPURE (array
);
2148 if (VECTORP (array
))
2150 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2151 args_out_of_range (array
, idx
);
2152 XVECTOR (array
)->contents
[idxval
] = newelt
;
2154 else if (BOOL_VECTOR_P (array
))
2158 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2159 args_out_of_range (array
, idx
);
2161 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2163 if (! NILP (newelt
))
2164 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2166 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2167 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2169 else if (CHAR_TABLE_P (array
))
2171 CHECK_CHARACTER (idx
);
2172 CHAR_TABLE_SET (array
, idxval
, newelt
);
2174 else if (STRING_MULTIBYTE (array
))
2176 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2177 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2179 if (idxval
< 0 || idxval
>= SCHARS (array
))
2180 args_out_of_range (array
, idx
);
2181 CHECK_CHARACTER (newelt
);
2183 nbytes
= SBYTES (array
);
2185 idxval_byte
= string_char_to_byte (array
, idxval
);
2186 p1
= SDATA (array
) + idxval_byte
;
2187 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2188 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2189 if (prev_bytes
!= new_bytes
)
2191 /* We must relocate the string data. */
2192 int nchars
= SCHARS (array
);
2196 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2197 memcpy (str
, SDATA (array
), nbytes
);
2198 allocate_string_data (XSTRING (array
), nchars
,
2199 nbytes
+ new_bytes
- prev_bytes
);
2200 memcpy (SDATA (array
), str
, idxval_byte
);
2201 p1
= SDATA (array
) + idxval_byte
;
2202 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2203 nbytes
- (idxval_byte
+ prev_bytes
));
2205 clear_string_char_byte_cache ();
2212 if (idxval
< 0 || idxval
>= SCHARS (array
))
2213 args_out_of_range (array
, idx
);
2214 CHECK_NUMBER (newelt
);
2216 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2220 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2221 if (SREF (array
, i
) >= 0x80)
2222 args_out_of_range (array
, newelt
);
2223 /* ARRAY is an ASCII string. Convert it to a multibyte
2224 string, and try `aset' again. */
2225 STRING_SET_MULTIBYTE (array
);
2226 return Faset (array
, idx
, newelt
);
2228 SSET (array
, idxval
, XINT (newelt
));
2234 /* Arithmetic functions */
2236 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2239 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2241 double f1
= 0, f2
= 0;
2244 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2245 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2247 if (FLOATP (num1
) || FLOATP (num2
))
2250 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2251 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2257 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2262 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2267 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2272 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2277 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2282 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2291 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2292 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2293 (register Lisp_Object num1
, Lisp_Object num2
)
2295 return arithcompare (num1
, num2
, equal
);
2298 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2299 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2300 (register Lisp_Object num1
, Lisp_Object num2
)
2302 return arithcompare (num1
, num2
, less
);
2305 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2306 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2307 (register Lisp_Object num1
, Lisp_Object num2
)
2309 return arithcompare (num1
, num2
, grtr
);
2312 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2313 doc
: /* Return t if first arg is less than or equal to second arg.
2314 Both must be numbers or markers. */)
2315 (register Lisp_Object num1
, Lisp_Object num2
)
2317 return arithcompare (num1
, num2
, less_or_equal
);
2320 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2321 doc
: /* Return t if first arg is greater than or equal to second arg.
2322 Both must be numbers or markers. */)
2323 (register Lisp_Object num1
, Lisp_Object num2
)
2325 return arithcompare (num1
, num2
, grtr_or_equal
);
2328 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2329 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2330 (register Lisp_Object num1
, Lisp_Object num2
)
2332 return arithcompare (num1
, num2
, notequal
);
2335 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2336 doc
: /* Return t if NUMBER is zero. */)
2337 (register Lisp_Object number
)
2339 CHECK_NUMBER_OR_FLOAT (number
);
2341 if (FLOATP (number
))
2343 if (XFLOAT_DATA (number
) == 0.0)
2353 /* Convert between long values and pairs of Lisp integers.
2354 Note that long_to_cons returns a single Lisp integer
2355 when the value fits in one. */
2358 long_to_cons (long unsigned int i
)
2360 unsigned long top
= i
>> 16;
2361 unsigned int bot
= i
& 0xFFFF;
2363 return make_number (bot
);
2364 if (top
== (unsigned long)-1 >> 16)
2365 return Fcons (make_number (-1), make_number (bot
));
2366 return Fcons (make_number (top
), make_number (bot
));
2370 cons_to_long (Lisp_Object c
)
2372 Lisp_Object top
, bot
;
2379 return ((XINT (top
) << 16) | XINT (bot
));
2382 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2383 doc
: /* Return the decimal representation of NUMBER as a string.
2384 Uses a minus sign if negative.
2385 NUMBER may be an integer or a floating point number. */)
2386 (Lisp_Object number
)
2388 char buffer
[VALBITS
];
2390 CHECK_NUMBER_OR_FLOAT (number
);
2392 if (FLOATP (number
))
2394 char pigbuf
[350]; /* see comments in float_to_string */
2396 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2397 return build_string (pigbuf
);
2400 if (sizeof (int) == sizeof (EMACS_INT
))
2401 sprintf (buffer
, "%d", (int) XINT (number
));
2402 else if (sizeof (long) == sizeof (EMACS_INT
))
2403 sprintf (buffer
, "%ld", (long) XINT (number
));
2406 return build_string (buffer
);
2410 digit_to_number (int character
, int base
)
2414 if (character
>= '0' && character
<= '9')
2415 digit
= character
- '0';
2416 else if (character
>= 'a' && character
<= 'z')
2417 digit
= character
- 'a' + 10;
2418 else if (character
>= 'A' && character
<= 'Z')
2419 digit
= character
- 'A' + 10;
2429 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2430 doc
: /* Parse STRING as a decimal number and return the number.
2431 This parses both integers and floating point numbers.
2432 It ignores leading spaces and tabs, and all trailing chars.
2434 If BASE, interpret STRING as a number in that base. If BASE isn't
2435 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2436 If the base used is not 10, STRING is always parsed as integer. */)
2437 (register Lisp_Object string
, Lisp_Object base
)
2439 register unsigned char *p
;
2444 CHECK_STRING (string
);
2450 CHECK_NUMBER (base
);
2452 if (b
< 2 || b
> 16)
2453 xsignal1 (Qargs_out_of_range
, base
);
2456 /* Skip any whitespace at the front of the number. Some versions of
2457 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2459 while (*p
== ' ' || *p
== '\t')
2470 if (isfloat_string (p
, 1) && b
== 10)
2471 val
= make_float (sign
* atof (p
));
2478 int digit
= digit_to_number (*p
++, b
);
2484 val
= make_fixnum_or_float (sign
* v
);
2504 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2505 int, Lisp_Object
*);
2506 extern Lisp_Object
fmod_float (Lisp_Object
, Lisp_Object
);
2509 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2511 register Lisp_Object val
;
2512 register int argnum
;
2513 register EMACS_INT accum
= 0;
2514 register EMACS_INT next
;
2516 switch (SWITCH_ENUM_CAST (code
))
2534 for (argnum
= 0; argnum
< nargs
; argnum
++)
2536 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2538 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2541 return float_arith_driver ((double) accum
, argnum
, code
,
2544 next
= XINT (args
[argnum
]);
2545 switch (SWITCH_ENUM_CAST (code
))
2551 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2562 xsignal0 (Qarith_error
);
2576 if (!argnum
|| next
> accum
)
2580 if (!argnum
|| next
< accum
)
2586 XSETINT (val
, accum
);
2591 #define isnan(x) ((x) != (x))
2594 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2596 register Lisp_Object val
;
2599 for (; argnum
< nargs
; argnum
++)
2601 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2602 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2606 next
= XFLOAT_DATA (val
);
2610 args
[argnum
] = val
; /* runs into a compiler bug. */
2611 next
= XINT (args
[argnum
]);
2613 switch (SWITCH_ENUM_CAST (code
))
2619 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2629 if (! IEEE_FLOATING_POINT
&& next
== 0)
2630 xsignal0 (Qarith_error
);
2637 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2639 if (!argnum
|| isnan (next
) || next
> accum
)
2643 if (!argnum
|| isnan (next
) || next
< accum
)
2649 return make_float (accum
);
2653 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2654 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2655 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2656 (int nargs
, Lisp_Object
*args
)
2658 return arith_driver (Aadd
, nargs
, args
);
2661 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2662 doc
: /* Negate number or subtract numbers or markers and return the result.
2663 With one arg, negates it. With more than one arg,
2664 subtracts all but the first from the first.
2665 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2666 (int nargs
, Lisp_Object
*args
)
2668 return arith_driver (Asub
, nargs
, args
);
2671 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2672 doc
: /* Return product of any number of arguments, which are numbers or markers.
2673 usage: (* &rest NUMBERS-OR-MARKERS) */)
2674 (int nargs
, Lisp_Object
*args
)
2676 return arith_driver (Amult
, nargs
, args
);
2679 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2680 doc
: /* Return first argument divided by all the remaining arguments.
2681 The arguments must be numbers or markers.
2682 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2683 (int nargs
, Lisp_Object
*args
)
2686 for (argnum
= 2; argnum
< nargs
; argnum
++)
2687 if (FLOATP (args
[argnum
]))
2688 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2689 return arith_driver (Adiv
, nargs
, args
);
2692 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2693 doc
: /* Return remainder of X divided by Y.
2694 Both must be integers or markers. */)
2695 (register Lisp_Object x
, Lisp_Object y
)
2699 CHECK_NUMBER_COERCE_MARKER (x
);
2700 CHECK_NUMBER_COERCE_MARKER (y
);
2702 if (XFASTINT (y
) == 0)
2703 xsignal0 (Qarith_error
);
2705 XSETINT (val
, XINT (x
) % XINT (y
));
2719 /* If the magnitude of the result exceeds that of the divisor, or
2720 the sign of the result does not agree with that of the dividend,
2721 iterate with the reduced value. This does not yield a
2722 particularly accurate result, but at least it will be in the
2723 range promised by fmod. */
2725 r
-= f2
* floor (r
/ f2
);
2726 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2730 #endif /* ! HAVE_FMOD */
2732 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2733 doc
: /* Return X modulo Y.
2734 The result falls between zero (inclusive) and Y (exclusive).
2735 Both X and Y must be numbers or markers. */)
2736 (register Lisp_Object x
, Lisp_Object y
)
2741 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2742 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2744 if (FLOATP (x
) || FLOATP (y
))
2745 return fmod_float (x
, y
);
2751 xsignal0 (Qarith_error
);
2755 /* If the "remainder" comes out with the wrong sign, fix it. */
2756 if (i2
< 0 ? i1
> 0 : i1
< 0)
2763 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2764 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2765 The value is always a number; markers are converted to numbers.
2766 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2767 (int nargs
, Lisp_Object
*args
)
2769 return arith_driver (Amax
, nargs
, args
);
2772 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2773 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2774 The value is always a number; markers are converted to numbers.
2775 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2776 (int nargs
, Lisp_Object
*args
)
2778 return arith_driver (Amin
, nargs
, args
);
2781 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2782 doc
: /* Return bitwise-and of all the arguments.
2783 Arguments may be integers, or markers converted to integers.
2784 usage: (logand &rest INTS-OR-MARKERS) */)
2785 (int nargs
, Lisp_Object
*args
)
2787 return arith_driver (Alogand
, nargs
, args
);
2790 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2791 doc
: /* Return bitwise-or of all the arguments.
2792 Arguments may be integers, or markers converted to integers.
2793 usage: (logior &rest INTS-OR-MARKERS) */)
2794 (int nargs
, Lisp_Object
*args
)
2796 return arith_driver (Alogior
, nargs
, args
);
2799 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2800 doc
: /* Return bitwise-exclusive-or of all the arguments.
2801 Arguments may be integers, or markers converted to integers.
2802 usage: (logxor &rest INTS-OR-MARKERS) */)
2803 (int nargs
, Lisp_Object
*args
)
2805 return arith_driver (Alogxor
, nargs
, args
);
2808 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2809 doc
: /* Return VALUE with its bits shifted left by COUNT.
2810 If COUNT is negative, shifting is actually to the right.
2811 In this case, the sign bit is duplicated. */)
2812 (register Lisp_Object value
, Lisp_Object count
)
2814 register Lisp_Object val
;
2816 CHECK_NUMBER (value
);
2817 CHECK_NUMBER (count
);
2819 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2821 else if (XINT (count
) > 0)
2822 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2823 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2824 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2826 XSETINT (val
, XINT (value
) >> -XINT (count
));
2830 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2831 doc
: /* Return VALUE with its bits shifted left by COUNT.
2832 If COUNT is negative, shifting is actually to the right.
2833 In this case, zeros are shifted in on the left. */)
2834 (register Lisp_Object value
, Lisp_Object count
)
2836 register Lisp_Object val
;
2838 CHECK_NUMBER (value
);
2839 CHECK_NUMBER (count
);
2841 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2843 else if (XINT (count
) > 0)
2844 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2845 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2848 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2852 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2853 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2854 Markers are converted to integers. */)
2855 (register Lisp_Object number
)
2857 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2859 if (FLOATP (number
))
2860 return (make_float (1.0 + XFLOAT_DATA (number
)));
2862 XSETINT (number
, XINT (number
) + 1);
2866 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2867 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2868 Markers are converted to integers. */)
2869 (register Lisp_Object number
)
2871 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2873 if (FLOATP (number
))
2874 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2876 XSETINT (number
, XINT (number
) - 1);
2880 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2881 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2882 (register Lisp_Object number
)
2884 CHECK_NUMBER (number
);
2885 XSETINT (number
, ~XINT (number
));
2889 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2890 doc
: /* Return the byteorder for the machine.
2891 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2892 lowercase l) for small endian machines. */)
2895 unsigned i
= 0x04030201;
2896 int order
= *(char *)&i
== 1 ? 108 : 66;
2898 return make_number (order
);
2906 Lisp_Object error_tail
, arith_tail
;
2908 Qquote
= intern_c_string ("quote");
2909 Qlambda
= intern_c_string ("lambda");
2910 Qsubr
= intern_c_string ("subr");
2911 Qerror_conditions
= intern_c_string ("error-conditions");
2912 Qerror_message
= intern_c_string ("error-message");
2913 Qtop_level
= intern_c_string ("top-level");
2915 Qerror
= intern_c_string ("error");
2916 Qquit
= intern_c_string ("quit");
2917 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2918 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2919 Qvoid_function
= intern_c_string ("void-function");
2920 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2921 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2922 Qvoid_variable
= intern_c_string ("void-variable");
2923 Qsetting_constant
= intern_c_string ("setting-constant");
2924 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2926 Qinvalid_function
= intern_c_string ("invalid-function");
2927 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2928 Qno_catch
= intern_c_string ("no-catch");
2929 Qend_of_file
= intern_c_string ("end-of-file");
2930 Qarith_error
= intern_c_string ("arith-error");
2931 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2932 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2933 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2934 Qtext_read_only
= intern_c_string ("text-read-only");
2935 Qmark_inactive
= intern_c_string ("mark-inactive");
2937 Qlistp
= intern_c_string ("listp");
2938 Qconsp
= intern_c_string ("consp");
2939 Qsymbolp
= intern_c_string ("symbolp");
2940 Qkeywordp
= intern_c_string ("keywordp");
2941 Qintegerp
= intern_c_string ("integerp");
2942 Qnatnump
= intern_c_string ("natnump");
2943 Qwholenump
= intern_c_string ("wholenump");
2944 Qstringp
= intern_c_string ("stringp");
2945 Qarrayp
= intern_c_string ("arrayp");
2946 Qsequencep
= intern_c_string ("sequencep");
2947 Qbufferp
= intern_c_string ("bufferp");
2948 Qvectorp
= intern_c_string ("vectorp");
2949 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2950 Qmarkerp
= intern_c_string ("markerp");
2951 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2952 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2953 Qboundp
= intern_c_string ("boundp");
2954 Qfboundp
= intern_c_string ("fboundp");
2956 Qfloatp
= intern_c_string ("floatp");
2957 Qnumberp
= intern_c_string ("numberp");
2958 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2960 Qchar_table_p
= intern_c_string ("char-table-p");
2961 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2963 Qsubrp
= intern_c_string ("subrp");
2964 Qunevalled
= intern_c_string ("unevalled");
2965 Qmany
= intern_c_string ("many");
2967 Qcdr
= intern_c_string ("cdr");
2969 /* Handle automatic advice activation */
2970 Qad_advice_info
= intern_c_string ("ad-advice-info");
2971 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2973 error_tail
= pure_cons (Qerror
, Qnil
);
2975 /* ERROR is used as a signaler for random errors for which nothing else is right */
2977 Fput (Qerror
, Qerror_conditions
,
2979 Fput (Qerror
, Qerror_message
,
2980 make_pure_c_string ("error"));
2982 Fput (Qquit
, Qerror_conditions
,
2983 pure_cons (Qquit
, Qnil
));
2984 Fput (Qquit
, Qerror_message
,
2985 make_pure_c_string ("Quit"));
2987 Fput (Qwrong_type_argument
, Qerror_conditions
,
2988 pure_cons (Qwrong_type_argument
, error_tail
));
2989 Fput (Qwrong_type_argument
, Qerror_message
,
2990 make_pure_c_string ("Wrong type argument"));
2992 Fput (Qargs_out_of_range
, Qerror_conditions
,
2993 pure_cons (Qargs_out_of_range
, error_tail
));
2994 Fput (Qargs_out_of_range
, Qerror_message
,
2995 make_pure_c_string ("Args out of range"));
2997 Fput (Qvoid_function
, Qerror_conditions
,
2998 pure_cons (Qvoid_function
, error_tail
));
2999 Fput (Qvoid_function
, Qerror_message
,
3000 make_pure_c_string ("Symbol's function definition is void"));
3002 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3003 pure_cons (Qcyclic_function_indirection
, error_tail
));
3004 Fput (Qcyclic_function_indirection
, Qerror_message
,
3005 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3007 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3008 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3009 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3010 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3012 Qcircular_list
= intern_c_string ("circular-list");
3013 staticpro (&Qcircular_list
);
3014 Fput (Qcircular_list
, Qerror_conditions
,
3015 pure_cons (Qcircular_list
, error_tail
));
3016 Fput (Qcircular_list
, Qerror_message
,
3017 make_pure_c_string ("List contains a loop"));
3019 Fput (Qvoid_variable
, Qerror_conditions
,
3020 pure_cons (Qvoid_variable
, error_tail
));
3021 Fput (Qvoid_variable
, Qerror_message
,
3022 make_pure_c_string ("Symbol's value as variable is void"));
3024 Fput (Qsetting_constant
, Qerror_conditions
,
3025 pure_cons (Qsetting_constant
, error_tail
));
3026 Fput (Qsetting_constant
, Qerror_message
,
3027 make_pure_c_string ("Attempt to set a constant symbol"));
3029 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3030 pure_cons (Qinvalid_read_syntax
, error_tail
));
3031 Fput (Qinvalid_read_syntax
, Qerror_message
,
3032 make_pure_c_string ("Invalid read syntax"));
3034 Fput (Qinvalid_function
, Qerror_conditions
,
3035 pure_cons (Qinvalid_function
, error_tail
));
3036 Fput (Qinvalid_function
, Qerror_message
,
3037 make_pure_c_string ("Invalid function"));
3039 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3040 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3041 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3042 make_pure_c_string ("Wrong number of arguments"));
3044 Fput (Qno_catch
, Qerror_conditions
,
3045 pure_cons (Qno_catch
, error_tail
));
3046 Fput (Qno_catch
, Qerror_message
,
3047 make_pure_c_string ("No catch for tag"));
3049 Fput (Qend_of_file
, Qerror_conditions
,
3050 pure_cons (Qend_of_file
, error_tail
));
3051 Fput (Qend_of_file
, Qerror_message
,
3052 make_pure_c_string ("End of file during parsing"));
3054 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3055 Fput (Qarith_error
, Qerror_conditions
,
3057 Fput (Qarith_error
, Qerror_message
,
3058 make_pure_c_string ("Arithmetic error"));
3060 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3061 pure_cons (Qbeginning_of_buffer
, error_tail
));
3062 Fput (Qbeginning_of_buffer
, Qerror_message
,
3063 make_pure_c_string ("Beginning of buffer"));
3065 Fput (Qend_of_buffer
, Qerror_conditions
,
3066 pure_cons (Qend_of_buffer
, error_tail
));
3067 Fput (Qend_of_buffer
, Qerror_message
,
3068 make_pure_c_string ("End of buffer"));
3070 Fput (Qbuffer_read_only
, Qerror_conditions
,
3071 pure_cons (Qbuffer_read_only
, error_tail
));
3072 Fput (Qbuffer_read_only
, Qerror_message
,
3073 make_pure_c_string ("Buffer is read-only"));
3075 Fput (Qtext_read_only
, Qerror_conditions
,
3076 pure_cons (Qtext_read_only
, error_tail
));
3077 Fput (Qtext_read_only
, Qerror_message
,
3078 make_pure_c_string ("Text is read-only"));
3080 Qrange_error
= intern_c_string ("range-error");
3081 Qdomain_error
= intern_c_string ("domain-error");
3082 Qsingularity_error
= intern_c_string ("singularity-error");
3083 Qoverflow_error
= intern_c_string ("overflow-error");
3084 Qunderflow_error
= intern_c_string ("underflow-error");
3086 Fput (Qdomain_error
, Qerror_conditions
,
3087 pure_cons (Qdomain_error
, arith_tail
));
3088 Fput (Qdomain_error
, Qerror_message
,
3089 make_pure_c_string ("Arithmetic domain error"));
3091 Fput (Qrange_error
, Qerror_conditions
,
3092 pure_cons (Qrange_error
, arith_tail
));
3093 Fput (Qrange_error
, Qerror_message
,
3094 make_pure_c_string ("Arithmetic range error"));
3096 Fput (Qsingularity_error
, Qerror_conditions
,
3097 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3098 Fput (Qsingularity_error
, Qerror_message
,
3099 make_pure_c_string ("Arithmetic singularity error"));
3101 Fput (Qoverflow_error
, Qerror_conditions
,
3102 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3103 Fput (Qoverflow_error
, Qerror_message
,
3104 make_pure_c_string ("Arithmetic overflow error"));
3106 Fput (Qunderflow_error
, Qerror_conditions
,
3107 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3108 Fput (Qunderflow_error
, Qerror_message
,
3109 make_pure_c_string ("Arithmetic underflow error"));
3111 staticpro (&Qrange_error
);
3112 staticpro (&Qdomain_error
);
3113 staticpro (&Qsingularity_error
);
3114 staticpro (&Qoverflow_error
);
3115 staticpro (&Qunderflow_error
);
3119 staticpro (&Qquote
);
3120 staticpro (&Qlambda
);
3122 staticpro (&Qunbound
);
3123 staticpro (&Qerror_conditions
);
3124 staticpro (&Qerror_message
);
3125 staticpro (&Qtop_level
);
3127 staticpro (&Qerror
);
3129 staticpro (&Qwrong_type_argument
);
3130 staticpro (&Qargs_out_of_range
);
3131 staticpro (&Qvoid_function
);
3132 staticpro (&Qcyclic_function_indirection
);
3133 staticpro (&Qcyclic_variable_indirection
);
3134 staticpro (&Qvoid_variable
);
3135 staticpro (&Qsetting_constant
);
3136 staticpro (&Qinvalid_read_syntax
);
3137 staticpro (&Qwrong_number_of_arguments
);
3138 staticpro (&Qinvalid_function
);
3139 staticpro (&Qno_catch
);
3140 staticpro (&Qend_of_file
);
3141 staticpro (&Qarith_error
);
3142 staticpro (&Qbeginning_of_buffer
);
3143 staticpro (&Qend_of_buffer
);
3144 staticpro (&Qbuffer_read_only
);
3145 staticpro (&Qtext_read_only
);
3146 staticpro (&Qmark_inactive
);
3148 staticpro (&Qlistp
);
3149 staticpro (&Qconsp
);
3150 staticpro (&Qsymbolp
);
3151 staticpro (&Qkeywordp
);
3152 staticpro (&Qintegerp
);
3153 staticpro (&Qnatnump
);
3154 staticpro (&Qwholenump
);
3155 staticpro (&Qstringp
);
3156 staticpro (&Qarrayp
);
3157 staticpro (&Qsequencep
);
3158 staticpro (&Qbufferp
);
3159 staticpro (&Qvectorp
);
3160 staticpro (&Qchar_or_string_p
);
3161 staticpro (&Qmarkerp
);
3162 staticpro (&Qbuffer_or_string_p
);
3163 staticpro (&Qinteger_or_marker_p
);
3164 staticpro (&Qfloatp
);
3165 staticpro (&Qnumberp
);
3166 staticpro (&Qnumber_or_marker_p
);
3167 staticpro (&Qchar_table_p
);
3168 staticpro (&Qvector_or_char_table_p
);
3169 staticpro (&Qsubrp
);
3171 staticpro (&Qunevalled
);
3173 staticpro (&Qboundp
);
3174 staticpro (&Qfboundp
);
3176 staticpro (&Qad_advice_info
);
3177 staticpro (&Qad_activate_internal
);
3179 /* Types that type-of returns. */
3180 Qinteger
= intern_c_string ("integer");
3181 Qsymbol
= intern_c_string ("symbol");
3182 Qstring
= intern_c_string ("string");
3183 Qcons
= intern_c_string ("cons");
3184 Qmarker
= intern_c_string ("marker");
3185 Qoverlay
= intern_c_string ("overlay");
3186 Qfloat
= intern_c_string ("float");
3187 Qwindow_configuration
= intern_c_string ("window-configuration");
3188 Qprocess
= intern_c_string ("process");
3189 Qwindow
= intern_c_string ("window");
3190 /* Qsubr = intern_c_string ("subr"); */
3191 Qcompiled_function
= intern_c_string ("compiled-function");
3192 Qbuffer
= intern_c_string ("buffer");
3193 Qframe
= intern_c_string ("frame");
3194 Qvector
= intern_c_string ("vector");
3195 Qchar_table
= intern_c_string ("char-table");
3196 Qbool_vector
= intern_c_string ("bool-vector");
3197 Qhash_table
= intern_c_string ("hash-table");
3199 DEFSYM (Qfont_spec
, "font-spec");
3200 DEFSYM (Qfont_entity
, "font-entity");
3201 DEFSYM (Qfont_object
, "font-object");
3203 DEFSYM (Qinteractive_form
, "interactive-form");
3205 staticpro (&Qinteger
);
3206 staticpro (&Qsymbol
);
3207 staticpro (&Qstring
);
3209 staticpro (&Qmarker
);
3210 staticpro (&Qoverlay
);
3211 staticpro (&Qfloat
);
3212 staticpro (&Qwindow_configuration
);
3213 staticpro (&Qprocess
);
3214 staticpro (&Qwindow
);
3215 /* staticpro (&Qsubr); */
3216 staticpro (&Qcompiled_function
);
3217 staticpro (&Qbuffer
);
3218 staticpro (&Qframe
);
3219 staticpro (&Qvector
);
3220 staticpro (&Qchar_table
);
3221 staticpro (&Qbool_vector
);
3222 staticpro (&Qhash_table
);
3224 defsubr (&Sindirect_variable
);
3225 defsubr (&Sinteractive_form
);
3228 defsubr (&Stype_of
);
3233 defsubr (&Sintegerp
);
3234 defsubr (&Sinteger_or_marker_p
);
3235 defsubr (&Snumberp
);
3236 defsubr (&Snumber_or_marker_p
);
3238 defsubr (&Snatnump
);
3239 defsubr (&Ssymbolp
);
3240 defsubr (&Skeywordp
);
3241 defsubr (&Sstringp
);
3242 defsubr (&Smultibyte_string_p
);
3243 defsubr (&Svectorp
);
3244 defsubr (&Schar_table_p
);
3245 defsubr (&Svector_or_char_table_p
);
3246 defsubr (&Sbool_vector_p
);
3248 defsubr (&Ssequencep
);
3249 defsubr (&Sbufferp
);
3250 defsubr (&Smarkerp
);
3252 defsubr (&Sbyte_code_function_p
);
3253 defsubr (&Schar_or_string_p
);
3256 defsubr (&Scar_safe
);
3257 defsubr (&Scdr_safe
);
3260 defsubr (&Ssymbol_function
);
3261 defsubr (&Sindirect_function
);
3262 defsubr (&Ssymbol_plist
);
3263 defsubr (&Ssymbol_name
);
3264 defsubr (&Smakunbound
);
3265 defsubr (&Sfmakunbound
);
3267 defsubr (&Sfboundp
);
3269 defsubr (&Sdefalias
);
3270 defsubr (&Ssetplist
);
3271 defsubr (&Ssymbol_value
);
3273 defsubr (&Sdefault_boundp
);
3274 defsubr (&Sdefault_value
);
3275 defsubr (&Sset_default
);
3276 defsubr (&Ssetq_default
);
3277 defsubr (&Smake_variable_buffer_local
);
3278 defsubr (&Smake_local_variable
);
3279 defsubr (&Skill_local_variable
);
3280 defsubr (&Smake_variable_frame_local
);
3281 defsubr (&Slocal_variable_p
);
3282 defsubr (&Slocal_variable_if_set_p
);
3283 defsubr (&Svariable_binding_locus
);
3284 #if 0 /* XXX Remove this. --lorentey */
3285 defsubr (&Sterminal_local_value
);
3286 defsubr (&Sset_terminal_local_value
);
3290 defsubr (&Snumber_to_string
);
3291 defsubr (&Sstring_to_number
);
3292 defsubr (&Seqlsign
);
3315 defsubr (&Sbyteorder
);
3316 defsubr (&Ssubr_arity
);
3317 defsubr (&Ssubr_name
);
3319 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3321 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3322 doc
: /* The largest value that is representable in a Lisp integer. */);
3323 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3324 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3326 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3327 doc
: /* The smallest value that is representable in a Lisp integer. */);
3328 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3329 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3333 arith_error (int signo
)
3335 sigsetmask (SIGEMPTYMASK
);
3337 SIGNAL_THREAD_CHECK (signo
);
3338 xsignal0 (Qarith_error
);
3344 /* Don't do this if just dumping out.
3345 We don't want to call `signal' in this case
3346 so that we don't have trouble with dumping
3347 signal-delivering routines in an inconsistent state. */
3351 #endif /* CANNOT_DUMP */
3352 signal (SIGFPE
, arith_error
);
3355 signal (SIGEMT
, arith_error
);
3359 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3360 (do not change this comment) */