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 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
669 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
670 Associates the function with the current load file, if any.
671 The optional third argument DOCSTRING specifies the documentation string
672 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
673 determined by DEFINITION. */)
674 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
676 CHECK_SYMBOL (symbol
);
677 if (CONSP (XSYMBOL (symbol
)->function
)
678 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
679 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
680 definition
= Ffset (symbol
, definition
);
681 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
682 if (!NILP (docstring
))
683 Fput (symbol
, Qfunction_documentation
, docstring
);
687 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
688 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
689 (register Lisp_Object symbol
, Lisp_Object newplist
)
691 CHECK_SYMBOL (symbol
);
692 XSYMBOL (symbol
)->plist
= newplist
;
696 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
697 doc
: /* Return minimum and maximum number of args allowed for SUBR.
698 SUBR must be a built-in function.
699 The returned value is a pair (MIN . MAX). MIN is the minimum number
700 of args. MAX is the maximum number or the symbol `many', for a
701 function with `&rest' args, or `unevalled' for a special form. */)
704 short minargs
, maxargs
;
706 minargs
= XSUBR (subr
)->min_args
;
707 maxargs
= XSUBR (subr
)->max_args
;
709 return Fcons (make_number (minargs
), Qmany
);
710 else if (maxargs
== UNEVALLED
)
711 return Fcons (make_number (minargs
), Qunevalled
);
713 return Fcons (make_number (minargs
), make_number (maxargs
));
716 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
717 doc
: /* Return name of subroutine SUBR.
718 SUBR must be a built-in function. */)
723 name
= XSUBR (subr
)->symbol_name
;
724 return make_string (name
, strlen (name
));
727 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
728 doc
: /* Return the interactive form of CMD or nil if none.
729 If CMD is not a command, the return value is nil.
730 Value, if non-nil, is a list \(interactive SPEC). */)
733 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
735 if (NILP (fun
) || EQ (fun
, Qunbound
))
738 /* Use an `interactive-form' property if present, analogous to the
739 function-documentation property. */
741 while (SYMBOLP (fun
))
743 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
747 fun
= Fsymbol_function (fun
);
752 const char *spec
= XSUBR (fun
)->intspec
;
754 return list2 (Qinteractive
,
755 (*spec
!= '(') ? build_string (spec
) :
756 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
758 else if (COMPILEDP (fun
))
760 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
761 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
763 else if (CONSP (fun
))
765 Lisp_Object funcar
= XCAR (fun
);
766 if (EQ (funcar
, Qlambda
))
767 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
768 else if (EQ (funcar
, Qautoload
))
772 do_autoload (fun
, cmd
);
774 return Finteractive_form (cmd
);
781 /***********************************************************************
782 Getting and Setting Values of Symbols
783 ***********************************************************************/
785 /* Return the symbol holding SYMBOL's value. Signal
786 `cyclic-variable-indirection' if SYMBOL's chain of variable
787 indirections contains a loop. */
790 indirect_variable (struct Lisp_Symbol
*symbol
)
792 struct Lisp_Symbol
*tortoise
, *hare
;
794 hare
= tortoise
= symbol
;
796 while (hare
->redirect
== SYMBOL_VARALIAS
)
798 hare
= SYMBOL_ALIAS (hare
);
799 if (hare
->redirect
!= SYMBOL_VARALIAS
)
802 hare
= SYMBOL_ALIAS (hare
);
803 tortoise
= SYMBOL_ALIAS (tortoise
);
805 if (hare
== tortoise
)
808 XSETSYMBOL (tem
, symbol
);
809 xsignal1 (Qcyclic_variable_indirection
, tem
);
817 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
818 doc
: /* Return the variable at the end of OBJECT's variable chain.
819 If OBJECT is a symbol, follow all variable indirections and return the final
820 variable. If OBJECT is not a symbol, just return it.
821 Signal a cyclic-variable-indirection error if there is a loop in the
822 variable chain of symbols. */)
825 if (SYMBOLP (object
))
826 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
831 /* Given the raw contents of a symbol value cell,
832 return the Lisp value of the symbol.
833 This does not handle buffer-local variables; use
834 swap_in_symval_forwarding for that. */
836 #define do_blv_forwarding(blv) \
837 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
840 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
842 register Lisp_Object val
;
843 switch (XFWDTYPE (valcontents
))
846 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
850 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
853 return *XOBJFWD (valcontents
)->objvar
;
855 case Lisp_Fwd_Buffer_Obj
:
856 return PER_BUFFER_VALUE (current_buffer
,
857 XBUFFER_OBJFWD (valcontents
)->offset
);
859 case Lisp_Fwd_Kboard_Obj
:
860 /* We used to simply use current_kboard here, but from Lisp
861 code, it's value is often unexpected. It seems nicer to
862 allow constructions like this to work as intuitively expected:
864 (with-selected-frame frame
865 (define-key local-function-map "\eOP" [f1]))
867 On the other hand, this affects the semantics of
868 last-command and real-last-command, and people may rely on
869 that. I took a quick look at the Lisp codebase, and I
870 don't think anything will break. --lorentey */
871 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
872 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
877 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
878 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
879 buffer-independent contents of the value cell: forwarded just one
880 step past the buffer-localness.
882 BUF non-zero means set the value in buffer BUF instead of the
883 current buffer. This only plays a role for per-buffer variables. */
885 #define store_blv_forwarding(blv, newval, buf) \
887 if ((blv)->forwarded) \
888 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
890 SET_BLV_VALUE (blv, newval); \
894 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
896 switch (XFWDTYPE (valcontents
))
899 CHECK_NUMBER (newval
);
900 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
904 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
908 *XOBJFWD (valcontents
)->objvar
= newval
;
910 /* If this variable is a default for something stored
911 in the buffer itself, such as default-fill-column,
912 find the buffers that don't have local values for it
914 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
915 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
917 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
918 - (char *) &buffer_defaults
);
919 int idx
= PER_BUFFER_IDX (offset
);
926 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
931 buf
= Fcdr (XCAR (tail
));
932 if (!BUFFERP (buf
)) continue;
935 if (! PER_BUFFER_VALUE_P (b
, idx
))
936 PER_BUFFER_VALUE (b
, offset
) = newval
;
941 case Lisp_Fwd_Buffer_Obj
:
943 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
944 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
946 if (!(NILP (type
) || NILP (newval
)
947 || (XINT (type
) == LISP_INT_TAG
949 : XTYPE (newval
) == XINT (type
))))
950 buffer_slot_type_mismatch (newval
, XINT (type
));
953 buf
= current_buffer
;
954 PER_BUFFER_VALUE (buf
, offset
) = newval
;
958 case Lisp_Fwd_Kboard_Obj
:
960 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
961 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
962 *(Lisp_Object
*) p
= newval
;
967 abort (); /* goto def; */
971 /* Set up SYMBOL to refer to its global binding.
972 This makes it safe to alter the status of other bindings. */
975 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
977 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
979 /* Unload the previously loaded binding. */
981 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
983 /* Select the global binding in the symbol. */
984 blv
->valcell
= blv
->defcell
;
986 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
988 /* Indicate that the global binding is set up now. */
990 SET_BLV_FOUND (blv
, 0);
993 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
994 VALCONTENTS is the contents of its value cell,
995 which points to a struct Lisp_Buffer_Local_Value.
997 Return the value forwarded one step past the buffer-local stage.
998 This could be another forwarding pointer. */
1001 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1003 register Lisp_Object tem1
;
1005 eassert (blv
== SYMBOL_BLV (symbol
));
1010 || (blv
->frame_local
1011 ? !EQ (selected_frame
, tem1
)
1012 : current_buffer
!= XBUFFER (tem1
)))
1015 /* Unload the previously loaded binding. */
1016 tem1
= blv
->valcell
;
1018 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1019 /* Choose the new binding. */
1022 XSETSYMBOL (var
, symbol
);
1023 if (blv
->frame_local
)
1025 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1026 blv
->where
= selected_frame
;
1030 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1031 XSETBUFFER (blv
->where
, current_buffer
);
1034 if (!(blv
->found
= !NILP (tem1
)))
1035 tem1
= blv
->defcell
;
1037 /* Load the new binding. */
1038 blv
->valcell
= tem1
;
1040 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1044 /* Find the value of a symbol, returning Qunbound if it's not bound.
1045 This is helpful for code which just wants to get a variable's value
1046 if it has one, without signaling an error.
1047 Note that it must not be possible to quit
1048 within this function. Great care is required for this. */
1051 find_symbol_value (Lisp_Object symbol
)
1053 struct Lisp_Symbol
*sym
;
1055 CHECK_SYMBOL (symbol
);
1056 sym
= XSYMBOL (symbol
);
1059 switch (sym
->redirect
)
1061 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1062 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1063 case SYMBOL_LOCALIZED
:
1065 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1066 swap_in_symval_forwarding (sym
, blv
);
1067 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1070 case SYMBOL_FORWARDED
:
1071 return do_symval_forwarding (SYMBOL_FWD (sym
));
1076 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1077 doc
: /* Return SYMBOL's value. Error if that is void. */)
1078 (Lisp_Object symbol
)
1082 val
= find_symbol_value (symbol
);
1083 if (!EQ (val
, Qunbound
))
1086 xsignal1 (Qvoid_variable
, symbol
);
1089 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1090 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1091 (register Lisp_Object symbol
, Lisp_Object newval
)
1093 set_internal (symbol
, newval
, Qnil
, 0);
1097 /* Return 1 if SYMBOL currently has a let-binding
1098 which was made in the buffer that is now current. */
1101 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1103 struct specbinding
*p
;
1105 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1107 && CONSP (p
->symbol
))
1109 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1110 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1111 if (symbol
== let_bound_symbol
1112 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1116 return p
>= specpdl
;
1120 let_shadows_global_binding_p (Lisp_Object symbol
)
1122 struct specbinding
*p
;
1124 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1125 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1128 return p
>= specpdl
;
1131 /* Store the value NEWVAL into SYMBOL.
1132 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1133 (nil stands for the current buffer/frame).
1135 If BINDFLAG is zero, then if this symbol is supposed to become
1136 local in every buffer where it is set, then we make it local.
1137 If BINDFLAG is nonzero, we don't do that. */
1140 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1142 int voide
= EQ (newval
, Qunbound
);
1143 struct Lisp_Symbol
*sym
;
1146 /* If restoring in a dead buffer, do nothing. */
1147 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1150 CHECK_SYMBOL (symbol
);
1151 if (SYMBOL_CONSTANT_P (symbol
))
1153 if (NILP (Fkeywordp (symbol
))
1154 || !EQ (newval
, Fsymbol_value (symbol
)))
1155 xsignal1 (Qsetting_constant
, symbol
);
1157 /* Allow setting keywords to their own value. */
1161 sym
= XSYMBOL (symbol
);
1164 switch (sym
->redirect
)
1166 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1167 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1168 case SYMBOL_LOCALIZED
:
1170 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1173 if (blv
->frame_local
)
1174 where
= selected_frame
;
1176 XSETBUFFER (where
, current_buffer
);
1178 /* If the current buffer is not the buffer whose binding is
1179 loaded, or if there may be frame-local bindings and the frame
1180 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1181 the default binding is loaded, the loaded binding may be the
1183 if (!EQ (blv
->where
, where
)
1184 /* Also unload a global binding (if the var is local_if_set). */
1185 || (EQ (blv
->valcell
, blv
->defcell
)))
1187 /* The currently loaded binding is not necessarily valid.
1188 We need to unload it, and choose a new binding. */
1190 /* Write out `realvalue' to the old loaded binding. */
1192 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1194 /* Find the new binding. */
1195 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1196 tem1
= Fassq (symbol
,
1198 ? XFRAME (where
)->param_alist
1199 : XBUFFER (where
)->local_var_alist
));
1205 /* This buffer still sees the default value. */
1207 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1208 or if this is `let' rather than `set',
1209 make CURRENT-ALIST-ELEMENT point to itself,
1210 indicating that we're seeing the default value.
1211 Likewise if the variable has been let-bound
1212 in the current buffer. */
1213 if (bindflag
|| !blv
->local_if_set
1214 || let_shadows_buffer_binding_p (sym
))
1217 tem1
= blv
->defcell
;
1219 /* If it's a local_if_set, being set not bound,
1220 and we're not within a let that was made for this buffer,
1221 create a new buffer-local binding for the variable.
1222 That means, give this buffer a new assoc for a local value
1223 and load that binding. */
1226 /* local_if_set is only supported for buffer-local
1227 bindings, not for frame-local bindings. */
1228 eassert (!blv
->frame_local
);
1229 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1230 XBUFFER (where
)->local_var_alist
1231 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1235 /* Record which binding is now loaded. */
1236 blv
->valcell
= tem1
;
1239 /* Store the new value in the cons cell. */
1240 SET_BLV_VALUE (blv
, newval
);
1245 /* If storing void (making the symbol void), forward only through
1246 buffer-local indicator, not through Lisp_Objfwd, etc. */
1249 store_symval_forwarding (blv
->fwd
, newval
,
1251 ? XBUFFER (where
) : current_buffer
);
1255 case SYMBOL_FORWARDED
:
1258 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1259 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1260 if (BUFFER_OBJFWDP (innercontents
))
1262 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1263 int idx
= PER_BUFFER_IDX (offset
);
1266 && !let_shadows_buffer_binding_p (sym
))
1267 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1271 { /* If storing void (making the symbol void), forward only through
1272 buffer-local indicator, not through Lisp_Objfwd, etc. */
1273 sym
->redirect
= SYMBOL_PLAINVAL
;
1274 SET_SYMBOL_VAL (sym
, newval
);
1277 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1285 /* Access or set a buffer-local symbol's default value. */
1287 /* Return the default value of SYMBOL, but don't check for voidness.
1288 Return Qunbound if it is void. */
1291 default_value (Lisp_Object symbol
)
1293 struct Lisp_Symbol
*sym
;
1295 CHECK_SYMBOL (symbol
);
1296 sym
= XSYMBOL (symbol
);
1299 switch (sym
->redirect
)
1301 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1302 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1303 case SYMBOL_LOCALIZED
:
1305 /* If var is set up for a buffer that lacks a local value for it,
1306 the current value is nominally the default value.
1307 But the `realvalue' slot may be more up to date, since
1308 ordinary setq stores just that slot. So use that. */
1309 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1310 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1311 return do_symval_forwarding (blv
->fwd
);
1313 return XCDR (blv
->defcell
);
1315 case SYMBOL_FORWARDED
:
1317 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1319 /* For a built-in buffer-local variable, get the default value
1320 rather than letting do_symval_forwarding get the current value. */
1321 if (BUFFER_OBJFWDP (valcontents
))
1323 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1324 if (PER_BUFFER_IDX (offset
) != 0)
1325 return PER_BUFFER_DEFAULT (offset
);
1328 /* For other variables, get the current value. */
1329 return do_symval_forwarding (valcontents
);
1335 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1336 doc
: /* Return t if SYMBOL has a non-void default value.
1337 This is the value that is seen in buffers that do not have their own values
1338 for this variable. */)
1339 (Lisp_Object symbol
)
1341 register Lisp_Object value
;
1343 value
= default_value (symbol
);
1344 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1347 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1348 doc
: /* Return SYMBOL's default value.
1349 This is the value that is seen in buffers that do not have their own values
1350 for this variable. The default value is meaningful for variables with
1351 local bindings in certain buffers. */)
1352 (Lisp_Object symbol
)
1354 register Lisp_Object value
;
1356 value
= default_value (symbol
);
1357 if (!EQ (value
, Qunbound
))
1360 xsignal1 (Qvoid_variable
, symbol
);
1363 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1364 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1365 The default value is seen in buffers that do not have their own values
1366 for this variable. */)
1367 (Lisp_Object symbol
, Lisp_Object value
)
1369 struct Lisp_Symbol
*sym
;
1371 CHECK_SYMBOL (symbol
);
1372 if (SYMBOL_CONSTANT_P (symbol
))
1374 if (NILP (Fkeywordp (symbol
))
1375 || !EQ (value
, Fdefault_value (symbol
)))
1376 xsignal1 (Qsetting_constant
, symbol
);
1378 /* Allow setting keywords to their own value. */
1381 sym
= XSYMBOL (symbol
);
1384 switch (sym
->redirect
)
1386 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1387 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1388 case SYMBOL_LOCALIZED
:
1390 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1392 /* Store new value into the DEFAULT-VALUE slot. */
1393 XSETCDR (blv
->defcell
, value
);
1395 /* If the default binding is now loaded, set the REALVALUE slot too. */
1396 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1397 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1400 case SYMBOL_FORWARDED
:
1402 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1404 /* Handle variables like case-fold-search that have special slots
1406 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1407 if (BUFFER_OBJFWDP (valcontents
))
1409 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1410 int idx
= PER_BUFFER_IDX (offset
);
1412 PER_BUFFER_DEFAULT (offset
) = value
;
1414 /* If this variable is not always local in all buffers,
1415 set it in the buffers that don't nominally have a local value. */
1420 for (b
= all_buffers
; b
; b
= b
->next
)
1421 if (!PER_BUFFER_VALUE_P (b
, idx
))
1422 PER_BUFFER_VALUE (b
, offset
) = value
;
1427 return Fset (symbol
, value
);
1433 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1434 doc
: /* Set the default value of variable VAR to VALUE.
1435 VAR, the variable name, is literal (not evaluated);
1436 VALUE is an expression: it is evaluated and its value returned.
1437 The default value of a variable is seen in buffers
1438 that do not have their own values for the variable.
1440 More generally, you can use multiple variables and values, as in
1441 (setq-default VAR VALUE VAR VALUE...)
1442 This sets each VAR's default value to the corresponding VALUE.
1443 The VALUE for the Nth VAR can refer to the new default values
1445 usage: (setq-default [VAR VALUE]...) */)
1448 register Lisp_Object args_left
;
1449 register Lisp_Object val
, symbol
;
1450 struct gcpro gcpro1
;
1460 val
= Feval (Fcar (Fcdr (args_left
)));
1461 symbol
= XCAR (args_left
);
1462 Fset_default (symbol
, val
);
1463 args_left
= Fcdr (XCDR (args_left
));
1465 while (!NILP (args_left
));
1471 /* Lisp functions for creating and removing buffer-local variables. */
1476 union Lisp_Fwd
*fwd
;
1479 static struct Lisp_Buffer_Local_Value
*
1480 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1482 struct Lisp_Buffer_Local_Value
*blv
1483 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1487 XSETSYMBOL (symbol
, sym
);
1488 tem
= Fcons (symbol
, (forwarded
1489 ? do_symval_forwarding (valcontents
.fwd
)
1490 : valcontents
.value
));
1492 /* Buffer_Local_Values cannot have as realval a buffer-local
1493 or keyboard-local forwarding. */
1494 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1495 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1496 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1498 blv
->frame_local
= 0;
1499 blv
->local_if_set
= 0;
1502 SET_BLV_FOUND (blv
, 0);
1506 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1507 1, 1, "vMake Variable Buffer Local: ",
1508 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1509 At any time, the value for the current buffer is in effect,
1510 unless the variable has never been set in this buffer,
1511 in which case the default value is in effect.
1512 Note that binding the variable with `let', or setting it while
1513 a `let'-style binding made in this buffer is in effect,
1514 does not make the variable buffer-local. Return VARIABLE.
1516 In most cases it is better to use `make-local-variable',
1517 which makes a variable local in just one buffer.
1519 The function `default-value' gets the default value and `set-default' sets it. */)
1520 (register Lisp_Object variable
)
1522 struct Lisp_Symbol
*sym
;
1523 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1524 union Lisp_Val_Fwd valcontents
;
1527 CHECK_SYMBOL (variable
);
1528 sym
= XSYMBOL (variable
);
1531 switch (sym
->redirect
)
1533 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1534 case SYMBOL_PLAINVAL
:
1535 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1536 if (EQ (valcontents
.value
, Qunbound
))
1537 valcontents
.value
= Qnil
;
1539 case SYMBOL_LOCALIZED
:
1540 blv
= SYMBOL_BLV (sym
);
1541 if (blv
->frame_local
)
1542 error ("Symbol %s may not be buffer-local",
1543 SDATA (SYMBOL_NAME (variable
)));
1545 case SYMBOL_FORWARDED
:
1546 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1547 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1548 error ("Symbol %s may not be buffer-local",
1549 SDATA (SYMBOL_NAME (variable
)));
1550 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1557 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1561 blv
= make_blv (sym
, forwarded
, valcontents
);
1562 sym
->redirect
= SYMBOL_LOCALIZED
;
1563 SET_SYMBOL_BLV (sym
, blv
);
1566 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1567 if (let_shadows_global_binding_p (symbol
))
1568 message ("Making %s buffer-local while let-bound!",
1569 SDATA (SYMBOL_NAME (variable
)));
1573 blv
->local_if_set
= 1;
1577 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1578 1, 1, "vMake Local Variable: ",
1579 doc
: /* Make VARIABLE have a separate value in the current buffer.
1580 Other buffers will continue to share a common default value.
1581 \(The buffer-local value of VARIABLE starts out as the same value
1582 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1585 If the variable is already arranged to become local when set,
1586 this function causes a local value to exist for this buffer,
1587 just as setting the variable would do.
1589 This function returns VARIABLE, and therefore
1590 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1593 See also `make-variable-buffer-local'.
1595 Do not use `make-local-variable' to make a hook variable buffer-local.
1596 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1597 (register Lisp_Object variable
)
1599 register Lisp_Object tem
;
1601 union Lisp_Val_Fwd valcontents
;
1602 struct Lisp_Symbol
*sym
;
1603 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1605 CHECK_SYMBOL (variable
);
1606 sym
= XSYMBOL (variable
);
1609 switch (sym
->redirect
)
1611 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1612 case SYMBOL_PLAINVAL
:
1613 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1614 case SYMBOL_LOCALIZED
:
1615 blv
= SYMBOL_BLV (sym
);
1616 if (blv
->frame_local
)
1617 error ("Symbol %s may not be buffer-local",
1618 SDATA (SYMBOL_NAME (variable
)));
1620 case SYMBOL_FORWARDED
:
1621 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1622 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1623 error ("Symbol %s may not be buffer-local",
1624 SDATA (SYMBOL_NAME (variable
)));
1630 error ("Symbol %s may not be buffer-local",
1631 SDATA (SYMBOL_NAME (variable
)));
1633 if (blv
? blv
->local_if_set
1634 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1636 tem
= Fboundp (variable
);
1637 /* Make sure the symbol has a local value in this particular buffer,
1638 by setting it to the same value it already has. */
1639 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1644 blv
= make_blv (sym
, forwarded
, valcontents
);
1645 sym
->redirect
= SYMBOL_LOCALIZED
;
1646 SET_SYMBOL_BLV (sym
, blv
);
1649 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1650 if (let_shadows_global_binding_p (symbol
))
1651 message ("Making %s local to %s while let-bound!",
1652 SDATA (SYMBOL_NAME (variable
)),
1653 SDATA (current_buffer
->name
));
1657 /* Make sure this buffer has its own value of symbol. */
1658 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1659 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1662 if (let_shadows_buffer_binding_p (sym
))
1663 message ("Making %s buffer-local while locally let-bound!",
1664 SDATA (SYMBOL_NAME (variable
)));
1666 /* Swap out any local binding for some other buffer, and make
1667 sure the current value is permanently recorded, if it's the
1669 find_symbol_value (variable
);
1671 current_buffer
->local_var_alist
1672 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1673 current_buffer
->local_var_alist
);
1675 /* Make sure symbol does not think it is set up for this buffer;
1676 force it to look once again for this buffer's value. */
1677 if (current_buffer
== XBUFFER (blv
->where
))
1679 /* blv->valcell = blv->defcell;
1680 * SET_BLV_FOUND (blv, 0); */
1684 /* If the symbol forwards into a C variable, then load the binding
1685 for this buffer now. If C code modifies the variable before we
1686 load the binding in, then that new value will clobber the default
1687 binding the next time we unload it. */
1689 swap_in_symval_forwarding (sym
, blv
);
1694 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1695 1, 1, "vKill Local Variable: ",
1696 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1697 From now on the default value will apply in this buffer. Return VARIABLE. */)
1698 (register Lisp_Object variable
)
1700 register Lisp_Object tem
;
1701 struct Lisp_Buffer_Local_Value
*blv
;
1702 struct Lisp_Symbol
*sym
;
1704 CHECK_SYMBOL (variable
);
1705 sym
= XSYMBOL (variable
);
1708 switch (sym
->redirect
)
1710 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1711 case SYMBOL_PLAINVAL
: return variable
;
1712 case SYMBOL_FORWARDED
:
1714 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1715 if (BUFFER_OBJFWDP (valcontents
))
1717 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1718 int idx
= PER_BUFFER_IDX (offset
);
1722 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1723 PER_BUFFER_VALUE (current_buffer
, offset
)
1724 = PER_BUFFER_DEFAULT (offset
);
1729 case SYMBOL_LOCALIZED
:
1730 blv
= SYMBOL_BLV (sym
);
1731 if (blv
->frame_local
)
1737 /* Get rid of this buffer's alist element, if any. */
1738 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1739 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1741 current_buffer
->local_var_alist
1742 = Fdelq (tem
, current_buffer
->local_var_alist
);
1744 /* If the symbol is set up with the current buffer's binding
1745 loaded, recompute its value. We have to do it now, or else
1746 forwarded objects won't work right. */
1748 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1749 if (EQ (buf
, blv
->where
))
1752 /* blv->valcell = blv->defcell;
1753 * SET_BLV_FOUND (blv, 0); */
1755 find_symbol_value (variable
);
1762 /* Lisp functions for creating and removing buffer-local variables. */
1764 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1765 when/if this is removed. */
1767 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1768 1, 1, "vMake Variable Frame Local: ",
1769 doc
: /* Enable VARIABLE to have frame-local bindings.
1770 This does not create any frame-local bindings for VARIABLE,
1771 it just makes them possible.
1773 A frame-local binding is actually a frame parameter value.
1774 If a frame F has a value for the frame parameter named VARIABLE,
1775 that also acts as a frame-local binding for VARIABLE in F--
1776 provided this function has been called to enable VARIABLE
1777 to have frame-local bindings at all.
1779 The only way to create a frame-local binding for VARIABLE in a frame
1780 is to set the VARIABLE frame parameter of that frame. See
1781 `modify-frame-parameters' for how to set frame parameters.
1783 Note that since Emacs 23.1, variables cannot be both buffer-local and
1784 frame-local any more (buffer-local bindings used to take precedence over
1785 frame-local bindings). */)
1786 (register Lisp_Object variable
)
1789 union Lisp_Val_Fwd valcontents
;
1790 struct Lisp_Symbol
*sym
;
1791 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1793 CHECK_SYMBOL (variable
);
1794 sym
= XSYMBOL (variable
);
1797 switch (sym
->redirect
)
1799 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1800 case SYMBOL_PLAINVAL
:
1801 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1802 if (EQ (valcontents
.value
, Qunbound
))
1803 valcontents
.value
= Qnil
;
1805 case SYMBOL_LOCALIZED
:
1806 if (SYMBOL_BLV (sym
)->frame_local
)
1809 error ("Symbol %s may not be frame-local",
1810 SDATA (SYMBOL_NAME (variable
)));
1811 case SYMBOL_FORWARDED
:
1812 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1813 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1814 error ("Symbol %s may not be frame-local",
1815 SDATA (SYMBOL_NAME (variable
)));
1821 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1823 blv
= make_blv (sym
, forwarded
, valcontents
);
1824 blv
->frame_local
= 1;
1825 sym
->redirect
= SYMBOL_LOCALIZED
;
1826 SET_SYMBOL_BLV (sym
, blv
);
1829 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1830 if (let_shadows_global_binding_p (symbol
))
1831 message ("Making %s frame-local while let-bound!",
1832 SDATA (SYMBOL_NAME (variable
)));
1837 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1839 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1840 BUFFER defaults to the current buffer. */)
1841 (register Lisp_Object variable
, Lisp_Object buffer
)
1843 register struct buffer
*buf
;
1844 struct Lisp_Symbol
*sym
;
1847 buf
= current_buffer
;
1850 CHECK_BUFFER (buffer
);
1851 buf
= XBUFFER (buffer
);
1854 CHECK_SYMBOL (variable
);
1855 sym
= XSYMBOL (variable
);
1858 switch (sym
->redirect
)
1860 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1861 case SYMBOL_PLAINVAL
: return Qnil
;
1862 case SYMBOL_LOCALIZED
:
1864 Lisp_Object tail
, elt
, tmp
;
1865 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1866 XSETBUFFER (tmp
, buf
);
1867 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
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
*);
2505 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2507 register Lisp_Object val
;
2508 register int argnum
;
2509 register EMACS_INT accum
= 0;
2510 register EMACS_INT next
;
2512 switch (SWITCH_ENUM_CAST (code
))
2530 for (argnum
= 0; argnum
< nargs
; argnum
++)
2532 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2534 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2537 return float_arith_driver ((double) accum
, argnum
, code
,
2540 next
= XINT (args
[argnum
]);
2541 switch (SWITCH_ENUM_CAST (code
))
2547 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2558 xsignal0 (Qarith_error
);
2572 if (!argnum
|| next
> accum
)
2576 if (!argnum
|| next
< accum
)
2582 XSETINT (val
, accum
);
2587 #define isnan(x) ((x) != (x))
2590 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2592 register Lisp_Object val
;
2595 for (; argnum
< nargs
; argnum
++)
2597 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2598 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2602 next
= XFLOAT_DATA (val
);
2606 args
[argnum
] = val
; /* runs into a compiler bug. */
2607 next
= XINT (args
[argnum
]);
2609 switch (SWITCH_ENUM_CAST (code
))
2615 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2625 if (! IEEE_FLOATING_POINT
&& next
== 0)
2626 xsignal0 (Qarith_error
);
2633 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2635 if (!argnum
|| isnan (next
) || next
> accum
)
2639 if (!argnum
|| isnan (next
) || next
< accum
)
2645 return make_float (accum
);
2649 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2650 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2651 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2652 (int nargs
, Lisp_Object
*args
)
2654 return arith_driver (Aadd
, nargs
, args
);
2657 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2658 doc
: /* Negate number or subtract numbers or markers and return the result.
2659 With one arg, negates it. With more than one arg,
2660 subtracts all but the first from the first.
2661 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2662 (int nargs
, Lisp_Object
*args
)
2664 return arith_driver (Asub
, nargs
, args
);
2667 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2668 doc
: /* Return product of any number of arguments, which are numbers or markers.
2669 usage: (* &rest NUMBERS-OR-MARKERS) */)
2670 (int nargs
, Lisp_Object
*args
)
2672 return arith_driver (Amult
, nargs
, args
);
2675 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2676 doc
: /* Return first argument divided by all the remaining arguments.
2677 The arguments must be numbers or markers.
2678 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2679 (int nargs
, Lisp_Object
*args
)
2682 for (argnum
= 2; argnum
< nargs
; argnum
++)
2683 if (FLOATP (args
[argnum
]))
2684 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2685 return arith_driver (Adiv
, nargs
, args
);
2688 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2689 doc
: /* Return remainder of X divided by Y.
2690 Both must be integers or markers. */)
2691 (register Lisp_Object x
, Lisp_Object y
)
2695 CHECK_NUMBER_COERCE_MARKER (x
);
2696 CHECK_NUMBER_COERCE_MARKER (y
);
2698 if (XFASTINT (y
) == 0)
2699 xsignal0 (Qarith_error
);
2701 XSETINT (val
, XINT (x
) % XINT (y
));
2715 /* If the magnitude of the result exceeds that of the divisor, or
2716 the sign of the result does not agree with that of the dividend,
2717 iterate with the reduced value. This does not yield a
2718 particularly accurate result, but at least it will be in the
2719 range promised by fmod. */
2721 r
-= f2
* floor (r
/ f2
);
2722 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2726 #endif /* ! HAVE_FMOD */
2728 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2729 doc
: /* Return X modulo Y.
2730 The result falls between zero (inclusive) and Y (exclusive).
2731 Both X and Y must be numbers or markers. */)
2732 (register Lisp_Object x
, Lisp_Object y
)
2737 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2738 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2740 if (FLOATP (x
) || FLOATP (y
))
2741 return fmod_float (x
, y
);
2747 xsignal0 (Qarith_error
);
2751 /* If the "remainder" comes out with the wrong sign, fix it. */
2752 if (i2
< 0 ? i1
> 0 : i1
< 0)
2759 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2760 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2761 The value is always a number; markers are converted to numbers.
2762 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2763 (int nargs
, Lisp_Object
*args
)
2765 return arith_driver (Amax
, nargs
, args
);
2768 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2769 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2770 The value is always a number; markers are converted to numbers.
2771 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2772 (int nargs
, Lisp_Object
*args
)
2774 return arith_driver (Amin
, nargs
, args
);
2777 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2778 doc
: /* Return bitwise-and of all the arguments.
2779 Arguments may be integers, or markers converted to integers.
2780 usage: (logand &rest INTS-OR-MARKERS) */)
2781 (int nargs
, Lisp_Object
*args
)
2783 return arith_driver (Alogand
, nargs
, args
);
2786 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2787 doc
: /* Return bitwise-or of all the arguments.
2788 Arguments may be integers, or markers converted to integers.
2789 usage: (logior &rest INTS-OR-MARKERS) */)
2790 (int nargs
, Lisp_Object
*args
)
2792 return arith_driver (Alogior
, nargs
, args
);
2795 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2796 doc
: /* Return bitwise-exclusive-or of all the arguments.
2797 Arguments may be integers, or markers converted to integers.
2798 usage: (logxor &rest INTS-OR-MARKERS) */)
2799 (int nargs
, Lisp_Object
*args
)
2801 return arith_driver (Alogxor
, nargs
, args
);
2804 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2805 doc
: /* Return VALUE with its bits shifted left by COUNT.
2806 If COUNT is negative, shifting is actually to the right.
2807 In this case, the sign bit is duplicated. */)
2808 (register Lisp_Object value
, Lisp_Object count
)
2810 register Lisp_Object val
;
2812 CHECK_NUMBER (value
);
2813 CHECK_NUMBER (count
);
2815 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2817 else if (XINT (count
) > 0)
2818 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2819 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2820 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2822 XSETINT (val
, XINT (value
) >> -XINT (count
));
2826 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2827 doc
: /* Return VALUE with its bits shifted left by COUNT.
2828 If COUNT is negative, shifting is actually to the right.
2829 In this case, zeros are shifted in on the left. */)
2830 (register Lisp_Object value
, Lisp_Object count
)
2832 register Lisp_Object val
;
2834 CHECK_NUMBER (value
);
2835 CHECK_NUMBER (count
);
2837 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2839 else if (XINT (count
) > 0)
2840 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2841 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2844 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2848 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2849 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2850 Markers are converted to integers. */)
2851 (register Lisp_Object number
)
2853 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2855 if (FLOATP (number
))
2856 return (make_float (1.0 + XFLOAT_DATA (number
)));
2858 XSETINT (number
, XINT (number
) + 1);
2862 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2863 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2864 Markers are converted to integers. */)
2865 (register Lisp_Object number
)
2867 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2869 if (FLOATP (number
))
2870 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2872 XSETINT (number
, XINT (number
) - 1);
2876 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2877 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2878 (register Lisp_Object number
)
2880 CHECK_NUMBER (number
);
2881 XSETINT (number
, ~XINT (number
));
2885 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2886 doc
: /* Return the byteorder for the machine.
2887 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2888 lowercase l) for small endian machines. */)
2891 unsigned i
= 0x04030201;
2892 int order
= *(char *)&i
== 1 ? 108 : 66;
2894 return make_number (order
);
2902 Lisp_Object error_tail
, arith_tail
;
2904 Qquote
= intern_c_string ("quote");
2905 Qlambda
= intern_c_string ("lambda");
2906 Qsubr
= intern_c_string ("subr");
2907 Qerror_conditions
= intern_c_string ("error-conditions");
2908 Qerror_message
= intern_c_string ("error-message");
2909 Qtop_level
= intern_c_string ("top-level");
2911 Qerror
= intern_c_string ("error");
2912 Qquit
= intern_c_string ("quit");
2913 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2914 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2915 Qvoid_function
= intern_c_string ("void-function");
2916 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2917 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2918 Qvoid_variable
= intern_c_string ("void-variable");
2919 Qsetting_constant
= intern_c_string ("setting-constant");
2920 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2922 Qinvalid_function
= intern_c_string ("invalid-function");
2923 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2924 Qno_catch
= intern_c_string ("no-catch");
2925 Qend_of_file
= intern_c_string ("end-of-file");
2926 Qarith_error
= intern_c_string ("arith-error");
2927 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2928 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2929 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2930 Qtext_read_only
= intern_c_string ("text-read-only");
2931 Qmark_inactive
= intern_c_string ("mark-inactive");
2933 Qlistp
= intern_c_string ("listp");
2934 Qconsp
= intern_c_string ("consp");
2935 Qsymbolp
= intern_c_string ("symbolp");
2936 Qkeywordp
= intern_c_string ("keywordp");
2937 Qintegerp
= intern_c_string ("integerp");
2938 Qnatnump
= intern_c_string ("natnump");
2939 Qwholenump
= intern_c_string ("wholenump");
2940 Qstringp
= intern_c_string ("stringp");
2941 Qarrayp
= intern_c_string ("arrayp");
2942 Qsequencep
= intern_c_string ("sequencep");
2943 Qbufferp
= intern_c_string ("bufferp");
2944 Qvectorp
= intern_c_string ("vectorp");
2945 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2946 Qmarkerp
= intern_c_string ("markerp");
2947 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2948 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2949 Qboundp
= intern_c_string ("boundp");
2950 Qfboundp
= intern_c_string ("fboundp");
2952 Qfloatp
= intern_c_string ("floatp");
2953 Qnumberp
= intern_c_string ("numberp");
2954 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2956 Qchar_table_p
= intern_c_string ("char-table-p");
2957 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2959 Qsubrp
= intern_c_string ("subrp");
2960 Qunevalled
= intern_c_string ("unevalled");
2961 Qmany
= intern_c_string ("many");
2963 Qcdr
= intern_c_string ("cdr");
2965 /* Handle automatic advice activation */
2966 Qad_advice_info
= intern_c_string ("ad-advice-info");
2967 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2969 error_tail
= pure_cons (Qerror
, Qnil
);
2971 /* ERROR is used as a signaler for random errors for which nothing else is right */
2973 Fput (Qerror
, Qerror_conditions
,
2975 Fput (Qerror
, Qerror_message
,
2976 make_pure_c_string ("error"));
2978 Fput (Qquit
, Qerror_conditions
,
2979 pure_cons (Qquit
, Qnil
));
2980 Fput (Qquit
, Qerror_message
,
2981 make_pure_c_string ("Quit"));
2983 Fput (Qwrong_type_argument
, Qerror_conditions
,
2984 pure_cons (Qwrong_type_argument
, error_tail
));
2985 Fput (Qwrong_type_argument
, Qerror_message
,
2986 make_pure_c_string ("Wrong type argument"));
2988 Fput (Qargs_out_of_range
, Qerror_conditions
,
2989 pure_cons (Qargs_out_of_range
, error_tail
));
2990 Fput (Qargs_out_of_range
, Qerror_message
,
2991 make_pure_c_string ("Args out of range"));
2993 Fput (Qvoid_function
, Qerror_conditions
,
2994 pure_cons (Qvoid_function
, error_tail
));
2995 Fput (Qvoid_function
, Qerror_message
,
2996 make_pure_c_string ("Symbol's function definition is void"));
2998 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2999 pure_cons (Qcyclic_function_indirection
, error_tail
));
3000 Fput (Qcyclic_function_indirection
, Qerror_message
,
3001 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3003 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3004 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3005 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3006 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3008 Qcircular_list
= intern_c_string ("circular-list");
3009 staticpro (&Qcircular_list
);
3010 Fput (Qcircular_list
, Qerror_conditions
,
3011 pure_cons (Qcircular_list
, error_tail
));
3012 Fput (Qcircular_list
, Qerror_message
,
3013 make_pure_c_string ("List contains a loop"));
3015 Fput (Qvoid_variable
, Qerror_conditions
,
3016 pure_cons (Qvoid_variable
, error_tail
));
3017 Fput (Qvoid_variable
, Qerror_message
,
3018 make_pure_c_string ("Symbol's value as variable is void"));
3020 Fput (Qsetting_constant
, Qerror_conditions
,
3021 pure_cons (Qsetting_constant
, error_tail
));
3022 Fput (Qsetting_constant
, Qerror_message
,
3023 make_pure_c_string ("Attempt to set a constant symbol"));
3025 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3026 pure_cons (Qinvalid_read_syntax
, error_tail
));
3027 Fput (Qinvalid_read_syntax
, Qerror_message
,
3028 make_pure_c_string ("Invalid read syntax"));
3030 Fput (Qinvalid_function
, Qerror_conditions
,
3031 pure_cons (Qinvalid_function
, error_tail
));
3032 Fput (Qinvalid_function
, Qerror_message
,
3033 make_pure_c_string ("Invalid function"));
3035 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3036 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3037 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3038 make_pure_c_string ("Wrong number of arguments"));
3040 Fput (Qno_catch
, Qerror_conditions
,
3041 pure_cons (Qno_catch
, error_tail
));
3042 Fput (Qno_catch
, Qerror_message
,
3043 make_pure_c_string ("No catch for tag"));
3045 Fput (Qend_of_file
, Qerror_conditions
,
3046 pure_cons (Qend_of_file
, error_tail
));
3047 Fput (Qend_of_file
, Qerror_message
,
3048 make_pure_c_string ("End of file during parsing"));
3050 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3051 Fput (Qarith_error
, Qerror_conditions
,
3053 Fput (Qarith_error
, Qerror_message
,
3054 make_pure_c_string ("Arithmetic error"));
3056 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3057 pure_cons (Qbeginning_of_buffer
, error_tail
));
3058 Fput (Qbeginning_of_buffer
, Qerror_message
,
3059 make_pure_c_string ("Beginning of buffer"));
3061 Fput (Qend_of_buffer
, Qerror_conditions
,
3062 pure_cons (Qend_of_buffer
, error_tail
));
3063 Fput (Qend_of_buffer
, Qerror_message
,
3064 make_pure_c_string ("End of buffer"));
3066 Fput (Qbuffer_read_only
, Qerror_conditions
,
3067 pure_cons (Qbuffer_read_only
, error_tail
));
3068 Fput (Qbuffer_read_only
, Qerror_message
,
3069 make_pure_c_string ("Buffer is read-only"));
3071 Fput (Qtext_read_only
, Qerror_conditions
,
3072 pure_cons (Qtext_read_only
, error_tail
));
3073 Fput (Qtext_read_only
, Qerror_message
,
3074 make_pure_c_string ("Text is read-only"));
3076 Qrange_error
= intern_c_string ("range-error");
3077 Qdomain_error
= intern_c_string ("domain-error");
3078 Qsingularity_error
= intern_c_string ("singularity-error");
3079 Qoverflow_error
= intern_c_string ("overflow-error");
3080 Qunderflow_error
= intern_c_string ("underflow-error");
3082 Fput (Qdomain_error
, Qerror_conditions
,
3083 pure_cons (Qdomain_error
, arith_tail
));
3084 Fput (Qdomain_error
, Qerror_message
,
3085 make_pure_c_string ("Arithmetic domain error"));
3087 Fput (Qrange_error
, Qerror_conditions
,
3088 pure_cons (Qrange_error
, arith_tail
));
3089 Fput (Qrange_error
, Qerror_message
,
3090 make_pure_c_string ("Arithmetic range error"));
3092 Fput (Qsingularity_error
, Qerror_conditions
,
3093 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3094 Fput (Qsingularity_error
, Qerror_message
,
3095 make_pure_c_string ("Arithmetic singularity error"));
3097 Fput (Qoverflow_error
, Qerror_conditions
,
3098 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3099 Fput (Qoverflow_error
, Qerror_message
,
3100 make_pure_c_string ("Arithmetic overflow error"));
3102 Fput (Qunderflow_error
, Qerror_conditions
,
3103 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3104 Fput (Qunderflow_error
, Qerror_message
,
3105 make_pure_c_string ("Arithmetic underflow error"));
3107 staticpro (&Qrange_error
);
3108 staticpro (&Qdomain_error
);
3109 staticpro (&Qsingularity_error
);
3110 staticpro (&Qoverflow_error
);
3111 staticpro (&Qunderflow_error
);
3115 staticpro (&Qquote
);
3116 staticpro (&Qlambda
);
3118 staticpro (&Qunbound
);
3119 staticpro (&Qerror_conditions
);
3120 staticpro (&Qerror_message
);
3121 staticpro (&Qtop_level
);
3123 staticpro (&Qerror
);
3125 staticpro (&Qwrong_type_argument
);
3126 staticpro (&Qargs_out_of_range
);
3127 staticpro (&Qvoid_function
);
3128 staticpro (&Qcyclic_function_indirection
);
3129 staticpro (&Qcyclic_variable_indirection
);
3130 staticpro (&Qvoid_variable
);
3131 staticpro (&Qsetting_constant
);
3132 staticpro (&Qinvalid_read_syntax
);
3133 staticpro (&Qwrong_number_of_arguments
);
3134 staticpro (&Qinvalid_function
);
3135 staticpro (&Qno_catch
);
3136 staticpro (&Qend_of_file
);
3137 staticpro (&Qarith_error
);
3138 staticpro (&Qbeginning_of_buffer
);
3139 staticpro (&Qend_of_buffer
);
3140 staticpro (&Qbuffer_read_only
);
3141 staticpro (&Qtext_read_only
);
3142 staticpro (&Qmark_inactive
);
3144 staticpro (&Qlistp
);
3145 staticpro (&Qconsp
);
3146 staticpro (&Qsymbolp
);
3147 staticpro (&Qkeywordp
);
3148 staticpro (&Qintegerp
);
3149 staticpro (&Qnatnump
);
3150 staticpro (&Qwholenump
);
3151 staticpro (&Qstringp
);
3152 staticpro (&Qarrayp
);
3153 staticpro (&Qsequencep
);
3154 staticpro (&Qbufferp
);
3155 staticpro (&Qvectorp
);
3156 staticpro (&Qchar_or_string_p
);
3157 staticpro (&Qmarkerp
);
3158 staticpro (&Qbuffer_or_string_p
);
3159 staticpro (&Qinteger_or_marker_p
);
3160 staticpro (&Qfloatp
);
3161 staticpro (&Qnumberp
);
3162 staticpro (&Qnumber_or_marker_p
);
3163 staticpro (&Qchar_table_p
);
3164 staticpro (&Qvector_or_char_table_p
);
3165 staticpro (&Qsubrp
);
3167 staticpro (&Qunevalled
);
3169 staticpro (&Qboundp
);
3170 staticpro (&Qfboundp
);
3172 staticpro (&Qad_advice_info
);
3173 staticpro (&Qad_activate_internal
);
3175 /* Types that type-of returns. */
3176 Qinteger
= intern_c_string ("integer");
3177 Qsymbol
= intern_c_string ("symbol");
3178 Qstring
= intern_c_string ("string");
3179 Qcons
= intern_c_string ("cons");
3180 Qmarker
= intern_c_string ("marker");
3181 Qoverlay
= intern_c_string ("overlay");
3182 Qfloat
= intern_c_string ("float");
3183 Qwindow_configuration
= intern_c_string ("window-configuration");
3184 Qprocess
= intern_c_string ("process");
3185 Qwindow
= intern_c_string ("window");
3186 /* Qsubr = intern_c_string ("subr"); */
3187 Qcompiled_function
= intern_c_string ("compiled-function");
3188 Qbuffer
= intern_c_string ("buffer");
3189 Qframe
= intern_c_string ("frame");
3190 Qvector
= intern_c_string ("vector");
3191 Qchar_table
= intern_c_string ("char-table");
3192 Qbool_vector
= intern_c_string ("bool-vector");
3193 Qhash_table
= intern_c_string ("hash-table");
3195 DEFSYM (Qfont_spec
, "font-spec");
3196 DEFSYM (Qfont_entity
, "font-entity");
3197 DEFSYM (Qfont_object
, "font-object");
3199 DEFSYM (Qinteractive_form
, "interactive-form");
3201 staticpro (&Qinteger
);
3202 staticpro (&Qsymbol
);
3203 staticpro (&Qstring
);
3205 staticpro (&Qmarker
);
3206 staticpro (&Qoverlay
);
3207 staticpro (&Qfloat
);
3208 staticpro (&Qwindow_configuration
);
3209 staticpro (&Qprocess
);
3210 staticpro (&Qwindow
);
3211 /* staticpro (&Qsubr); */
3212 staticpro (&Qcompiled_function
);
3213 staticpro (&Qbuffer
);
3214 staticpro (&Qframe
);
3215 staticpro (&Qvector
);
3216 staticpro (&Qchar_table
);
3217 staticpro (&Qbool_vector
);
3218 staticpro (&Qhash_table
);
3220 defsubr (&Sindirect_variable
);
3221 defsubr (&Sinteractive_form
);
3224 defsubr (&Stype_of
);
3229 defsubr (&Sintegerp
);
3230 defsubr (&Sinteger_or_marker_p
);
3231 defsubr (&Snumberp
);
3232 defsubr (&Snumber_or_marker_p
);
3234 defsubr (&Snatnump
);
3235 defsubr (&Ssymbolp
);
3236 defsubr (&Skeywordp
);
3237 defsubr (&Sstringp
);
3238 defsubr (&Smultibyte_string_p
);
3239 defsubr (&Svectorp
);
3240 defsubr (&Schar_table_p
);
3241 defsubr (&Svector_or_char_table_p
);
3242 defsubr (&Sbool_vector_p
);
3244 defsubr (&Ssequencep
);
3245 defsubr (&Sbufferp
);
3246 defsubr (&Smarkerp
);
3248 defsubr (&Sbyte_code_function_p
);
3249 defsubr (&Schar_or_string_p
);
3252 defsubr (&Scar_safe
);
3253 defsubr (&Scdr_safe
);
3256 defsubr (&Ssymbol_function
);
3257 defsubr (&Sindirect_function
);
3258 defsubr (&Ssymbol_plist
);
3259 defsubr (&Ssymbol_name
);
3260 defsubr (&Smakunbound
);
3261 defsubr (&Sfmakunbound
);
3263 defsubr (&Sfboundp
);
3265 defsubr (&Sdefalias
);
3266 defsubr (&Ssetplist
);
3267 defsubr (&Ssymbol_value
);
3269 defsubr (&Sdefault_boundp
);
3270 defsubr (&Sdefault_value
);
3271 defsubr (&Sset_default
);
3272 defsubr (&Ssetq_default
);
3273 defsubr (&Smake_variable_buffer_local
);
3274 defsubr (&Smake_local_variable
);
3275 defsubr (&Skill_local_variable
);
3276 defsubr (&Smake_variable_frame_local
);
3277 defsubr (&Slocal_variable_p
);
3278 defsubr (&Slocal_variable_if_set_p
);
3279 defsubr (&Svariable_binding_locus
);
3280 #if 0 /* XXX Remove this. --lorentey */
3281 defsubr (&Sterminal_local_value
);
3282 defsubr (&Sset_terminal_local_value
);
3286 defsubr (&Snumber_to_string
);
3287 defsubr (&Sstring_to_number
);
3288 defsubr (&Seqlsign
);
3311 defsubr (&Sbyteorder
);
3312 defsubr (&Ssubr_arity
);
3313 defsubr (&Ssubr_name
);
3315 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3317 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3318 doc
: /* The largest value that is representable in a Lisp integer. */);
3319 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3320 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3322 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3323 doc
: /* The smallest value that is representable in a Lisp integer. */);
3324 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3325 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3329 arith_error (int signo
)
3331 sigsetmask (SIGEMPTYMASK
);
3333 SIGNAL_THREAD_CHECK (signo
);
3334 xsignal0 (Qarith_error
);
3340 /* Don't do this if just dumping out.
3341 We don't want to call `signal' in this case
3342 so that we don't have trouble with dumping
3343 signal-delivering routines in an inconsistent state. */
3347 #endif /* CANNOT_DUMP */
3348 signal (SIGFPE
, arith_error
);
3351 signal (SIGEMT
, arith_error
);
3355 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3356 (do not change this comment) */