1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
34 #include "syssignal.h"
36 #ifdef LISP_FLOAT_TYPE
43 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
44 #ifndef IEEE_FLOATING_POINT
45 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
46 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
47 #define IEEE_FLOATING_POINT 1
49 #define IEEE_FLOATING_POINT 0
53 /* Work around a problem that happens because math.h on hpux 7
54 defines two static variables--which, in Emacs, are not really static,
55 because `static' is defined as nothing. The problem is that they are
56 here, in floatfns.c, and in lread.c.
57 These macros prevent the name conflict. */
58 #if defined (HPUX) && !defined (HPUX8)
59 #define _MAXLDBL data_c_maxldbl
60 #define _NMAXLDBL data_c_nmaxldbl
64 #endif /* LISP_FLOAT_TYPE */
67 extern double atof ();
70 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
71 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
72 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
73 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
74 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
75 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
76 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
77 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
78 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
79 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
80 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
81 Lisp_Object Qbuffer_or_string_p
;
82 Lisp_Object Qboundp
, Qfboundp
;
83 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
86 Lisp_Object Qad_advice_info
, Qad_activate
;
88 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
89 Lisp_Object Qoverflow_error
, Qunderflow_error
;
91 #ifdef LISP_FLOAT_TYPE
93 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
96 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
97 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
99 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
100 static Lisp_Object Qchar_table
, Qbool_vector
;
102 static Lisp_Object
swap_in_symval_forwarding ();
104 Lisp_Object
set_internal ();
107 wrong_type_argument (predicate
, value
)
108 register Lisp_Object predicate
, value
;
110 register Lisp_Object tem
;
113 if (!EQ (Vmocklisp_arguments
, Qt
))
115 if (STRINGP (value
) &&
116 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
117 return Fstring_to_number (value
, Qnil
);
118 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
119 return Fnumber_to_string (value
);
122 /* If VALUE is not even a valid Lisp object, abort here
123 where we can get a backtrace showing where it came from. */
124 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
127 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
128 tem
= call1 (predicate
, value
);
136 error ("Attempt to modify read-only object");
140 args_out_of_range (a1
, a2
)
144 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
148 args_out_of_range_3 (a1
, a2
, a3
)
149 Lisp_Object a1
, a2
, a3
;
152 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
155 /* On some machines, XINT needs a temporary location.
156 Here it is, in case it is needed. */
158 int sign_extend_temp
;
160 /* On a few machines, XINT can only be done by calling this. */
163 sign_extend_lisp_int (num
)
166 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
167 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
169 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
172 /* Data type predicates */
174 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
175 "Return t if the two args are the same Lisp object.")
177 Lisp_Object obj1
, obj2
;
184 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
193 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
194 "Return a symbol representing the type of OBJECT.\n\
195 The symbol returned names the object's basic type;\n\
196 for example, (type-of 1) returns `integer'.")
200 switch (XGCTYPE (object
))
215 switch (XMISCTYPE (object
))
217 case Lisp_Misc_Marker
:
219 case Lisp_Misc_Overlay
:
221 case Lisp_Misc_Float
:
226 case Lisp_Vectorlike
:
227 if (GC_WINDOW_CONFIGURATIONP (object
))
228 return Qwindow_configuration
;
229 if (GC_PROCESSP (object
))
231 if (GC_WINDOWP (object
))
233 if (GC_SUBRP (object
))
235 if (GC_COMPILEDP (object
))
236 return Qcompiled_function
;
237 if (GC_BUFFERP (object
))
239 if (GC_CHAR_TABLE_P (object
))
241 if (GC_BOOL_VECTOR_P (object
))
243 if (GC_FRAMEP (object
))
247 #ifdef LISP_FLOAT_TYPE
257 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
266 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "Return t if OBJECT is not a cons cell. This includes nil.")
275 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "Return t if OBJECT is a list. This includes nil.")
279 if (CONSP (object
) || NILP (object
))
284 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "Return t if OBJECT is not a list. Lists include nil.")
288 if (CONSP (object
) || NILP (object
))
293 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "Return t if OBJECT is a symbol.")
297 if (SYMBOLP (object
))
302 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "Return t if OBJECT is a vector.")
306 if (VECTORP (object
))
311 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "Return t if OBJECT is a string.")
315 if (STRINGP (object
))
320 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0, "Return t if OBJECT is a char-table.")
324 if (CHAR_TABLE_P (object
))
329 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
330 Svector_or_char_table_p
, 1, 1, 0,
331 "Return t if OBJECT is a char-table or vector.")
335 if (VECTORP (object
) || CHAR_TABLE_P (object
))
340 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
344 if (BOOL_VECTOR_P (object
))
349 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
353 if (VECTORP (object
) || STRINGP (object
)
354 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
359 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
360 "Return t if OBJECT is a sequence (list or array).")
362 register Lisp_Object object
;
364 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
365 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
370 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
374 if (BUFFERP (object
))
379 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
383 if (MARKERP (object
))
388 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
397 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
398 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
402 if (COMPILEDP (object
))
407 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
408 "Return t if OBJECT is a character (an integer) or a string.")
410 register Lisp_Object object
;
412 if (INTEGERP (object
) || STRINGP (object
))
417 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
421 if (INTEGERP (object
))
426 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
427 "Return t if OBJECT is an integer or a marker (editor pointer).")
429 register Lisp_Object object
;
431 if (MARKERP (object
) || INTEGERP (object
))
436 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
437 "Return t if OBJECT is a nonnegative integer.")
441 if (NATNUMP (object
))
446 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
447 "Return t if OBJECT is a number (floating point or integer).")
451 if (NUMBERP (object
))
457 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
458 Snumber_or_marker_p
, 1, 1, 0,
459 "Return t if OBJECT is a number or a marker.")
463 if (NUMBERP (object
) || MARKERP (object
))
468 #ifdef LISP_FLOAT_TYPE
469 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
470 "Return t if OBJECT is a floating point number.")
478 #endif /* LISP_FLOAT_TYPE */
480 /* Extract and set components of lists */
482 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
483 "Return the car of LIST. If arg is nil, return nil.\n\
484 Error if arg is not nil and not a cons cell. See also `car-safe'.")
486 register Lisp_Object list
;
491 return XCONS (list
)->car
;
492 else if (EQ (list
, Qnil
))
495 list
= wrong_type_argument (Qlistp
, list
);
499 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
500 "Return the car of OBJECT if it is a cons cell, or else nil.")
505 return XCONS (object
)->car
;
510 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
511 "Return the cdr of LIST. If arg is nil, return nil.\n\
512 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
515 register Lisp_Object list
;
520 return XCONS (list
)->cdr
;
521 else if (EQ (list
, Qnil
))
524 list
= wrong_type_argument (Qlistp
, list
);
528 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
529 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
534 return XCONS (object
)->cdr
;
539 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
540 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
542 register Lisp_Object cell
, newcar
;
545 cell
= wrong_type_argument (Qconsp
, cell
);
548 XCONS (cell
)->car
= newcar
;
552 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
553 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
555 register Lisp_Object cell
, newcdr
;
558 cell
= wrong_type_argument (Qconsp
, cell
);
561 XCONS (cell
)->cdr
= newcdr
;
565 /* Extract and set components of symbols */
567 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
569 register Lisp_Object symbol
;
571 Lisp_Object valcontents
;
572 CHECK_SYMBOL (symbol
, 0);
574 valcontents
= XSYMBOL (symbol
)->value
;
576 if (BUFFER_LOCAL_VALUEP (valcontents
)
577 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
578 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
580 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
583 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
585 register Lisp_Object symbol
;
587 CHECK_SYMBOL (symbol
, 0);
588 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
591 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
593 register Lisp_Object symbol
;
595 CHECK_SYMBOL (symbol
, 0);
596 if (NILP (symbol
) || EQ (symbol
, Qt
))
597 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
598 Fset (symbol
, Qunbound
);
602 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
604 register Lisp_Object symbol
;
606 CHECK_SYMBOL (symbol
, 0);
607 if (NILP (symbol
) || EQ (symbol
, Qt
))
608 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
609 XSYMBOL (symbol
)->function
= Qunbound
;
613 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
614 "Return SYMBOL's function definition. Error if that is void.")
616 register Lisp_Object symbol
;
618 CHECK_SYMBOL (symbol
, 0);
619 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
620 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
621 return XSYMBOL (symbol
)->function
;
624 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
626 register Lisp_Object symbol
;
628 CHECK_SYMBOL (symbol
, 0);
629 return XSYMBOL (symbol
)->plist
;
632 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
634 register Lisp_Object symbol
;
636 register Lisp_Object name
;
638 CHECK_SYMBOL (symbol
, 0);
639 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
643 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
644 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
646 register Lisp_Object symbol
, definition
;
648 CHECK_SYMBOL (symbol
, 0);
649 if (NILP (symbol
) || EQ (symbol
, Qt
))
650 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
651 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
652 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
654 XSYMBOL (symbol
)->function
= definition
;
655 /* Handle automatic advice activation */
656 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
658 call2 (Qad_activate
, symbol
, Qnil
);
659 definition
= XSYMBOL (symbol
)->function
;
664 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
665 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
666 Associates the function with the current load file, if any.")
668 register Lisp_Object symbol
, definition
;
670 CHECK_SYMBOL (symbol
, 0);
671 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
672 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
674 XSYMBOL (symbol
)->function
= definition
;
675 /* Handle automatic advice activation */
676 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
678 call2 (Qad_activate
, symbol
, Qnil
);
679 definition
= XSYMBOL (symbol
)->function
;
681 LOADHIST_ATTACH (symbol
);
685 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
686 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
688 register Lisp_Object symbol
, newplist
;
690 CHECK_SYMBOL (symbol
, 0);
691 XSYMBOL (symbol
)->plist
= newplist
;
696 /* Getting and setting values of symbols */
698 /* Given the raw contents of a symbol value cell,
699 return the Lisp value of the symbol.
700 This does not handle buffer-local variables; use
701 swap_in_symval_forwarding for that. */
704 do_symval_forwarding (valcontents
)
705 register Lisp_Object valcontents
;
707 register Lisp_Object val
;
709 if (MISCP (valcontents
))
710 switch (XMISCTYPE (valcontents
))
712 case Lisp_Misc_Intfwd
:
713 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
716 case Lisp_Misc_Boolfwd
:
717 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
719 case Lisp_Misc_Objfwd
:
720 return *XOBJFWD (valcontents
)->objvar
;
722 case Lisp_Misc_Buffer_Objfwd
:
723 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
724 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
726 case Lisp_Misc_Kboard_Objfwd
:
727 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
728 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
733 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
734 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
735 buffer-independent contents of the value cell: forwarded just one
736 step past the buffer-localness. */
739 store_symval_forwarding (symbol
, valcontents
, newval
)
741 register Lisp_Object valcontents
, newval
;
743 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
746 switch (XMISCTYPE (valcontents
))
748 case Lisp_Misc_Intfwd
:
749 CHECK_NUMBER (newval
, 1);
750 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
751 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
752 error ("Value out of range for variable `%s'",
753 XSYMBOL (symbol
)->name
->data
);
756 case Lisp_Misc_Boolfwd
:
757 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
760 case Lisp_Misc_Objfwd
:
761 *XOBJFWD (valcontents
)->objvar
= newval
;
764 case Lisp_Misc_Buffer_Objfwd
:
766 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
769 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
770 if (! NILP (type
) && ! NILP (newval
)
771 && XTYPE (newval
) != XINT (type
))
772 buffer_slot_type_mismatch (offset
);
774 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
778 case Lisp_Misc_Kboard_Objfwd
:
779 (*(Lisp_Object
*)((char *)current_kboard
780 + XKBOARD_OBJFWD (valcontents
)->offset
))
791 valcontents
= XSYMBOL (symbol
)->value
;
792 if (BUFFER_LOCAL_VALUEP (valcontents
)
793 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
794 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
796 XSYMBOL (symbol
)->value
= newval
;
800 /* Set up the buffer-local symbol SYMBOL for validity in the current
801 buffer. VALCONTENTS is the contents of its value cell.
802 Return the value forwarded one step past the buffer-local indicator. */
805 swap_in_symval_forwarding (symbol
, valcontents
)
806 Lisp_Object symbol
, valcontents
;
808 /* valcontents is a pointer to a struct resembling the cons
809 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
811 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
812 local_var_alist, that being the element whose car is this
813 variable. Or it can be a pointer to the
814 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
815 an element in its alist for this variable.
817 If the current buffer is not BUFFER, we store the current
818 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
819 appropriate alist element for the buffer now current and set up
820 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
821 element, and store into BUFFER.
823 Note that REALVALUE can be a forwarding pointer. */
825 register Lisp_Object tem1
;
826 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
828 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
830 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
832 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
833 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
835 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
836 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
837 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
839 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
842 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
845 /* Find the value of a symbol, returning Qunbound if it's not bound.
846 This is helpful for code which just wants to get a variable's value
847 if it has one, without signaling an error.
848 Note that it must not be possible to quit
849 within this function. Great care is required for this. */
852 find_symbol_value (symbol
)
855 register Lisp_Object valcontents
, tem1
;
856 register Lisp_Object val
;
857 CHECK_SYMBOL (symbol
, 0);
858 valcontents
= XSYMBOL (symbol
)->value
;
860 if (BUFFER_LOCAL_VALUEP (valcontents
)
861 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
862 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
864 if (MISCP (valcontents
))
866 switch (XMISCTYPE (valcontents
))
868 case Lisp_Misc_Intfwd
:
869 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
872 case Lisp_Misc_Boolfwd
:
873 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
875 case Lisp_Misc_Objfwd
:
876 return *XOBJFWD (valcontents
)->objvar
;
878 case Lisp_Misc_Buffer_Objfwd
:
879 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
880 + (char *)current_buffer
);
882 case Lisp_Misc_Kboard_Objfwd
:
883 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
884 + (char *)current_kboard
);
891 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
892 "Return SYMBOL's value. Error if that is void.")
898 val
= find_symbol_value (symbol
);
899 if (EQ (val
, Qunbound
))
900 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
905 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
906 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
908 register Lisp_Object symbol
, newval
;
910 return set_internal (symbol
, newval
, 0);
913 /* Stpre the value NEWVAL into SYMBOL.
914 If BINDFLAG is zero, then if this symbol is supposed to become
915 local in every buffer where it is set, then we make it local.
916 If BINDFLAG is nonzero, we don't do that. */
919 set_internal (symbol
, newval
, bindflag
)
920 register Lisp_Object symbol
, newval
;
923 int voide
= EQ (newval
, Qunbound
);
925 register Lisp_Object valcontents
, tem1
, current_alist_element
;
927 CHECK_SYMBOL (symbol
, 0);
928 if (NILP (symbol
) || EQ (symbol
, Qt
))
929 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
930 valcontents
= XSYMBOL (symbol
)->value
;
932 if (BUFFER_OBJFWDP (valcontents
))
934 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
935 register int mask
= XINT (*((Lisp_Object
*)
936 (idx
+ (char *)&buffer_local_flags
)));
938 current_buffer
->local_var_flags
|= mask
;
941 else if (BUFFER_LOCAL_VALUEP (valcontents
)
942 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
944 /* valcontents is actually a pointer to a struct resembling a cons,
945 with contents something like:
946 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
948 BUFFER is the last buffer for which this symbol's value was
951 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
952 local_var_alist, that being the element whose car is this
953 variable. Or it can be a pointer to the
954 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
955 have an element in its alist for this variable (that is, if
956 BUFFER sees the default value of this variable).
958 If we want to examine or set the value and BUFFER is current,
959 we just examine or set REALVALUE. If BUFFER is not current, we
960 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
961 then find the appropriate alist element for the buffer now
962 current and set up CURRENT-ALIST-ELEMENT. Then we set
963 REALVALUE out of that element, and store into BUFFER.
965 If we are setting the variable and the current buffer does
966 not have an alist entry for this variable, an alist entry is
969 Note that REALVALUE can be a forwarding pointer. Each time
970 it is examined or set, forwarding must be done. */
972 /* What value are we caching right now? */
973 current_alist_element
=
974 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
976 /* If the current buffer is not the buffer whose binding is
977 currently cached, or if it's a Lisp_Buffer_Local_Value and
978 we're looking at the default value, the cache is invalid; we
979 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
981 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
982 || (BUFFER_LOCAL_VALUEP (valcontents
)
983 && EQ (XCONS (current_alist_element
)->car
,
984 current_alist_element
)))
986 /* Write out the cached value for the old buffer; copy it
987 back to its alist element. This works if the current
988 buffer only sees the default value, too. */
989 Fsetcdr (current_alist_element
,
990 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
992 /* Find the new value for CURRENT-ALIST-ELEMENT. */
993 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
996 /* This buffer still sees the default value. */
998 /* If the variable is a Lisp_Some_Buffer_Local_Value,
999 or if this is `let' rather than `set',
1000 make CURRENT-ALIST-ELEMENT point to itself,
1001 indicating that we're seeing the default value. */
1002 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1003 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1005 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1006 give this buffer a new assoc for a local value and set
1007 CURRENT-ALIST-ELEMENT to point to that. */
1010 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1011 current_buffer
->local_var_alist
=
1012 Fcons (tem1
, current_buffer
->local_var_alist
);
1015 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1016 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
1019 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1020 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
1023 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1026 /* If storing void (making the symbol void), forward only through
1027 buffer-local indicator, not through Lisp_Objfwd, etc. */
1029 store_symval_forwarding (symbol
, Qnil
, newval
);
1031 store_symval_forwarding (symbol
, valcontents
, newval
);
1036 /* Access or set a buffer-local symbol's default value. */
1038 /* Return the default value of SYMBOL, but don't check for voidness.
1039 Return Qunbound if it is void. */
1042 default_value (symbol
)
1045 register Lisp_Object valcontents
;
1047 CHECK_SYMBOL (symbol
, 0);
1048 valcontents
= XSYMBOL (symbol
)->value
;
1050 /* For a built-in buffer-local variable, get the default value
1051 rather than letting do_symval_forwarding get the current value. */
1052 if (BUFFER_OBJFWDP (valcontents
))
1054 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1056 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1057 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1060 /* Handle user-created local variables. */
1061 if (BUFFER_LOCAL_VALUEP (valcontents
)
1062 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1064 /* If var is set up for a buffer that lacks a local value for it,
1065 the current value is nominally the default value.
1066 But the current value slot may be more up to date, since
1067 ordinary setq stores just that slot. So use that. */
1068 Lisp_Object current_alist_element
, alist_element_car
;
1069 current_alist_element
1070 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1071 alist_element_car
= XCONS (current_alist_element
)->car
;
1072 if (EQ (alist_element_car
, current_alist_element
))
1073 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1075 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1077 /* For other variables, get the current value. */
1078 return do_symval_forwarding (valcontents
);
1081 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1082 "Return t if SYMBOL has a non-void default value.\n\
1083 This is the value that is seen in buffers that do not have their own values\n\
1084 for this variable.")
1088 register Lisp_Object value
;
1090 value
= default_value (symbol
);
1091 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1094 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1095 "Return SYMBOL's default value.\n\
1096 This is the value that is seen in buffers that do not have their own values\n\
1097 for this variable. The default value is meaningful for variables with\n\
1098 local bindings in certain buffers.")
1102 register Lisp_Object value
;
1104 value
= default_value (symbol
);
1105 if (EQ (value
, Qunbound
))
1106 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1110 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1111 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1112 The default value is seen in buffers that do not have their own values\n\
1113 for this variable.")
1115 Lisp_Object symbol
, value
;
1117 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1119 CHECK_SYMBOL (symbol
, 0);
1120 valcontents
= XSYMBOL (symbol
)->value
;
1122 /* Handle variables like case-fold-search that have special slots
1123 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1125 if (BUFFER_OBJFWDP (valcontents
))
1127 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1128 register struct buffer
*b
;
1129 register int mask
= XINT (*((Lisp_Object
*)
1130 (idx
+ (char *)&buffer_local_flags
)));
1134 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1135 for (b
= all_buffers
; b
; b
= b
->next
)
1136 if (!(b
->local_var_flags
& mask
))
1137 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1142 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1143 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1144 return Fset (symbol
, value
);
1146 /* Store new value into the DEFAULT-VALUE slot */
1147 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1149 /* If that slot is current, we must set the REALVALUE slot too */
1150 current_alist_element
1151 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1152 alist_element_buffer
= Fcar (current_alist_element
);
1153 if (EQ (alist_element_buffer
, current_alist_element
))
1154 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1160 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1161 "Set the default value of variable VAR to VALUE.\n\
1162 VAR, the variable name, is literal (not evaluated);\n\
1163 VALUE is an expression and it is evaluated.\n\
1164 The default value of a variable is seen in buffers\n\
1165 that do not have their own values for the variable.\n\
1167 More generally, you can use multiple variables and values, as in\n\
1168 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1169 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1170 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1175 register Lisp_Object args_left
;
1176 register Lisp_Object val
, symbol
;
1177 struct gcpro gcpro1
;
1187 val
= Feval (Fcar (Fcdr (args_left
)));
1188 symbol
= Fcar (args_left
);
1189 Fset_default (symbol
, val
);
1190 args_left
= Fcdr (Fcdr (args_left
));
1192 while (!NILP (args_left
));
1198 /* Lisp functions for creating and removing buffer-local variables. */
1200 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1201 1, 1, "vMake Variable Buffer Local: ",
1202 "Make VARIABLE have a separate value for each buffer.\n\
1203 At any time, the value for the current buffer is in effect.\n\
1204 There is also a default value which is seen in any buffer which has not yet\n\
1205 set its own value.\n\
1206 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1207 for the current buffer if it was previously using the default value.\n\
1208 The function `default-value' gets the default value and `set-default' sets it.")
1210 register Lisp_Object variable
;
1212 register Lisp_Object tem
, valcontents
, newval
;
1214 CHECK_SYMBOL (variable
, 0);
1216 valcontents
= XSYMBOL (variable
)->value
;
1217 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1218 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1220 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1222 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1224 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1227 if (EQ (valcontents
, Qunbound
))
1228 XSYMBOL (variable
)->value
= Qnil
;
1229 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1230 XCONS (tem
)->car
= tem
;
1231 newval
= allocate_misc ();
1232 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1233 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1234 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1235 XSYMBOL (variable
)->value
= newval
;
1239 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1240 1, 1, "vMake Local Variable: ",
1241 "Make VARIABLE have a separate value in the current buffer.\n\
1242 Other buffers will continue to share a common default value.\n\
1243 \(The buffer-local value of VARIABLE starts out as the same value\n\
1244 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1245 See also `make-variable-buffer-local'.\n\n\
1246 If the variable is already arranged to become local when set,\n\
1247 this function causes a local value to exist for this buffer,\n\
1248 just as setting the variable would do.\n\
1250 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1251 Use `make-local-hook' instead.")
1253 register Lisp_Object variable
;
1255 register Lisp_Object tem
, valcontents
;
1257 CHECK_SYMBOL (variable
, 0);
1259 valcontents
= XSYMBOL (variable
)->value
;
1260 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1261 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1263 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1265 tem
= Fboundp (variable
);
1267 /* Make sure the symbol has a local value in this particular buffer,
1268 by setting it to the same value it already has. */
1269 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1272 /* Make sure symbol is set up to hold per-buffer values */
1273 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1276 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1277 XCONS (tem
)->car
= tem
;
1278 newval
= allocate_misc ();
1279 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1280 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1281 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1282 XSYMBOL (variable
)->value
= newval
;
1284 /* Make sure this buffer has its own value of symbol */
1285 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1288 /* Swap out any local binding for some other buffer, and make
1289 sure the current value is permanently recorded, if it's the
1291 find_symbol_value (variable
);
1293 current_buffer
->local_var_alist
1294 = Fcons (Fcons (variable
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
)->cdr
),
1295 current_buffer
->local_var_alist
);
1297 /* Make sure symbol does not think it is set up for this buffer;
1298 force it to look once again for this buffer's value */
1300 Lisp_Object
*pvalbuf
;
1302 valcontents
= XSYMBOL (variable
)->value
;
1304 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1305 if (current_buffer
== XBUFFER (*pvalbuf
))
1310 /* If the symbol forwards into a C variable, then swap in the
1311 variable for this buffer immediately. If C code modifies the
1312 variable before we swap in, then that new value will clobber the
1313 default value the next time we swap. */
1314 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->car
;
1315 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1316 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1321 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1322 1, 1, "vKill Local Variable: ",
1323 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1324 From now on the default value will apply in this buffer.")
1326 register Lisp_Object variable
;
1328 register Lisp_Object tem
, valcontents
;
1330 CHECK_SYMBOL (variable
, 0);
1332 valcontents
= XSYMBOL (variable
)->value
;
1334 if (BUFFER_OBJFWDP (valcontents
))
1336 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1337 register int mask
= XINT (*((Lisp_Object
*)
1338 (idx
+ (char *)&buffer_local_flags
)));
1342 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1343 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1344 current_buffer
->local_var_flags
&= ~mask
;
1349 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1350 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1353 /* Get rid of this buffer's alist element, if any */
1355 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1357 current_buffer
->local_var_alist
1358 = Fdelq (tem
, current_buffer
->local_var_alist
);
1360 /* If the symbol is set up for the current buffer, recompute its
1361 value. We have to do it now, or else forwarded objects won't
1364 Lisp_Object
*pvalbuf
;
1365 valcontents
= XSYMBOL (variable
)->value
;
1366 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1367 if (current_buffer
== XBUFFER (*pvalbuf
))
1370 find_symbol_value (variable
);
1377 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1379 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1380 BUFFER defaults to the current buffer.")
1382 register Lisp_Object variable
, buffer
;
1384 Lisp_Object valcontents
;
1385 register struct buffer
*buf
;
1388 buf
= current_buffer
;
1391 CHECK_BUFFER (buffer
, 0);
1392 buf
= XBUFFER (buffer
);
1395 CHECK_SYMBOL (variable
, 0);
1397 valcontents
= XSYMBOL (variable
)->value
;
1398 if (BUFFER_LOCAL_VALUEP (valcontents
)
1399 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1401 Lisp_Object tail
, elt
;
1402 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1404 elt
= XCONS (tail
)->car
;
1405 if (EQ (variable
, XCONS (elt
)->car
))
1409 if (BUFFER_OBJFWDP (valcontents
))
1411 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1412 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1413 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1419 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1421 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1422 BUFFER defaults to the current buffer.")
1424 register Lisp_Object variable
, buffer
;
1426 Lisp_Object valcontents
;
1427 register struct buffer
*buf
;
1430 buf
= current_buffer
;
1433 CHECK_BUFFER (buffer
, 0);
1434 buf
= XBUFFER (buffer
);
1437 CHECK_SYMBOL (variable
, 0);
1439 valcontents
= XSYMBOL (variable
)->value
;
1441 /* This means that make-variable-buffer-local was done. */
1442 if (BUFFER_LOCAL_VALUEP (valcontents
))
1444 /* All these slots become local if they are set. */
1445 if (BUFFER_OBJFWDP (valcontents
))
1447 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1449 Lisp_Object tail
, elt
;
1450 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1452 elt
= XCONS (tail
)->car
;
1453 if (EQ (variable
, XCONS (elt
)->car
))
1460 /* Find the function at the end of a chain of symbol function indirections. */
1462 /* If OBJECT is a symbol, find the end of its function chain and
1463 return the value found there. If OBJECT is not a symbol, just
1464 return it. If there is a cycle in the function chain, signal a
1465 cyclic-function-indirection error.
1467 This is like Findirect_function, except that it doesn't signal an
1468 error if the chain ends up unbound. */
1470 indirect_function (object
)
1471 register Lisp_Object object
;
1473 Lisp_Object tortoise
, hare
;
1475 hare
= tortoise
= object
;
1479 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1481 hare
= XSYMBOL (hare
)->function
;
1482 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1484 hare
= XSYMBOL (hare
)->function
;
1486 tortoise
= XSYMBOL (tortoise
)->function
;
1488 if (EQ (hare
, tortoise
))
1489 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1495 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1496 "Return the function at the end of OBJECT's function chain.\n\
1497 If OBJECT is a symbol, follow all function indirections and return the final\n\
1498 function binding.\n\
1499 If OBJECT is not a symbol, just return it.\n\
1500 Signal a void-function error if the final symbol is unbound.\n\
1501 Signal a cyclic-function-indirection error if there is a loop in the\n\
1502 function chain of symbols.")
1504 register Lisp_Object object
;
1508 result
= indirect_function (object
);
1510 if (EQ (result
, Qunbound
))
1511 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1515 /* Extract and set vector and string elements */
1517 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1518 "Return the element of ARRAY at index IDX.\n\
1519 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1520 or a byte-code object. IDX starts at 0.")
1522 register Lisp_Object array
;
1525 register int idxval
;
1527 CHECK_NUMBER (idx
, 1);
1528 idxval
= XINT (idx
);
1529 if (STRINGP (array
))
1532 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1533 args_out_of_range (array
, idx
);
1534 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1537 else if (BOOL_VECTOR_P (array
))
1541 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1542 args_out_of_range (array
, idx
);
1544 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1545 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1547 else if (CHAR_TABLE_P (array
))
1552 args_out_of_range (array
, idx
);
1553 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1555 /* For ASCII and 8-bit European characters, the element is
1556 stored in the top table. */
1557 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1559 val
= XCHAR_TABLE (array
)->defalt
;
1560 while (NILP (val
)) /* Follow parents until we find some value. */
1562 array
= XCHAR_TABLE (array
)->parent
;
1565 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1567 val
= XCHAR_TABLE (array
)->defalt
;
1574 Lisp_Object sub_table
;
1576 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1577 if (code
[0] != CHARSET_COMPOSITION
)
1579 if (code
[1] < 32) code
[1] = -1;
1580 else if (code
[2] < 32) code
[2] = -1;
1582 /* Here, the possible range of CODE[0] (== charset ID) is
1583 128..MAX_CHARSET. Since the top level char table contains
1584 data for multibyte characters after 256th element, we must
1585 increment CODE[0] by 128 to get a correct index. */
1587 code
[3] = -1; /* anchor */
1589 try_parent_char_table
:
1591 for (i
= 0; code
[i
] >= 0; i
++)
1593 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1594 if (SUB_CHAR_TABLE_P (val
))
1599 val
= XCHAR_TABLE (sub_table
)->defalt
;
1602 array
= XCHAR_TABLE (array
)->parent
;
1604 goto try_parent_char_table
;
1609 /* Here, VAL is a sub char table. We try the default value
1611 val
= XCHAR_TABLE (val
)->defalt
;
1614 array
= XCHAR_TABLE (array
)->parent
;
1616 goto try_parent_char_table
;
1624 if (VECTORP (array
))
1625 size
= XVECTOR (array
)->size
;
1626 else if (COMPILEDP (array
))
1627 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1629 wrong_type_argument (Qarrayp
, array
);
1631 if (idxval
< 0 || idxval
>= size
)
1632 args_out_of_range (array
, idx
);
1633 return XVECTOR (array
)->contents
[idxval
];
1637 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1638 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1639 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1641 (array
, idx
, newelt
)
1642 register Lisp_Object array
;
1643 Lisp_Object idx
, newelt
;
1645 register int idxval
;
1647 CHECK_NUMBER (idx
, 1);
1648 idxval
= XINT (idx
);
1649 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1650 && ! CHAR_TABLE_P (array
))
1651 array
= wrong_type_argument (Qarrayp
, array
);
1652 CHECK_IMPURE (array
);
1654 if (VECTORP (array
))
1656 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1657 args_out_of_range (array
, idx
);
1658 XVECTOR (array
)->contents
[idxval
] = newelt
;
1660 else if (BOOL_VECTOR_P (array
))
1664 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1665 args_out_of_range (array
, idx
);
1667 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1669 if (! NILP (newelt
))
1670 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1672 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1673 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1675 else if (CHAR_TABLE_P (array
))
1680 args_out_of_range (array
, idx
);
1681 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1682 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1688 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1689 if (code
[0] != CHARSET_COMPOSITION
)
1691 if (code
[1] < 32) code
[1] = -1;
1692 else if (code
[2] < 32) code
[2] = -1;
1694 /* See the comment of the corresponding part in Faref. */
1696 code
[3] = -1; /* anchor */
1697 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1699 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1700 if (SUB_CHAR_TABLE_P (val
))
1706 /* VAL is a leaf. Create a sub char table with the
1707 default value VAL or XCHAR_TABLE (array)->defalt
1708 and look into it. */
1710 temp
= make_sub_char_table (NILP (val
)
1711 ? XCHAR_TABLE (array
)->defalt
1713 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1717 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1722 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1723 args_out_of_range (array
, idx
);
1724 CHECK_NUMBER (newelt
, 2);
1725 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1731 /* Arithmetic functions */
1733 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1736 arithcompare (num1
, num2
, comparison
)
1737 Lisp_Object num1
, num2
;
1738 enum comparison comparison
;
1743 #ifdef LISP_FLOAT_TYPE
1744 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1745 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1747 if (FLOATP (num1
) || FLOATP (num2
))
1750 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1751 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1754 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1755 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1756 #endif /* LISP_FLOAT_TYPE */
1761 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1766 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1771 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1776 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1781 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1786 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1795 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1796 "Return t if two args, both numbers or markers, are equal.")
1798 register Lisp_Object num1
, num2
;
1800 return arithcompare (num1
, num2
, equal
);
1803 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1804 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1806 register Lisp_Object num1
, num2
;
1808 return arithcompare (num1
, num2
, less
);
1811 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1812 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1814 register Lisp_Object num1
, num2
;
1816 return arithcompare (num1
, num2
, grtr
);
1819 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1820 "Return t if first arg is less than or equal to second arg.\n\
1821 Both must be numbers or markers.")
1823 register Lisp_Object num1
, num2
;
1825 return arithcompare (num1
, num2
, less_or_equal
);
1828 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1829 "Return t if first arg is greater than or equal to second arg.\n\
1830 Both must be numbers or markers.")
1832 register Lisp_Object num1
, num2
;
1834 return arithcompare (num1
, num2
, grtr_or_equal
);
1837 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1838 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1840 register Lisp_Object num1
, num2
;
1842 return arithcompare (num1
, num2
, notequal
);
1845 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1847 register Lisp_Object number
;
1849 #ifdef LISP_FLOAT_TYPE
1850 CHECK_NUMBER_OR_FLOAT (number
, 0);
1852 if (FLOATP (number
))
1854 if (XFLOAT(number
)->data
== 0.0)
1859 CHECK_NUMBER (number
, 0);
1860 #endif /* LISP_FLOAT_TYPE */
1867 /* Convert between long values and pairs of Lisp integers. */
1873 unsigned int top
= i
>> 16;
1874 unsigned int bot
= i
& 0xFFFF;
1876 return make_number (bot
);
1877 if (top
== (unsigned long)-1 >> 16)
1878 return Fcons (make_number (-1), make_number (bot
));
1879 return Fcons (make_number (top
), make_number (bot
));
1886 Lisp_Object top
, bot
;
1889 top
= XCONS (c
)->car
;
1890 bot
= XCONS (c
)->cdr
;
1892 bot
= XCONS (bot
)->car
;
1893 return ((XINT (top
) << 16) | XINT (bot
));
1896 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1897 "Convert NUMBER to a string by printing it in decimal.\n\
1898 Uses a minus sign if negative.\n\
1899 NUMBER may be an integer or a floating point number.")
1903 char buffer
[VALBITS
];
1905 #ifndef LISP_FLOAT_TYPE
1906 CHECK_NUMBER (number
, 0);
1908 CHECK_NUMBER_OR_FLOAT (number
, 0);
1910 if (FLOATP (number
))
1912 char pigbuf
[350]; /* see comments in float_to_string */
1914 float_to_string (pigbuf
, XFLOAT(number
)->data
);
1915 return build_string (pigbuf
);
1917 #endif /* LISP_FLOAT_TYPE */
1919 if (sizeof (int) == sizeof (EMACS_INT
))
1920 sprintf (buffer
, "%d", XINT (number
));
1921 else if (sizeof (long) == sizeof (EMACS_INT
))
1922 sprintf (buffer
, "%ld", XINT (number
));
1925 return build_string (buffer
);
1929 digit_to_number (character
, base
)
1930 int character
, base
;
1934 if (character
>= '0' && character
<= '9')
1935 digit
= character
- '0';
1936 else if (character
>= 'a' && character
<= 'z')
1937 digit
= character
- 'a' + 10;
1938 else if (character
>= 'A' && character
<= 'Z')
1939 digit
= character
- 'A' + 10;
1949 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
1950 "Convert STRING to a number by parsing it as a decimal number.\n\
1951 This parses both integers and floating point numbers.\n\
1952 It ignores leading spaces and tabs.\n\
1954 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
1955 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
1956 Floating point numbers always use base 10.")
1958 register Lisp_Object string
, base
;
1960 register unsigned char *p
;
1961 register int b
, digit
, v
= 0;
1964 CHECK_STRING (string
, 0);
1970 CHECK_NUMBER (base
, 1);
1972 if (b
< 2 || b
> 16)
1973 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
1976 p
= XSTRING (string
)->data
;
1978 /* Skip any whitespace at the front of the number. Some versions of
1979 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1980 while (*p
== ' ' || *p
== '\t')
1991 #ifdef LISP_FLOAT_TYPE
1992 if (isfloat_string (p
))
1993 return make_float (negative
* atof (p
));
1994 #endif /* LISP_FLOAT_TYPE */
1998 int digit
= digit_to_number (*p
++, b
);
2004 return make_number (negative
* v
);
2009 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2011 extern Lisp_Object
float_arith_driver ();
2012 extern Lisp_Object
fmod_float ();
2015 arith_driver (code
, nargs
, args
)
2018 register Lisp_Object
*args
;
2020 register Lisp_Object val
;
2021 register int argnum
;
2022 register EMACS_INT accum
;
2023 register EMACS_INT next
;
2025 switch (SWITCH_ENUM_CAST (code
))
2038 for (argnum
= 0; argnum
< nargs
; argnum
++)
2040 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2041 #ifdef LISP_FLOAT_TYPE
2042 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2044 if (FLOATP (val
)) /* time to do serious math */
2045 return (float_arith_driver ((double) accum
, argnum
, code
,
2048 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2049 #endif /* LISP_FLOAT_TYPE */
2050 args
[argnum
] = val
; /* runs into a compiler bug. */
2051 next
= XINT (args
[argnum
]);
2052 switch (SWITCH_ENUM_CAST (code
))
2054 case Aadd
: accum
+= next
; break;
2056 if (!argnum
&& nargs
!= 1)
2060 case Amult
: accum
*= next
; break;
2062 if (!argnum
) accum
= next
;
2066 Fsignal (Qarith_error
, Qnil
);
2070 case Alogand
: accum
&= next
; break;
2071 case Alogior
: accum
|= next
; break;
2072 case Alogxor
: accum
^= next
; break;
2073 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2074 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2078 XSETINT (val
, accum
);
2083 #define isnan(x) ((x) != (x))
2085 #ifdef LISP_FLOAT_TYPE
2088 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2090 register int argnum
;
2093 register Lisp_Object
*args
;
2095 register Lisp_Object val
;
2098 for (; argnum
< nargs
; argnum
++)
2100 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2101 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2105 next
= XFLOAT (val
)->data
;
2109 args
[argnum
] = val
; /* runs into a compiler bug. */
2110 next
= XINT (args
[argnum
]);
2112 switch (SWITCH_ENUM_CAST (code
))
2118 if (!argnum
&& nargs
!= 1)
2130 if (! IEEE_FLOATING_POINT
&& next
== 0)
2131 Fsignal (Qarith_error
, Qnil
);
2138 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2140 if (!argnum
|| isnan (next
) || next
> accum
)
2144 if (!argnum
|| isnan (next
) || next
< accum
)
2150 return make_float (accum
);
2152 #endif /* LISP_FLOAT_TYPE */
2154 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2155 "Return sum of any number of arguments, which are numbers or markers.")
2160 return arith_driver (Aadd
, nargs
, args
);
2163 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2164 "Negate number or subtract numbers or markers.\n\
2165 With one arg, negates it. With more than one arg,\n\
2166 subtracts all but the first from the first.")
2171 return arith_driver (Asub
, nargs
, args
);
2174 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2175 "Returns product of any number of arguments, which are numbers or markers.")
2180 return arith_driver (Amult
, nargs
, args
);
2183 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2184 "Returns first argument divided by all the remaining arguments.\n\
2185 The arguments must be numbers or markers.")
2190 return arith_driver (Adiv
, nargs
, args
);
2193 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2194 "Returns remainder of X divided by Y.\n\
2195 Both must be integers or markers.")
2197 register Lisp_Object x
, y
;
2201 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2202 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2204 if (XFASTINT (y
) == 0)
2205 Fsignal (Qarith_error
, Qnil
);
2207 XSETINT (val
, XINT (x
) % XINT (y
));
2221 /* If the magnitude of the result exceeds that of the divisor, or
2222 the sign of the result does not agree with that of the dividend,
2223 iterate with the reduced value. This does not yield a
2224 particularly accurate result, but at least it will be in the
2225 range promised by fmod. */
2227 r
-= f2
* floor (r
/ f2
);
2228 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2232 #endif /* ! HAVE_FMOD */
2234 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2235 "Returns X modulo Y.\n\
2236 The result falls between zero (inclusive) and Y (exclusive).\n\
2237 Both X and Y must be numbers or markers.")
2239 register Lisp_Object x
, y
;
2244 #ifdef LISP_FLOAT_TYPE
2245 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2246 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2248 if (FLOATP (x
) || FLOATP (y
))
2249 return fmod_float (x
, y
);
2251 #else /* not LISP_FLOAT_TYPE */
2252 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2253 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2254 #endif /* not LISP_FLOAT_TYPE */
2260 Fsignal (Qarith_error
, Qnil
);
2264 /* If the "remainder" comes out with the wrong sign, fix it. */
2265 if (i2
< 0 ? i1
> 0 : i1
< 0)
2272 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2273 "Return largest of all the arguments (which must be numbers or markers).\n\
2274 The value is always a number; markers are converted to numbers.")
2279 return arith_driver (Amax
, nargs
, args
);
2282 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2283 "Return smallest of all the arguments (which must be numbers or markers).\n\
2284 The value is always a number; markers are converted to numbers.")
2289 return arith_driver (Amin
, nargs
, args
);
2292 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2293 "Return bitwise-and of all the arguments.\n\
2294 Arguments may be integers, or markers converted to integers.")
2299 return arith_driver (Alogand
, nargs
, args
);
2302 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2303 "Return bitwise-or of all the arguments.\n\
2304 Arguments may be integers, or markers converted to integers.")
2309 return arith_driver (Alogior
, nargs
, args
);
2312 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2313 "Return bitwise-exclusive-or of all the arguments.\n\
2314 Arguments may be integers, or markers converted to integers.")
2319 return arith_driver (Alogxor
, nargs
, args
);
2322 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2323 "Return VALUE with its bits shifted left by COUNT.\n\
2324 If COUNT is negative, shifting is actually to the right.\n\
2325 In this case, the sign bit is duplicated.")
2327 register Lisp_Object value
, count
;
2329 register Lisp_Object val
;
2331 CHECK_NUMBER (value
, 0);
2332 CHECK_NUMBER (count
, 1);
2334 if (XINT (count
) > 0)
2335 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2337 XSETINT (val
, XINT (value
) >> -XINT (count
));
2341 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2342 "Return VALUE with its bits shifted left by COUNT.\n\
2343 If COUNT is negative, shifting is actually to the right.\n\
2344 In this case, zeros are shifted in on the left.")
2346 register Lisp_Object value
, count
;
2348 register Lisp_Object val
;
2350 CHECK_NUMBER (value
, 0);
2351 CHECK_NUMBER (count
, 1);
2353 if (XINT (count
) > 0)
2354 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2356 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2360 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2361 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2362 Markers are converted to integers.")
2364 register Lisp_Object number
;
2366 #ifdef LISP_FLOAT_TYPE
2367 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2369 if (FLOATP (number
))
2370 return (make_float (1.0 + XFLOAT (number
)->data
));
2372 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2373 #endif /* LISP_FLOAT_TYPE */
2375 XSETINT (number
, XINT (number
) + 1);
2379 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2380 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2381 Markers are converted to integers.")
2383 register Lisp_Object number
;
2385 #ifdef LISP_FLOAT_TYPE
2386 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2388 if (FLOATP (number
))
2389 return (make_float (-1.0 + XFLOAT (number
)->data
));
2391 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2392 #endif /* LISP_FLOAT_TYPE */
2394 XSETINT (number
, XINT (number
) - 1);
2398 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2399 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2401 register Lisp_Object number
;
2403 CHECK_NUMBER (number
, 0);
2404 XSETINT (number
, ~XINT (number
));
2411 Lisp_Object error_tail
, arith_tail
;
2413 Qquote
= intern ("quote");
2414 Qlambda
= intern ("lambda");
2415 Qsubr
= intern ("subr");
2416 Qerror_conditions
= intern ("error-conditions");
2417 Qerror_message
= intern ("error-message");
2418 Qtop_level
= intern ("top-level");
2420 Qerror
= intern ("error");
2421 Qquit
= intern ("quit");
2422 Qwrong_type_argument
= intern ("wrong-type-argument");
2423 Qargs_out_of_range
= intern ("args-out-of-range");
2424 Qvoid_function
= intern ("void-function");
2425 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2426 Qvoid_variable
= intern ("void-variable");
2427 Qsetting_constant
= intern ("setting-constant");
2428 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2430 Qinvalid_function
= intern ("invalid-function");
2431 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2432 Qno_catch
= intern ("no-catch");
2433 Qend_of_file
= intern ("end-of-file");
2434 Qarith_error
= intern ("arith-error");
2435 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2436 Qend_of_buffer
= intern ("end-of-buffer");
2437 Qbuffer_read_only
= intern ("buffer-read-only");
2438 Qmark_inactive
= intern ("mark-inactive");
2440 Qlistp
= intern ("listp");
2441 Qconsp
= intern ("consp");
2442 Qsymbolp
= intern ("symbolp");
2443 Qintegerp
= intern ("integerp");
2444 Qnatnump
= intern ("natnump");
2445 Qwholenump
= intern ("wholenump");
2446 Qstringp
= intern ("stringp");
2447 Qarrayp
= intern ("arrayp");
2448 Qsequencep
= intern ("sequencep");
2449 Qbufferp
= intern ("bufferp");
2450 Qvectorp
= intern ("vectorp");
2451 Qchar_or_string_p
= intern ("char-or-string-p");
2452 Qmarkerp
= intern ("markerp");
2453 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2454 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2455 Qboundp
= intern ("boundp");
2456 Qfboundp
= intern ("fboundp");
2458 #ifdef LISP_FLOAT_TYPE
2459 Qfloatp
= intern ("floatp");
2460 Qnumberp
= intern ("numberp");
2461 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2462 #endif /* LISP_FLOAT_TYPE */
2464 Qchar_table_p
= intern ("char-table-p");
2465 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2467 Qcdr
= intern ("cdr");
2469 /* Handle automatic advice activation */
2470 Qad_advice_info
= intern ("ad-advice-info");
2471 Qad_activate
= intern ("ad-activate");
2473 error_tail
= Fcons (Qerror
, Qnil
);
2475 /* ERROR is used as a signaler for random errors for which nothing else is right */
2477 Fput (Qerror
, Qerror_conditions
,
2479 Fput (Qerror
, Qerror_message
,
2480 build_string ("error"));
2482 Fput (Qquit
, Qerror_conditions
,
2483 Fcons (Qquit
, Qnil
));
2484 Fput (Qquit
, Qerror_message
,
2485 build_string ("Quit"));
2487 Fput (Qwrong_type_argument
, Qerror_conditions
,
2488 Fcons (Qwrong_type_argument
, error_tail
));
2489 Fput (Qwrong_type_argument
, Qerror_message
,
2490 build_string ("Wrong type argument"));
2492 Fput (Qargs_out_of_range
, Qerror_conditions
,
2493 Fcons (Qargs_out_of_range
, error_tail
));
2494 Fput (Qargs_out_of_range
, Qerror_message
,
2495 build_string ("Args out of range"));
2497 Fput (Qvoid_function
, Qerror_conditions
,
2498 Fcons (Qvoid_function
, error_tail
));
2499 Fput (Qvoid_function
, Qerror_message
,
2500 build_string ("Symbol's function definition is void"));
2502 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2503 Fcons (Qcyclic_function_indirection
, error_tail
));
2504 Fput (Qcyclic_function_indirection
, Qerror_message
,
2505 build_string ("Symbol's chain of function indirections contains a loop"));
2507 Fput (Qvoid_variable
, Qerror_conditions
,
2508 Fcons (Qvoid_variable
, error_tail
));
2509 Fput (Qvoid_variable
, Qerror_message
,
2510 build_string ("Symbol's value as variable is void"));
2512 Fput (Qsetting_constant
, Qerror_conditions
,
2513 Fcons (Qsetting_constant
, error_tail
));
2514 Fput (Qsetting_constant
, Qerror_message
,
2515 build_string ("Attempt to set a constant symbol"));
2517 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2518 Fcons (Qinvalid_read_syntax
, error_tail
));
2519 Fput (Qinvalid_read_syntax
, Qerror_message
,
2520 build_string ("Invalid read syntax"));
2522 Fput (Qinvalid_function
, Qerror_conditions
,
2523 Fcons (Qinvalid_function
, error_tail
));
2524 Fput (Qinvalid_function
, Qerror_message
,
2525 build_string ("Invalid function"));
2527 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2528 Fcons (Qwrong_number_of_arguments
, error_tail
));
2529 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2530 build_string ("Wrong number of arguments"));
2532 Fput (Qno_catch
, Qerror_conditions
,
2533 Fcons (Qno_catch
, error_tail
));
2534 Fput (Qno_catch
, Qerror_message
,
2535 build_string ("No catch for tag"));
2537 Fput (Qend_of_file
, Qerror_conditions
,
2538 Fcons (Qend_of_file
, error_tail
));
2539 Fput (Qend_of_file
, Qerror_message
,
2540 build_string ("End of file during parsing"));
2542 arith_tail
= Fcons (Qarith_error
, error_tail
);
2543 Fput (Qarith_error
, Qerror_conditions
,
2545 Fput (Qarith_error
, Qerror_message
,
2546 build_string ("Arithmetic error"));
2548 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2549 Fcons (Qbeginning_of_buffer
, error_tail
));
2550 Fput (Qbeginning_of_buffer
, Qerror_message
,
2551 build_string ("Beginning of buffer"));
2553 Fput (Qend_of_buffer
, Qerror_conditions
,
2554 Fcons (Qend_of_buffer
, error_tail
));
2555 Fput (Qend_of_buffer
, Qerror_message
,
2556 build_string ("End of buffer"));
2558 Fput (Qbuffer_read_only
, Qerror_conditions
,
2559 Fcons (Qbuffer_read_only
, error_tail
));
2560 Fput (Qbuffer_read_only
, Qerror_message
,
2561 build_string ("Buffer is read-only"));
2563 #ifdef LISP_FLOAT_TYPE
2564 Qrange_error
= intern ("range-error");
2565 Qdomain_error
= intern ("domain-error");
2566 Qsingularity_error
= intern ("singularity-error");
2567 Qoverflow_error
= intern ("overflow-error");
2568 Qunderflow_error
= intern ("underflow-error");
2570 Fput (Qdomain_error
, Qerror_conditions
,
2571 Fcons (Qdomain_error
, arith_tail
));
2572 Fput (Qdomain_error
, Qerror_message
,
2573 build_string ("Arithmetic domain error"));
2575 Fput (Qrange_error
, Qerror_conditions
,
2576 Fcons (Qrange_error
, arith_tail
));
2577 Fput (Qrange_error
, Qerror_message
,
2578 build_string ("Arithmetic range error"));
2580 Fput (Qsingularity_error
, Qerror_conditions
,
2581 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2582 Fput (Qsingularity_error
, Qerror_message
,
2583 build_string ("Arithmetic singularity error"));
2585 Fput (Qoverflow_error
, Qerror_conditions
,
2586 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2587 Fput (Qoverflow_error
, Qerror_message
,
2588 build_string ("Arithmetic overflow error"));
2590 Fput (Qunderflow_error
, Qerror_conditions
,
2591 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2592 Fput (Qunderflow_error
, Qerror_message
,
2593 build_string ("Arithmetic underflow error"));
2595 staticpro (&Qrange_error
);
2596 staticpro (&Qdomain_error
);
2597 staticpro (&Qsingularity_error
);
2598 staticpro (&Qoverflow_error
);
2599 staticpro (&Qunderflow_error
);
2600 #endif /* LISP_FLOAT_TYPE */
2604 staticpro (&Qquote
);
2605 staticpro (&Qlambda
);
2607 staticpro (&Qunbound
);
2608 staticpro (&Qerror_conditions
);
2609 staticpro (&Qerror_message
);
2610 staticpro (&Qtop_level
);
2612 staticpro (&Qerror
);
2614 staticpro (&Qwrong_type_argument
);
2615 staticpro (&Qargs_out_of_range
);
2616 staticpro (&Qvoid_function
);
2617 staticpro (&Qcyclic_function_indirection
);
2618 staticpro (&Qvoid_variable
);
2619 staticpro (&Qsetting_constant
);
2620 staticpro (&Qinvalid_read_syntax
);
2621 staticpro (&Qwrong_number_of_arguments
);
2622 staticpro (&Qinvalid_function
);
2623 staticpro (&Qno_catch
);
2624 staticpro (&Qend_of_file
);
2625 staticpro (&Qarith_error
);
2626 staticpro (&Qbeginning_of_buffer
);
2627 staticpro (&Qend_of_buffer
);
2628 staticpro (&Qbuffer_read_only
);
2629 staticpro (&Qmark_inactive
);
2631 staticpro (&Qlistp
);
2632 staticpro (&Qconsp
);
2633 staticpro (&Qsymbolp
);
2634 staticpro (&Qintegerp
);
2635 staticpro (&Qnatnump
);
2636 staticpro (&Qwholenump
);
2637 staticpro (&Qstringp
);
2638 staticpro (&Qarrayp
);
2639 staticpro (&Qsequencep
);
2640 staticpro (&Qbufferp
);
2641 staticpro (&Qvectorp
);
2642 staticpro (&Qchar_or_string_p
);
2643 staticpro (&Qmarkerp
);
2644 staticpro (&Qbuffer_or_string_p
);
2645 staticpro (&Qinteger_or_marker_p
);
2646 #ifdef LISP_FLOAT_TYPE
2647 staticpro (&Qfloatp
);
2648 staticpro (&Qnumberp
);
2649 staticpro (&Qnumber_or_marker_p
);
2650 #endif /* LISP_FLOAT_TYPE */
2651 staticpro (&Qchar_table_p
);
2652 staticpro (&Qvector_or_char_table_p
);
2654 staticpro (&Qboundp
);
2655 staticpro (&Qfboundp
);
2657 staticpro (&Qad_advice_info
);
2658 staticpro (&Qad_activate
);
2660 /* Types that type-of returns. */
2661 Qinteger
= intern ("integer");
2662 Qsymbol
= intern ("symbol");
2663 Qstring
= intern ("string");
2664 Qcons
= intern ("cons");
2665 Qmarker
= intern ("marker");
2666 Qoverlay
= intern ("overlay");
2667 Qfloat
= intern ("float");
2668 Qwindow_configuration
= intern ("window-configuration");
2669 Qprocess
= intern ("process");
2670 Qwindow
= intern ("window");
2671 /* Qsubr = intern ("subr"); */
2672 Qcompiled_function
= intern ("compiled-function");
2673 Qbuffer
= intern ("buffer");
2674 Qframe
= intern ("frame");
2675 Qvector
= intern ("vector");
2676 Qchar_table
= intern ("char-table");
2677 Qbool_vector
= intern ("bool-vector");
2679 staticpro (&Qinteger
);
2680 staticpro (&Qsymbol
);
2681 staticpro (&Qstring
);
2683 staticpro (&Qmarker
);
2684 staticpro (&Qoverlay
);
2685 staticpro (&Qfloat
);
2686 staticpro (&Qwindow_configuration
);
2687 staticpro (&Qprocess
);
2688 staticpro (&Qwindow
);
2689 /* staticpro (&Qsubr); */
2690 staticpro (&Qcompiled_function
);
2691 staticpro (&Qbuffer
);
2692 staticpro (&Qframe
);
2693 staticpro (&Qvector
);
2694 staticpro (&Qchar_table
);
2695 staticpro (&Qbool_vector
);
2699 defsubr (&Stype_of
);
2704 defsubr (&Sintegerp
);
2705 defsubr (&Sinteger_or_marker_p
);
2706 defsubr (&Snumberp
);
2707 defsubr (&Snumber_or_marker_p
);
2708 #ifdef LISP_FLOAT_TYPE
2710 #endif /* LISP_FLOAT_TYPE */
2711 defsubr (&Snatnump
);
2712 defsubr (&Ssymbolp
);
2713 defsubr (&Sstringp
);
2714 defsubr (&Svectorp
);
2715 defsubr (&Schar_table_p
);
2716 defsubr (&Svector_or_char_table_p
);
2717 defsubr (&Sbool_vector_p
);
2719 defsubr (&Ssequencep
);
2720 defsubr (&Sbufferp
);
2721 defsubr (&Smarkerp
);
2723 defsubr (&Sbyte_code_function_p
);
2724 defsubr (&Schar_or_string_p
);
2727 defsubr (&Scar_safe
);
2728 defsubr (&Scdr_safe
);
2731 defsubr (&Ssymbol_function
);
2732 defsubr (&Sindirect_function
);
2733 defsubr (&Ssymbol_plist
);
2734 defsubr (&Ssymbol_name
);
2735 defsubr (&Smakunbound
);
2736 defsubr (&Sfmakunbound
);
2738 defsubr (&Sfboundp
);
2740 defsubr (&Sdefalias
);
2741 defsubr (&Ssetplist
);
2742 defsubr (&Ssymbol_value
);
2744 defsubr (&Sdefault_boundp
);
2745 defsubr (&Sdefault_value
);
2746 defsubr (&Sset_default
);
2747 defsubr (&Ssetq_default
);
2748 defsubr (&Smake_variable_buffer_local
);
2749 defsubr (&Smake_local_variable
);
2750 defsubr (&Skill_local_variable
);
2751 defsubr (&Slocal_variable_p
);
2752 defsubr (&Slocal_variable_if_set_p
);
2755 defsubr (&Snumber_to_string
);
2756 defsubr (&Sstring_to_number
);
2757 defsubr (&Seqlsign
);
2781 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2788 #if defined(USG) && !defined(POSIX_SIGNALS)
2789 /* USG systems forget handlers when they are used;
2790 must reestablish each time */
2791 signal (signo
, arith_error
);
2794 /* VMS systems are like USG. */
2795 signal (signo
, arith_error
);
2799 #else /* not BSD4_1 */
2800 sigsetmask (SIGEMPTYMASK
);
2801 #endif /* not BSD4_1 */
2803 Fsignal (Qarith_error
, Qnil
);
2808 /* Don't do this if just dumping out.
2809 We don't want to call `signal' in this case
2810 so that we don't have trouble with dumping
2811 signal-delivering routines in an inconsistent state. */
2815 #endif /* CANNOT_DUMP */
2816 signal (SIGFPE
, arith_error
);
2819 signal (SIGEMT
, arith_error
);