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. */
26 /* Put this before lisp.h so that lisp.h can define DBL_DIG if not defined. */
27 #ifdef LISP_FLOAT_TYPE
42 #include "syssignal.h"
44 #ifdef LISP_FLOAT_TYPE
50 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
51 #ifndef IEEE_FLOATING_POINT
52 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
53 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
54 #define IEEE_FLOATING_POINT 1
56 #define IEEE_FLOATING_POINT 0
60 /* Work around a problem that happens because math.h on hpux 7
61 defines two static variables--which, in Emacs, are not really static,
62 because `static' is defined as nothing. The problem is that they are
63 here, in floatfns.c, and in lread.c.
64 These macros prevent the name conflict. */
65 #if defined (HPUX) && !defined (HPUX8)
66 #define _MAXLDBL data_c_maxldbl
67 #define _NMAXLDBL data_c_nmaxldbl
71 #endif /* LISP_FLOAT_TYPE */
74 extern double atof ();
77 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
78 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
79 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
80 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
81 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
82 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
83 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
84 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
85 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
86 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
87 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
88 Lisp_Object Qbuffer_or_string_p
;
89 Lisp_Object Qboundp
, Qfboundp
;
90 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
93 Lisp_Object Qad_advice_info
, Qad_activate
;
95 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
96 Lisp_Object Qoverflow_error
, Qunderflow_error
;
98 #ifdef LISP_FLOAT_TYPE
100 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
103 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
104 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
105 Lisp_Object Qprocess
;
106 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
107 static Lisp_Object Qchar_table
, Qbool_vector
;
109 static Lisp_Object
swap_in_symval_forwarding ();
111 Lisp_Object
set_internal ();
114 wrong_type_argument (predicate
, value
)
115 register Lisp_Object predicate
, value
;
117 register Lisp_Object tem
;
120 if (!EQ (Vmocklisp_arguments
, Qt
))
122 if (STRINGP (value
) &&
123 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
124 return Fstring_to_number (value
, Qnil
);
125 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
126 return Fnumber_to_string (value
);
129 /* If VALUE is not even a valid Lisp object, abort here
130 where we can get a backtrace showing where it came from. */
131 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
134 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
135 tem
= call1 (predicate
, value
);
143 error ("Attempt to modify read-only object");
147 args_out_of_range (a1
, a2
)
151 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
155 args_out_of_range_3 (a1
, a2
, a3
)
156 Lisp_Object a1
, a2
, a3
;
159 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
162 /* On some machines, XINT needs a temporary location.
163 Here it is, in case it is needed. */
165 int sign_extend_temp
;
167 /* On a few machines, XINT can only be done by calling this. */
170 sign_extend_lisp_int (num
)
173 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
174 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
176 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
179 /* Data type predicates */
181 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
182 "T if the two args are the same Lisp object.")
184 Lisp_Object obj1
, obj2
;
191 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
200 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
201 "Return a symbol representing the type of OBJECT.\n\
202 The symbol returned names the object's basic type;\n\
203 for example, (type-of 1) returns `integer'.")
207 switch (XGCTYPE (object
))
222 switch (XMISCTYPE (object
))
224 case Lisp_Misc_Marker
:
226 case Lisp_Misc_Overlay
:
228 case Lisp_Misc_Float
:
233 case Lisp_Vectorlike
:
234 if (GC_WINDOW_CONFIGURATIONP (object
))
235 return Qwindow_configuration
;
236 if (GC_PROCESSP (object
))
238 if (GC_WINDOWP (object
))
240 if (GC_SUBRP (object
))
242 if (GC_COMPILEDP (object
))
243 return Qcompiled_function
;
244 if (GC_BUFFERP (object
))
246 if (GC_CHAR_TABLE_P (object
))
248 if (GC_BOOL_VECTOR_P (object
))
250 if (GC_FRAMEP (object
))
254 #ifdef LISP_FLOAT_TYPE
264 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
273 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
282 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
286 if (CONSP (object
) || NILP (object
))
291 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
295 if (CONSP (object
) || NILP (object
))
300 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
304 if (SYMBOLP (object
))
309 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
313 if (VECTORP (object
))
318 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
322 if (STRINGP (object
))
327 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0, "T if OBJECT is a char-table.")
331 if (CHAR_TABLE_P (object
))
336 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
337 Svector_or_char_table_p
, 1, 1, 0,
338 "T if OBJECT is a char-table or vector.")
342 if (VECTORP (object
) || CHAR_TABLE_P (object
))
347 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "T if OBJECT is a bool-vector.")
351 if (BOOL_VECTOR_P (object
))
356 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
360 if (VECTORP (object
) || STRINGP (object
)
361 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
366 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
367 "T if OBJECT is a sequence (list or array).")
369 register Lisp_Object object
;
371 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
372 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
377 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
381 if (BUFFERP (object
))
386 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
390 if (MARKERP (object
))
395 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
404 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
405 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
409 if (COMPILEDP (object
))
414 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
415 "T if OBJECT is a character (an integer) or a string.")
417 register Lisp_Object object
;
419 if (INTEGERP (object
) || STRINGP (object
))
424 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "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 "T if OBJECT is an integer or a marker (editor pointer).")
436 register Lisp_Object object
;
438 if (MARKERP (object
) || INTEGERP (object
))
443 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
444 "T if OBJECT is a nonnegative integer.")
448 if (NATNUMP (object
))
453 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
454 "T if OBJECT is a number (floating point or integer).")
458 if (NUMBERP (object
))
464 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
465 Snumber_or_marker_p
, 1, 1, 0,
466 "T if OBJECT is a number or a marker.")
470 if (NUMBERP (object
) || MARKERP (object
))
475 #ifdef LISP_FLOAT_TYPE
476 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
477 "T if OBJECT is a floating point number.")
485 #endif /* LISP_FLOAT_TYPE */
487 /* Extract and set components of lists */
489 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
490 "Return the car of LIST. If arg is nil, return nil.\n\
491 Error if arg is not nil and not a cons cell. See also `car-safe'.")
493 register Lisp_Object list
;
498 return XCONS (list
)->car
;
499 else if (EQ (list
, Qnil
))
502 list
= wrong_type_argument (Qlistp
, list
);
506 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
507 "Return the car of OBJECT if it is a cons cell, or else nil.")
512 return XCONS (object
)->car
;
517 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
518 "Return the cdr of LIST. If arg is nil, return nil.\n\
519 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
522 register Lisp_Object list
;
527 return XCONS (list
)->cdr
;
528 else if (EQ (list
, Qnil
))
531 list
= wrong_type_argument (Qlistp
, list
);
535 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
536 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
541 return XCONS (object
)->cdr
;
546 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
547 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
549 register Lisp_Object cell
, newcar
;
552 cell
= wrong_type_argument (Qconsp
, cell
);
555 XCONS (cell
)->car
= newcar
;
559 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
560 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
562 register Lisp_Object cell
, newcdr
;
565 cell
= wrong_type_argument (Qconsp
, cell
);
568 XCONS (cell
)->cdr
= newcdr
;
572 /* Extract and set components of symbols */
574 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
576 register Lisp_Object symbol
;
578 Lisp_Object valcontents
;
579 CHECK_SYMBOL (symbol
, 0);
581 valcontents
= XSYMBOL (symbol
)->value
;
583 if (BUFFER_LOCAL_VALUEP (valcontents
)
584 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
585 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
587 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
590 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
592 register Lisp_Object symbol
;
594 CHECK_SYMBOL (symbol
, 0);
595 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
598 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
600 register Lisp_Object symbol
;
602 CHECK_SYMBOL (symbol
, 0);
603 if (NILP (symbol
) || EQ (symbol
, Qt
))
604 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
605 Fset (symbol
, Qunbound
);
609 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
611 register Lisp_Object symbol
;
613 CHECK_SYMBOL (symbol
, 0);
614 if (NILP (symbol
) || EQ (symbol
, Qt
))
615 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
616 XSYMBOL (symbol
)->function
= Qunbound
;
620 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
621 "Return SYMBOL's function definition. Error if that is void.")
623 register Lisp_Object symbol
;
625 CHECK_SYMBOL (symbol
, 0);
626 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
627 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
628 return XSYMBOL (symbol
)->function
;
631 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
633 register Lisp_Object symbol
;
635 CHECK_SYMBOL (symbol
, 0);
636 return XSYMBOL (symbol
)->plist
;
639 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
641 register Lisp_Object symbol
;
643 register Lisp_Object name
;
645 CHECK_SYMBOL (symbol
, 0);
646 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
650 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
651 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
653 register Lisp_Object symbol
, definition
;
655 CHECK_SYMBOL (symbol
, 0);
656 if (NILP (symbol
) || EQ (symbol
, Qt
))
657 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
658 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
659 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
661 XSYMBOL (symbol
)->function
= definition
;
662 /* Handle automatic advice activation */
663 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
665 call2 (Qad_activate
, symbol
, Qnil
);
666 definition
= XSYMBOL (symbol
)->function
;
671 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
672 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
673 Associates the function with the current load file, if any.")
675 register Lisp_Object symbol
, definition
;
677 CHECK_SYMBOL (symbol
, 0);
678 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
679 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
681 XSYMBOL (symbol
)->function
= definition
;
682 /* Handle automatic advice activation */
683 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
685 call2 (Qad_activate
, symbol
, Qnil
);
686 definition
= XSYMBOL (symbol
)->function
;
688 LOADHIST_ATTACH (symbol
);
692 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
693 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
695 register Lisp_Object symbol
, newplist
;
697 CHECK_SYMBOL (symbol
, 0);
698 XSYMBOL (symbol
)->plist
= newplist
;
703 /* Getting and setting values of symbols */
705 /* Given the raw contents of a symbol value cell,
706 return the Lisp value of the symbol.
707 This does not handle buffer-local variables; use
708 swap_in_symval_forwarding for that. */
711 do_symval_forwarding (valcontents
)
712 register Lisp_Object valcontents
;
714 register Lisp_Object val
;
716 if (MISCP (valcontents
))
717 switch (XMISCTYPE (valcontents
))
719 case Lisp_Misc_Intfwd
:
720 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
723 case Lisp_Misc_Boolfwd
:
724 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
726 case Lisp_Misc_Objfwd
:
727 return *XOBJFWD (valcontents
)->objvar
;
729 case Lisp_Misc_Buffer_Objfwd
:
730 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
731 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
733 case Lisp_Misc_Kboard_Objfwd
:
734 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
735 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
740 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
741 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
742 buffer-independent contents of the value cell: forwarded just one
743 step past the buffer-localness. */
746 store_symval_forwarding (symbol
, valcontents
, newval
)
748 register Lisp_Object valcontents
, newval
;
750 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
753 switch (XMISCTYPE (valcontents
))
755 case Lisp_Misc_Intfwd
:
756 CHECK_NUMBER (newval
, 1);
757 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
758 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
759 error ("Value out of range for variable `%s'",
760 XSYMBOL (symbol
)->name
->data
);
763 case Lisp_Misc_Boolfwd
:
764 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
767 case Lisp_Misc_Objfwd
:
768 *XOBJFWD (valcontents
)->objvar
= newval
;
771 case Lisp_Misc_Buffer_Objfwd
:
773 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
776 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
777 if (! NILP (type
) && ! NILP (newval
)
778 && XTYPE (newval
) != XINT (type
))
779 buffer_slot_type_mismatch (offset
);
781 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
785 case Lisp_Misc_Kboard_Objfwd
:
786 (*(Lisp_Object
*)((char *)current_kboard
787 + XKBOARD_OBJFWD (valcontents
)->offset
))
798 valcontents
= XSYMBOL (symbol
)->value
;
799 if (BUFFER_LOCAL_VALUEP (valcontents
)
800 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
801 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
803 XSYMBOL (symbol
)->value
= newval
;
807 /* Set up the buffer-local symbol SYMBOL for validity in the current
808 buffer. VALCONTENTS is the contents of its value cell.
809 Return the value forwarded one step past the buffer-local indicator. */
812 swap_in_symval_forwarding (symbol
, valcontents
)
813 Lisp_Object symbol
, valcontents
;
815 /* valcontents is a pointer to a struct resembling the cons
816 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
818 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
819 local_var_alist, that being the element whose car is this
820 variable. Or it can be a pointer to the
821 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
822 an element in its alist for this variable.
824 If the current buffer is not BUFFER, we store the current
825 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
826 appropriate alist element for the buffer now current and set up
827 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
828 element, and store into BUFFER.
830 Note that REALVALUE can be a forwarding pointer. */
832 register Lisp_Object tem1
;
833 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
835 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
837 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
839 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
840 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
842 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
843 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
844 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
846 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
849 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
852 /* Find the value of a symbol, returning Qunbound if it's not bound.
853 This is helpful for code which just wants to get a variable's value
854 if it has one, without signaling an error.
855 Note that it must not be possible to quit
856 within this function. Great care is required for this. */
859 find_symbol_value (symbol
)
862 register Lisp_Object valcontents
, tem1
;
863 register Lisp_Object val
;
864 CHECK_SYMBOL (symbol
, 0);
865 valcontents
= XSYMBOL (symbol
)->value
;
867 if (BUFFER_LOCAL_VALUEP (valcontents
)
868 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
869 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
871 if (MISCP (valcontents
))
873 switch (XMISCTYPE (valcontents
))
875 case Lisp_Misc_Intfwd
:
876 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
879 case Lisp_Misc_Boolfwd
:
880 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
882 case Lisp_Misc_Objfwd
:
883 return *XOBJFWD (valcontents
)->objvar
;
885 case Lisp_Misc_Buffer_Objfwd
:
886 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
887 + (char *)current_buffer
);
889 case Lisp_Misc_Kboard_Objfwd
:
890 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
891 + (char *)current_kboard
);
898 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
899 "Return SYMBOL's value. Error if that is void.")
905 val
= find_symbol_value (symbol
);
906 if (EQ (val
, Qunbound
))
907 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
912 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
913 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
915 register Lisp_Object symbol
, newval
;
917 return set_internal (symbol
, newval
, 0);
920 /* Stpre the value NEWVAL into SYMBOL.
921 If BINDFLAG is zero, then if this symbol is supposed to become
922 local in every buffer where it is set, then we make it local.
923 If BINDFLAG is nonzero, we don't do that. */
926 set_internal (symbol
, newval
, bindflag
)
927 register Lisp_Object symbol
, newval
;
930 int voide
= EQ (newval
, Qunbound
);
932 register Lisp_Object valcontents
, tem1
, current_alist_element
;
934 CHECK_SYMBOL (symbol
, 0);
935 if (NILP (symbol
) || EQ (symbol
, Qt
))
936 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
937 valcontents
= XSYMBOL (symbol
)->value
;
939 if (BUFFER_OBJFWDP (valcontents
))
941 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
942 register int mask
= XINT (*((Lisp_Object
*)
943 (idx
+ (char *)&buffer_local_flags
)));
945 current_buffer
->local_var_flags
|= mask
;
948 else if (BUFFER_LOCAL_VALUEP (valcontents
)
949 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
951 /* valcontents is actually a pointer to a struct resembling a cons,
952 with contents something like:
953 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
955 BUFFER is the last buffer for which this symbol's value was
958 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
959 local_var_alist, that being the element whose car is this
960 variable. Or it can be a pointer to the
961 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
962 have an element in its alist for this variable (that is, if
963 BUFFER sees the default value of this variable).
965 If we want to examine or set the value and BUFFER is current,
966 we just examine or set REALVALUE. If BUFFER is not current, we
967 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
968 then find the appropriate alist element for the buffer now
969 current and set up CURRENT-ALIST-ELEMENT. Then we set
970 REALVALUE out of that element, and store into BUFFER.
972 If we are setting the variable and the current buffer does
973 not have an alist entry for this variable, an alist entry is
976 Note that REALVALUE can be a forwarding pointer. Each time
977 it is examined or set, forwarding must be done. */
979 /* What value are we caching right now? */
980 current_alist_element
=
981 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
983 /* If the current buffer is not the buffer whose binding is
984 currently cached, or if it's a Lisp_Buffer_Local_Value and
985 we're looking at the default value, the cache is invalid; we
986 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
988 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
989 || (BUFFER_LOCAL_VALUEP (valcontents
)
990 && EQ (XCONS (current_alist_element
)->car
,
991 current_alist_element
)))
993 /* Write out the cached value for the old buffer; copy it
994 back to its alist element. This works if the current
995 buffer only sees the default value, too. */
996 Fsetcdr (current_alist_element
,
997 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
999 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1000 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1003 /* This buffer still sees the default value. */
1005 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1006 or if this is `let' rather than `set',
1007 make CURRENT-ALIST-ELEMENT point to itself,
1008 indicating that we're seeing the default value. */
1009 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1010 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1012 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1013 give this buffer a new assoc for a local value and set
1014 CURRENT-ALIST-ELEMENT to point to that. */
1017 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1018 current_buffer
->local_var_alist
=
1019 Fcons (tem1
, current_buffer
->local_var_alist
);
1022 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1023 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
1026 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1027 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
1030 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1033 /* If storing void (making the symbol void), forward only through
1034 buffer-local indicator, not through Lisp_Objfwd, etc. */
1036 store_symval_forwarding (symbol
, Qnil
, newval
);
1038 store_symval_forwarding (symbol
, valcontents
, newval
);
1043 /* Access or set a buffer-local symbol's default value. */
1045 /* Return the default value of SYMBOL, but don't check for voidness.
1046 Return Qunbound if it is void. */
1049 default_value (symbol
)
1052 register Lisp_Object valcontents
;
1054 CHECK_SYMBOL (symbol
, 0);
1055 valcontents
= XSYMBOL (symbol
)->value
;
1057 /* For a built-in buffer-local variable, get the default value
1058 rather than letting do_symval_forwarding get the current value. */
1059 if (BUFFER_OBJFWDP (valcontents
))
1061 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1063 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1064 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1067 /* Handle user-created local variables. */
1068 if (BUFFER_LOCAL_VALUEP (valcontents
)
1069 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1071 /* If var is set up for a buffer that lacks a local value for it,
1072 the current value is nominally the default value.
1073 But the current value slot may be more up to date, since
1074 ordinary setq stores just that slot. So use that. */
1075 Lisp_Object current_alist_element
, alist_element_car
;
1076 current_alist_element
1077 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1078 alist_element_car
= XCONS (current_alist_element
)->car
;
1079 if (EQ (alist_element_car
, current_alist_element
))
1080 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1082 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1084 /* For other variables, get the current value. */
1085 return do_symval_forwarding (valcontents
);
1088 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1089 "Return T if SYMBOL has a non-void default value.\n\
1090 This is the value that is seen in buffers that do not have their own values\n\
1091 for this variable.")
1095 register Lisp_Object value
;
1097 value
= default_value (symbol
);
1098 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1101 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1102 "Return SYMBOL's default value.\n\
1103 This is the value that is seen in buffers that do not have their own values\n\
1104 for this variable. The default value is meaningful for variables with\n\
1105 local bindings in certain buffers.")
1109 register Lisp_Object value
;
1111 value
= default_value (symbol
);
1112 if (EQ (value
, Qunbound
))
1113 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1117 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1118 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1119 The default value is seen in buffers that do not have their own values\n\
1120 for this variable.")
1122 Lisp_Object symbol
, value
;
1124 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1126 CHECK_SYMBOL (symbol
, 0);
1127 valcontents
= XSYMBOL (symbol
)->value
;
1129 /* Handle variables like case-fold-search that have special slots
1130 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1132 if (BUFFER_OBJFWDP (valcontents
))
1134 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1135 register struct buffer
*b
;
1136 register int mask
= XINT (*((Lisp_Object
*)
1137 (idx
+ (char *)&buffer_local_flags
)));
1141 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1142 for (b
= all_buffers
; b
; b
= b
->next
)
1143 if (!(b
->local_var_flags
& mask
))
1144 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1149 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1150 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1151 return Fset (symbol
, value
);
1153 /* Store new value into the DEFAULT-VALUE slot */
1154 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1156 /* If that slot is current, we must set the REALVALUE slot too */
1157 current_alist_element
1158 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1159 alist_element_buffer
= Fcar (current_alist_element
);
1160 if (EQ (alist_element_buffer
, current_alist_element
))
1161 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1167 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1168 "Set the default value of variable VAR to VALUE.\n\
1169 VAR, the variable name, is literal (not evaluated);\n\
1170 VALUE is an expression and it is evaluated.\n\
1171 The default value of a variable is seen in buffers\n\
1172 that do not have their own values for the variable.\n\
1174 More generally, you can use multiple variables and values, as in\n\
1175 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1176 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1177 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1182 register Lisp_Object args_left
;
1183 register Lisp_Object val
, symbol
;
1184 struct gcpro gcpro1
;
1194 val
= Feval (Fcar (Fcdr (args_left
)));
1195 symbol
= Fcar (args_left
);
1196 Fset_default (symbol
, val
);
1197 args_left
= Fcdr (Fcdr (args_left
));
1199 while (!NILP (args_left
));
1205 /* Lisp functions for creating and removing buffer-local variables. */
1207 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1208 1, 1, "vMake Variable Buffer Local: ",
1209 "Make VARIABLE have a separate value for each buffer.\n\
1210 At any time, the value for the current buffer is in effect.\n\
1211 There is also a default value which is seen in any buffer which has not yet\n\
1212 set its own value.\n\
1213 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1214 for the current buffer if it was previously using the default value.\n\
1215 The function `default-value' gets the default value and `set-default' sets it.")
1217 register Lisp_Object variable
;
1219 register Lisp_Object tem
, valcontents
, newval
;
1221 CHECK_SYMBOL (variable
, 0);
1223 valcontents
= XSYMBOL (variable
)->value
;
1224 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1225 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1227 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1229 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1231 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1234 if (EQ (valcontents
, Qunbound
))
1235 XSYMBOL (variable
)->value
= Qnil
;
1236 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1237 XCONS (tem
)->car
= tem
;
1238 newval
= allocate_misc ();
1239 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1240 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1241 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1242 XSYMBOL (variable
)->value
= newval
;
1246 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1247 1, 1, "vMake Local Variable: ",
1248 "Make VARIABLE have a separate value in the current buffer.\n\
1249 Other buffers will continue to share a common default value.\n\
1250 \(The buffer-local value of VARIABLE starts out as the same value\n\
1251 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1252 See also `make-variable-buffer-local'.\n\n\
1253 If the variable is already arranged to become local when set,\n\
1254 this function causes a local value to exist for this buffer,\n\
1255 just as setting the variable would do.\n\
1257 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1258 Use `make-local-hook' instead.")
1260 register Lisp_Object variable
;
1262 register Lisp_Object tem
, valcontents
;
1264 CHECK_SYMBOL (variable
, 0);
1266 valcontents
= XSYMBOL (variable
)->value
;
1267 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1268 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1270 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1272 tem
= Fboundp (variable
);
1274 /* Make sure the symbol has a local value in this particular buffer,
1275 by setting it to the same value it already has. */
1276 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1279 /* Make sure symbol is set up to hold per-buffer values */
1280 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1283 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1284 XCONS (tem
)->car
= tem
;
1285 newval
= allocate_misc ();
1286 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1287 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1288 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1289 XSYMBOL (variable
)->value
= newval
;
1291 /* Make sure this buffer has its own value of symbol */
1292 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1295 /* Swap out any local binding for some other buffer, and make
1296 sure the current value is permanently recorded, if it's the
1298 find_symbol_value (variable
);
1300 current_buffer
->local_var_alist
1301 = Fcons (Fcons (variable
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
)->cdr
),
1302 current_buffer
->local_var_alist
);
1304 /* Make sure symbol does not think it is set up for this buffer;
1305 force it to look once again for this buffer's value */
1307 Lisp_Object
*pvalbuf
;
1309 valcontents
= XSYMBOL (variable
)->value
;
1311 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1312 if (current_buffer
== XBUFFER (*pvalbuf
))
1317 /* If the symbol forwards into a C variable, then swap in the
1318 variable for this buffer immediately. If C code modifies the
1319 variable before we swap in, then that new value will clobber the
1320 default value the next time we swap. */
1321 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->car
;
1322 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1323 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1328 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1329 1, 1, "vKill Local Variable: ",
1330 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1331 From now on the default value will apply in this buffer.")
1333 register Lisp_Object variable
;
1335 register Lisp_Object tem
, valcontents
;
1337 CHECK_SYMBOL (variable
, 0);
1339 valcontents
= XSYMBOL (variable
)->value
;
1341 if (BUFFER_OBJFWDP (valcontents
))
1343 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1344 register int mask
= XINT (*((Lisp_Object
*)
1345 (idx
+ (char *)&buffer_local_flags
)));
1349 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1350 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1351 current_buffer
->local_var_flags
&= ~mask
;
1356 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1357 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1360 /* Get rid of this buffer's alist element, if any */
1362 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1364 current_buffer
->local_var_alist
1365 = Fdelq (tem
, current_buffer
->local_var_alist
);
1367 /* If the symbol is set up for the current buffer, recompute its
1368 value. We have to do it now, or else forwarded objects won't
1371 Lisp_Object
*pvalbuf
;
1372 valcontents
= XSYMBOL (variable
)->value
;
1373 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1374 if (current_buffer
== XBUFFER (*pvalbuf
))
1377 find_symbol_value (variable
);
1384 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1386 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1387 BUFFER defaults to the current buffer.")
1389 register Lisp_Object variable
, buffer
;
1391 Lisp_Object valcontents
;
1392 register struct buffer
*buf
;
1395 buf
= current_buffer
;
1398 CHECK_BUFFER (buffer
, 0);
1399 buf
= XBUFFER (buffer
);
1402 CHECK_SYMBOL (variable
, 0);
1404 valcontents
= XSYMBOL (variable
)->value
;
1405 if (BUFFER_LOCAL_VALUEP (valcontents
)
1406 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1408 Lisp_Object tail
, elt
;
1409 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1411 elt
= XCONS (tail
)->car
;
1412 if (EQ (variable
, XCONS (elt
)->car
))
1416 if (BUFFER_OBJFWDP (valcontents
))
1418 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1419 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1420 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1426 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1428 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1429 BUFFER defaults to the current buffer.")
1431 register Lisp_Object variable
, buffer
;
1433 Lisp_Object valcontents
;
1434 register struct buffer
*buf
;
1437 buf
= current_buffer
;
1440 CHECK_BUFFER (buffer
, 0);
1441 buf
= XBUFFER (buffer
);
1444 CHECK_SYMBOL (variable
, 0);
1446 valcontents
= XSYMBOL (variable
)->value
;
1448 /* This means that make-variable-buffer-local was done. */
1449 if (BUFFER_LOCAL_VALUEP (valcontents
))
1451 /* All these slots become local if they are set. */
1452 if (BUFFER_OBJFWDP (valcontents
))
1454 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1456 Lisp_Object tail
, elt
;
1457 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1459 elt
= XCONS (tail
)->car
;
1460 if (EQ (variable
, XCONS (elt
)->car
))
1467 /* Find the function at the end of a chain of symbol function indirections. */
1469 /* If OBJECT is a symbol, find the end of its function chain and
1470 return the value found there. If OBJECT is not a symbol, just
1471 return it. If there is a cycle in the function chain, signal a
1472 cyclic-function-indirection error.
1474 This is like Findirect_function, except that it doesn't signal an
1475 error if the chain ends up unbound. */
1477 indirect_function (object
)
1478 register Lisp_Object object
;
1480 Lisp_Object tortoise
, hare
;
1482 hare
= tortoise
= object
;
1486 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1488 hare
= XSYMBOL (hare
)->function
;
1489 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1491 hare
= XSYMBOL (hare
)->function
;
1493 tortoise
= XSYMBOL (tortoise
)->function
;
1495 if (EQ (hare
, tortoise
))
1496 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1502 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1503 "Return the function at the end of OBJECT's function chain.\n\
1504 If OBJECT is a symbol, follow all function indirections and return the final\n\
1505 function binding.\n\
1506 If OBJECT is not a symbol, just return it.\n\
1507 Signal a void-function error if the final symbol is unbound.\n\
1508 Signal a cyclic-function-indirection error if there is a loop in the\n\
1509 function chain of symbols.")
1511 register Lisp_Object object
;
1515 result
= indirect_function (object
);
1517 if (EQ (result
, Qunbound
))
1518 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1522 /* Extract and set vector and string elements */
1524 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1525 "Return the element of ARRAY at index IDX.\n\
1526 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1527 or a byte-code object. IDX starts at 0.")
1529 register Lisp_Object array
;
1532 register int idxval
;
1534 CHECK_NUMBER (idx
, 1);
1535 idxval
= XINT (idx
);
1536 if (STRINGP (array
))
1539 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1540 args_out_of_range (array
, idx
);
1541 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1544 else if (BOOL_VECTOR_P (array
))
1548 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1549 args_out_of_range (array
, idx
);
1551 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1552 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1554 else if (CHAR_TABLE_P (array
))
1559 args_out_of_range (array
, idx
);
1560 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1562 /* For ASCII and 8-bit European characters, the element is
1563 stored in the top table. */
1564 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1566 val
= XCHAR_TABLE (array
)->defalt
;
1567 while (NILP (val
)) /* Follow parents until we find some value. */
1569 array
= XCHAR_TABLE (array
)->parent
;
1572 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1574 val
= XCHAR_TABLE (array
)->defalt
;
1581 Lisp_Object sub_table
;
1583 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1584 if (code
[0] != CHARSET_COMPOSITION
)
1586 if (code
[1] < 32) code
[1] = -1;
1587 else if (code
[2] < 32) code
[2] = -1;
1589 /* Here, the possible range of CODE[0] (== charset ID) is
1590 128..MAX_CHARSET. Since the top level char table contains
1591 data for multibyte characters after 256th element, we must
1592 increment CODE[0] by 128 to get a correct index. */
1594 code
[3] = -1; /* anchor */
1596 try_parent_char_table
:
1598 for (i
= 0; code
[i
] >= 0; i
++)
1600 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1601 if (SUB_CHAR_TABLE_P (val
))
1606 val
= XCHAR_TABLE (sub_table
)->defalt
;
1609 array
= XCHAR_TABLE (array
)->parent
;
1611 goto try_parent_char_table
;
1616 /* Here, VAL is a sub char table. We try the default value
1618 val
= XCHAR_TABLE (val
)->defalt
;
1621 array
= XCHAR_TABLE (array
)->parent
;
1623 goto try_parent_char_table
;
1631 if (VECTORP (array
))
1632 size
= XVECTOR (array
)->size
;
1633 else if (COMPILEDP (array
))
1634 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1636 wrong_type_argument (Qarrayp
, array
);
1638 if (idxval
< 0 || idxval
>= size
)
1639 args_out_of_range (array
, idx
);
1640 return XVECTOR (array
)->contents
[idxval
];
1644 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1645 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1646 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1648 (array
, idx
, newelt
)
1649 register Lisp_Object array
;
1650 Lisp_Object idx
, newelt
;
1652 register int idxval
;
1654 CHECK_NUMBER (idx
, 1);
1655 idxval
= XINT (idx
);
1656 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1657 && ! CHAR_TABLE_P (array
))
1658 array
= wrong_type_argument (Qarrayp
, array
);
1659 CHECK_IMPURE (array
);
1661 if (VECTORP (array
))
1663 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1664 args_out_of_range (array
, idx
);
1665 XVECTOR (array
)->contents
[idxval
] = newelt
;
1667 else if (BOOL_VECTOR_P (array
))
1671 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1672 args_out_of_range (array
, idx
);
1674 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1676 if (! NILP (newelt
))
1677 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1679 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1680 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1682 else if (CHAR_TABLE_P (array
))
1687 args_out_of_range (array
, idx
);
1688 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1689 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1695 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1696 if (code
[0] != CHARSET_COMPOSITION
)
1698 if (code
[1] < 32) code
[1] = -1;
1699 else if (code
[2] < 32) code
[2] = -1;
1701 /* See the comment of the corresponding part in Faref. */
1703 code
[3] = -1; /* anchor */
1704 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1706 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1707 if (SUB_CHAR_TABLE_P (val
))
1710 /* VAL is a leaf. Create a sub char table with the
1711 default value VAL or XCHAR_TABLE (array)->defalt
1712 and look into it. */
1713 array
= (XCHAR_TABLE (array
)->contents
[code
[i
]]
1714 = make_sub_char_table (NILP (val
)
1715 ? XCHAR_TABLE (array
)->defalt
1718 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1723 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1724 args_out_of_range (array
, idx
);
1725 CHECK_NUMBER (newelt
, 2);
1726 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1732 /* Arithmetic functions */
1734 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1737 arithcompare (num1
, num2
, comparison
)
1738 Lisp_Object num1
, num2
;
1739 enum comparison comparison
;
1744 #ifdef LISP_FLOAT_TYPE
1745 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1746 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1748 if (FLOATP (num1
) || FLOATP (num2
))
1751 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1752 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1755 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1756 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1757 #endif /* LISP_FLOAT_TYPE */
1762 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1767 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1772 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1777 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1782 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1787 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1796 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1797 "T if two args, both numbers or markers, are equal.")
1799 register Lisp_Object num1
, num2
;
1801 return arithcompare (num1
, num2
, equal
);
1804 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1805 "T if first arg is less than second arg. Both must be numbers or markers.")
1807 register Lisp_Object num1
, num2
;
1809 return arithcompare (num1
, num2
, less
);
1812 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1813 "T if first arg is greater than second arg. Both must be numbers or markers.")
1815 register Lisp_Object num1
, num2
;
1817 return arithcompare (num1
, num2
, grtr
);
1820 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1821 "T if first arg is less than or equal to second arg.\n\
1822 Both must be numbers or markers.")
1824 register Lisp_Object num1
, num2
;
1826 return arithcompare (num1
, num2
, less_or_equal
);
1829 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1830 "T if first arg is greater than or equal to second arg.\n\
1831 Both must be numbers or markers.")
1833 register Lisp_Object num1
, num2
;
1835 return arithcompare (num1
, num2
, grtr_or_equal
);
1838 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1839 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1841 register Lisp_Object num1
, num2
;
1843 return arithcompare (num1
, num2
, notequal
);
1846 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1848 register Lisp_Object number
;
1850 #ifdef LISP_FLOAT_TYPE
1851 CHECK_NUMBER_OR_FLOAT (number
, 0);
1853 if (FLOATP (number
))
1855 if (XFLOAT(number
)->data
== 0.0)
1860 CHECK_NUMBER (number
, 0);
1861 #endif /* LISP_FLOAT_TYPE */
1868 /* Convert between long values and pairs of Lisp integers. */
1874 unsigned int top
= i
>> 16;
1875 unsigned int bot
= i
& 0xFFFF;
1877 return make_number (bot
);
1878 if (top
== (unsigned long)-1 >> 16)
1879 return Fcons (make_number (-1), make_number (bot
));
1880 return Fcons (make_number (top
), make_number (bot
));
1887 Lisp_Object top
, bot
;
1890 top
= XCONS (c
)->car
;
1891 bot
= XCONS (c
)->cdr
;
1893 bot
= XCONS (bot
)->car
;
1894 return ((XINT (top
) << 16) | XINT (bot
));
1897 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1898 "Convert NUMBER to a string by printing it in decimal.\n\
1899 Uses a minus sign if negative.\n\
1900 NUMBER may be an integer or a floating point number.")
1904 char buffer
[VALBITS
];
1906 #ifndef LISP_FLOAT_TYPE
1907 CHECK_NUMBER (number
, 0);
1909 CHECK_NUMBER_OR_FLOAT (number
, 0);
1911 if (FLOATP (number
))
1913 char pigbuf
[350]; /* see comments in float_to_string */
1915 float_to_string (pigbuf
, XFLOAT(number
)->data
);
1916 return build_string (pigbuf
);
1918 #endif /* LISP_FLOAT_TYPE */
1920 if (sizeof (int) == sizeof (EMACS_INT
))
1921 sprintf (buffer
, "%d", XINT (number
));
1922 else if (sizeof (long) == sizeof (EMACS_INT
))
1923 sprintf (buffer
, "%ld", XINT (number
));
1926 return build_string (buffer
);
1930 digit_to_number (character
, base
)
1931 int character
, base
;
1935 if (character
>= '0' && character
<= '9')
1936 digit
= character
- '0';
1937 else if (character
>= 'a' && character
<= 'z')
1938 digit
= character
- 'a' + 10;
1939 else if (character
>= 'A' && character
<= 'Z')
1940 digit
= character
- 'A' + 10;
1950 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
1951 "Convert STRING to a number by parsing it as a decimal number.\n\
1952 This parses both integers and floating point numbers.\n\
1953 It ignores leading spaces and tabs.\n\
1955 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
1956 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
1957 Floating point numbers always use base 10.")
1959 register Lisp_Object string
, base
;
1961 register unsigned char *p
;
1962 register int b
, digit
, v
= 0;
1965 CHECK_STRING (string
, 0);
1971 CHECK_NUMBER (base
, 1);
1973 if (b
< 2 || b
> 16)
1974 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
1977 p
= XSTRING (string
)->data
;
1979 /* Skip any whitespace at the front of the number. Some versions of
1980 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1981 while (*p
== ' ' || *p
== '\t')
1992 #ifdef LISP_FLOAT_TYPE
1993 if (isfloat_string (p
))
1994 return make_float (atof (p
));
1995 #endif /* LISP_FLOAT_TYPE */
1999 int digit
= digit_to_number (*p
++, b
);
2005 return make_number (negative
* v
);
2010 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2012 extern Lisp_Object
float_arith_driver ();
2013 extern Lisp_Object
fmod_float ();
2016 arith_driver (code
, nargs
, args
)
2019 register Lisp_Object
*args
;
2021 register Lisp_Object val
;
2022 register int argnum
;
2023 register EMACS_INT accum
;
2024 register EMACS_INT next
;
2026 switch (SWITCH_ENUM_CAST (code
))
2039 for (argnum
= 0; argnum
< nargs
; argnum
++)
2041 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2042 #ifdef LISP_FLOAT_TYPE
2043 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2045 if (FLOATP (val
)) /* time to do serious math */
2046 return (float_arith_driver ((double) accum
, argnum
, code
,
2049 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2050 #endif /* LISP_FLOAT_TYPE */
2051 args
[argnum
] = val
; /* runs into a compiler bug. */
2052 next
= XINT (args
[argnum
]);
2053 switch (SWITCH_ENUM_CAST (code
))
2055 case Aadd
: accum
+= next
; break;
2057 if (!argnum
&& nargs
!= 1)
2061 case Amult
: accum
*= next
; break;
2063 if (!argnum
) accum
= next
;
2067 Fsignal (Qarith_error
, Qnil
);
2071 case Alogand
: accum
&= next
; break;
2072 case Alogior
: accum
|= next
; break;
2073 case Alogxor
: accum
^= next
; break;
2074 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2075 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2079 XSETINT (val
, accum
);
2084 #define isnan(x) ((x) != (x))
2086 #ifdef LISP_FLOAT_TYPE
2089 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2091 register int argnum
;
2094 register Lisp_Object
*args
;
2096 register Lisp_Object val
;
2099 for (; argnum
< nargs
; argnum
++)
2101 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2102 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2106 next
= XFLOAT (val
)->data
;
2110 args
[argnum
] = val
; /* runs into a compiler bug. */
2111 next
= XINT (args
[argnum
]);
2113 switch (SWITCH_ENUM_CAST (code
))
2119 if (!argnum
&& nargs
!= 1)
2131 if (! IEEE_FLOATING_POINT
&& next
== 0)
2132 Fsignal (Qarith_error
, Qnil
);
2139 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2141 if (!argnum
|| isnan (next
) || next
> accum
)
2145 if (!argnum
|| isnan (next
) || next
< accum
)
2151 return make_float (accum
);
2153 #endif /* LISP_FLOAT_TYPE */
2155 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2156 "Return sum of any number of arguments, which are numbers or markers.")
2161 return arith_driver (Aadd
, nargs
, args
);
2164 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2165 "Negate number or subtract numbers or markers.\n\
2166 With one arg, negates it. With more than one arg,\n\
2167 subtracts all but the first from the first.")
2172 return arith_driver (Asub
, nargs
, args
);
2175 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2176 "Returns product of any number of arguments, which are numbers or markers.")
2181 return arith_driver (Amult
, nargs
, args
);
2184 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2185 "Returns first argument divided by all the remaining arguments.\n\
2186 The arguments must be numbers or markers.")
2191 return arith_driver (Adiv
, nargs
, args
);
2194 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2195 "Returns remainder of X divided by Y.\n\
2196 Both must be integers or markers.")
2198 register Lisp_Object x
, y
;
2202 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2203 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2205 if (XFASTINT (y
) == 0)
2206 Fsignal (Qarith_error
, Qnil
);
2208 XSETINT (val
, XINT (x
) % XINT (y
));
2222 /* If the magnitude of the result exceeds that of the divisor, or
2223 the sign of the result does not agree with that of the dividend,
2224 iterate with the reduced value. This does not yield a
2225 particularly accurate result, but at least it will be in the
2226 range promised by fmod. */
2228 r
-= f2
* floor (r
/ f2
);
2229 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2233 #endif /* ! HAVE_FMOD */
2235 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2236 "Returns X modulo Y.\n\
2237 The result falls between zero (inclusive) and Y (exclusive).\n\
2238 Both X and Y must be numbers or markers.")
2240 register Lisp_Object x
, y
;
2245 #ifdef LISP_FLOAT_TYPE
2246 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2247 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2249 if (FLOATP (x
) || FLOATP (y
))
2250 return fmod_float (x
, y
);
2252 #else /* not LISP_FLOAT_TYPE */
2253 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2254 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2255 #endif /* not LISP_FLOAT_TYPE */
2261 Fsignal (Qarith_error
, Qnil
);
2265 /* If the "remainder" comes out with the wrong sign, fix it. */
2266 if (i2
< 0 ? i1
> 0 : i1
< 0)
2273 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2274 "Return largest of all the arguments (which must be numbers or markers).\n\
2275 The value is always a number; markers are converted to numbers.")
2280 return arith_driver (Amax
, nargs
, args
);
2283 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2284 "Return smallest of all the arguments (which must be numbers or markers).\n\
2285 The value is always a number; markers are converted to numbers.")
2290 return arith_driver (Amin
, nargs
, args
);
2293 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2294 "Return bitwise-and of all the arguments.\n\
2295 Arguments may be integers, or markers converted to integers.")
2300 return arith_driver (Alogand
, nargs
, args
);
2303 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2304 "Return bitwise-or of all the arguments.\n\
2305 Arguments may be integers, or markers converted to integers.")
2310 return arith_driver (Alogior
, nargs
, args
);
2313 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2314 "Return bitwise-exclusive-or of all the arguments.\n\
2315 Arguments may be integers, or markers converted to integers.")
2320 return arith_driver (Alogxor
, nargs
, args
);
2323 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2324 "Return VALUE with its bits shifted left by COUNT.\n\
2325 If COUNT is negative, shifting is actually to the right.\n\
2326 In this case, the sign bit is duplicated.")
2328 register Lisp_Object value
, count
;
2330 register Lisp_Object val
;
2332 CHECK_NUMBER (value
, 0);
2333 CHECK_NUMBER (count
, 1);
2335 if (XINT (count
) > 0)
2336 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2338 XSETINT (val
, XINT (value
) >> -XINT (count
));
2342 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2343 "Return VALUE with its bits shifted left by COUNT.\n\
2344 If COUNT is negative, shifting is actually to the right.\n\
2345 In this case, zeros are shifted in on the left.")
2347 register Lisp_Object value
, count
;
2349 register Lisp_Object val
;
2351 CHECK_NUMBER (value
, 0);
2352 CHECK_NUMBER (count
, 1);
2354 if (XINT (count
) > 0)
2355 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2357 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2361 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2362 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2363 Markers are converted to integers.")
2365 register Lisp_Object number
;
2367 #ifdef LISP_FLOAT_TYPE
2368 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2370 if (FLOATP (number
))
2371 return (make_float (1.0 + XFLOAT (number
)->data
));
2373 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2374 #endif /* LISP_FLOAT_TYPE */
2376 XSETINT (number
, XINT (number
) + 1);
2380 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2381 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2382 Markers are converted to integers.")
2384 register Lisp_Object number
;
2386 #ifdef LISP_FLOAT_TYPE
2387 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2389 if (FLOATP (number
))
2390 return (make_float (-1.0 + XFLOAT (number
)->data
));
2392 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2393 #endif /* LISP_FLOAT_TYPE */
2395 XSETINT (number
, XINT (number
) - 1);
2399 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2400 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2402 register Lisp_Object number
;
2404 CHECK_NUMBER (number
, 0);
2405 XSETINT (number
, ~XINT (number
));
2412 Lisp_Object error_tail
, arith_tail
;
2414 Qquote
= intern ("quote");
2415 Qlambda
= intern ("lambda");
2416 Qsubr
= intern ("subr");
2417 Qerror_conditions
= intern ("error-conditions");
2418 Qerror_message
= intern ("error-message");
2419 Qtop_level
= intern ("top-level");
2421 Qerror
= intern ("error");
2422 Qquit
= intern ("quit");
2423 Qwrong_type_argument
= intern ("wrong-type-argument");
2424 Qargs_out_of_range
= intern ("args-out-of-range");
2425 Qvoid_function
= intern ("void-function");
2426 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2427 Qvoid_variable
= intern ("void-variable");
2428 Qsetting_constant
= intern ("setting-constant");
2429 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2431 Qinvalid_function
= intern ("invalid-function");
2432 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2433 Qno_catch
= intern ("no-catch");
2434 Qend_of_file
= intern ("end-of-file");
2435 Qarith_error
= intern ("arith-error");
2436 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2437 Qend_of_buffer
= intern ("end-of-buffer");
2438 Qbuffer_read_only
= intern ("buffer-read-only");
2439 Qmark_inactive
= intern ("mark-inactive");
2441 Qlistp
= intern ("listp");
2442 Qconsp
= intern ("consp");
2443 Qsymbolp
= intern ("symbolp");
2444 Qintegerp
= intern ("integerp");
2445 Qnatnump
= intern ("natnump");
2446 Qwholenump
= intern ("wholenump");
2447 Qstringp
= intern ("stringp");
2448 Qarrayp
= intern ("arrayp");
2449 Qsequencep
= intern ("sequencep");
2450 Qbufferp
= intern ("bufferp");
2451 Qvectorp
= intern ("vectorp");
2452 Qchar_or_string_p
= intern ("char-or-string-p");
2453 Qmarkerp
= intern ("markerp");
2454 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2455 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2456 Qboundp
= intern ("boundp");
2457 Qfboundp
= intern ("fboundp");
2459 #ifdef LISP_FLOAT_TYPE
2460 Qfloatp
= intern ("floatp");
2461 Qnumberp
= intern ("numberp");
2462 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2463 #endif /* LISP_FLOAT_TYPE */
2465 Qchar_table_p
= intern ("char-table-p");
2466 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2468 Qcdr
= intern ("cdr");
2470 /* Handle automatic advice activation */
2471 Qad_advice_info
= intern ("ad-advice-info");
2472 Qad_activate
= intern ("ad-activate");
2474 error_tail
= Fcons (Qerror
, Qnil
);
2476 /* ERROR is used as a signaler for random errors for which nothing else is right */
2478 Fput (Qerror
, Qerror_conditions
,
2480 Fput (Qerror
, Qerror_message
,
2481 build_string ("error"));
2483 Fput (Qquit
, Qerror_conditions
,
2484 Fcons (Qquit
, Qnil
));
2485 Fput (Qquit
, Qerror_message
,
2486 build_string ("Quit"));
2488 Fput (Qwrong_type_argument
, Qerror_conditions
,
2489 Fcons (Qwrong_type_argument
, error_tail
));
2490 Fput (Qwrong_type_argument
, Qerror_message
,
2491 build_string ("Wrong type argument"));
2493 Fput (Qargs_out_of_range
, Qerror_conditions
,
2494 Fcons (Qargs_out_of_range
, error_tail
));
2495 Fput (Qargs_out_of_range
, Qerror_message
,
2496 build_string ("Args out of range"));
2498 Fput (Qvoid_function
, Qerror_conditions
,
2499 Fcons (Qvoid_function
, error_tail
));
2500 Fput (Qvoid_function
, Qerror_message
,
2501 build_string ("Symbol's function definition is void"));
2503 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2504 Fcons (Qcyclic_function_indirection
, error_tail
));
2505 Fput (Qcyclic_function_indirection
, Qerror_message
,
2506 build_string ("Symbol's chain of function indirections contains a loop"));
2508 Fput (Qvoid_variable
, Qerror_conditions
,
2509 Fcons (Qvoid_variable
, error_tail
));
2510 Fput (Qvoid_variable
, Qerror_message
,
2511 build_string ("Symbol's value as variable is void"));
2513 Fput (Qsetting_constant
, Qerror_conditions
,
2514 Fcons (Qsetting_constant
, error_tail
));
2515 Fput (Qsetting_constant
, Qerror_message
,
2516 build_string ("Attempt to set a constant symbol"));
2518 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2519 Fcons (Qinvalid_read_syntax
, error_tail
));
2520 Fput (Qinvalid_read_syntax
, Qerror_message
,
2521 build_string ("Invalid read syntax"));
2523 Fput (Qinvalid_function
, Qerror_conditions
,
2524 Fcons (Qinvalid_function
, error_tail
));
2525 Fput (Qinvalid_function
, Qerror_message
,
2526 build_string ("Invalid function"));
2528 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2529 Fcons (Qwrong_number_of_arguments
, error_tail
));
2530 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2531 build_string ("Wrong number of arguments"));
2533 Fput (Qno_catch
, Qerror_conditions
,
2534 Fcons (Qno_catch
, error_tail
));
2535 Fput (Qno_catch
, Qerror_message
,
2536 build_string ("No catch for tag"));
2538 Fput (Qend_of_file
, Qerror_conditions
,
2539 Fcons (Qend_of_file
, error_tail
));
2540 Fput (Qend_of_file
, Qerror_message
,
2541 build_string ("End of file during parsing"));
2543 arith_tail
= Fcons (Qarith_error
, error_tail
);
2544 Fput (Qarith_error
, Qerror_conditions
,
2546 Fput (Qarith_error
, Qerror_message
,
2547 build_string ("Arithmetic error"));
2549 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2550 Fcons (Qbeginning_of_buffer
, error_tail
));
2551 Fput (Qbeginning_of_buffer
, Qerror_message
,
2552 build_string ("Beginning of buffer"));
2554 Fput (Qend_of_buffer
, Qerror_conditions
,
2555 Fcons (Qend_of_buffer
, error_tail
));
2556 Fput (Qend_of_buffer
, Qerror_message
,
2557 build_string ("End of buffer"));
2559 Fput (Qbuffer_read_only
, Qerror_conditions
,
2560 Fcons (Qbuffer_read_only
, error_tail
));
2561 Fput (Qbuffer_read_only
, Qerror_message
,
2562 build_string ("Buffer is read-only"));
2564 #ifdef LISP_FLOAT_TYPE
2565 Qrange_error
= intern ("range-error");
2566 Qdomain_error
= intern ("domain-error");
2567 Qsingularity_error
= intern ("singularity-error");
2568 Qoverflow_error
= intern ("overflow-error");
2569 Qunderflow_error
= intern ("underflow-error");
2571 Fput (Qdomain_error
, Qerror_conditions
,
2572 Fcons (Qdomain_error
, arith_tail
));
2573 Fput (Qdomain_error
, Qerror_message
,
2574 build_string ("Arithmetic domain error"));
2576 Fput (Qrange_error
, Qerror_conditions
,
2577 Fcons (Qrange_error
, arith_tail
));
2578 Fput (Qrange_error
, Qerror_message
,
2579 build_string ("Arithmetic range error"));
2581 Fput (Qsingularity_error
, Qerror_conditions
,
2582 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2583 Fput (Qsingularity_error
, Qerror_message
,
2584 build_string ("Arithmetic singularity error"));
2586 Fput (Qoverflow_error
, Qerror_conditions
,
2587 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2588 Fput (Qoverflow_error
, Qerror_message
,
2589 build_string ("Arithmetic overflow error"));
2591 Fput (Qunderflow_error
, Qerror_conditions
,
2592 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2593 Fput (Qunderflow_error
, Qerror_message
,
2594 build_string ("Arithmetic underflow error"));
2596 staticpro (&Qrange_error
);
2597 staticpro (&Qdomain_error
);
2598 staticpro (&Qsingularity_error
);
2599 staticpro (&Qoverflow_error
);
2600 staticpro (&Qunderflow_error
);
2601 #endif /* LISP_FLOAT_TYPE */
2605 staticpro (&Qquote
);
2606 staticpro (&Qlambda
);
2608 staticpro (&Qunbound
);
2609 staticpro (&Qerror_conditions
);
2610 staticpro (&Qerror_message
);
2611 staticpro (&Qtop_level
);
2613 staticpro (&Qerror
);
2615 staticpro (&Qwrong_type_argument
);
2616 staticpro (&Qargs_out_of_range
);
2617 staticpro (&Qvoid_function
);
2618 staticpro (&Qcyclic_function_indirection
);
2619 staticpro (&Qvoid_variable
);
2620 staticpro (&Qsetting_constant
);
2621 staticpro (&Qinvalid_read_syntax
);
2622 staticpro (&Qwrong_number_of_arguments
);
2623 staticpro (&Qinvalid_function
);
2624 staticpro (&Qno_catch
);
2625 staticpro (&Qend_of_file
);
2626 staticpro (&Qarith_error
);
2627 staticpro (&Qbeginning_of_buffer
);
2628 staticpro (&Qend_of_buffer
);
2629 staticpro (&Qbuffer_read_only
);
2630 staticpro (&Qmark_inactive
);
2632 staticpro (&Qlistp
);
2633 staticpro (&Qconsp
);
2634 staticpro (&Qsymbolp
);
2635 staticpro (&Qintegerp
);
2636 staticpro (&Qnatnump
);
2637 staticpro (&Qwholenump
);
2638 staticpro (&Qstringp
);
2639 staticpro (&Qarrayp
);
2640 staticpro (&Qsequencep
);
2641 staticpro (&Qbufferp
);
2642 staticpro (&Qvectorp
);
2643 staticpro (&Qchar_or_string_p
);
2644 staticpro (&Qmarkerp
);
2645 staticpro (&Qbuffer_or_string_p
);
2646 staticpro (&Qinteger_or_marker_p
);
2647 #ifdef LISP_FLOAT_TYPE
2648 staticpro (&Qfloatp
);
2649 staticpro (&Qnumberp
);
2650 staticpro (&Qnumber_or_marker_p
);
2651 #endif /* LISP_FLOAT_TYPE */
2652 staticpro (&Qchar_table_p
);
2653 staticpro (&Qvector_or_char_table_p
);
2655 staticpro (&Qboundp
);
2656 staticpro (&Qfboundp
);
2658 staticpro (&Qad_advice_info
);
2659 staticpro (&Qad_activate
);
2661 /* Types that type-of returns. */
2662 Qinteger
= intern ("integer");
2663 Qsymbol
= intern ("symbol");
2664 Qstring
= intern ("string");
2665 Qcons
= intern ("cons");
2666 Qmarker
= intern ("marker");
2667 Qoverlay
= intern ("overlay");
2668 Qfloat
= intern ("float");
2669 Qwindow_configuration
= intern ("window-configuration");
2670 Qprocess
= intern ("process");
2671 Qwindow
= intern ("window");
2672 /* Qsubr = intern ("subr"); */
2673 Qcompiled_function
= intern ("compiled-function");
2674 Qbuffer
= intern ("buffer");
2675 Qframe
= intern ("frame");
2676 Qvector
= intern ("vector");
2677 Qchar_table
= intern ("char-table");
2678 Qbool_vector
= intern ("bool-vector");
2680 staticpro (&Qinteger
);
2681 staticpro (&Qsymbol
);
2682 staticpro (&Qstring
);
2684 staticpro (&Qmarker
);
2685 staticpro (&Qoverlay
);
2686 staticpro (&Qfloat
);
2687 staticpro (&Qwindow_configuration
);
2688 staticpro (&Qprocess
);
2689 staticpro (&Qwindow
);
2690 /* staticpro (&Qsubr); */
2691 staticpro (&Qcompiled_function
);
2692 staticpro (&Qbuffer
);
2693 staticpro (&Qframe
);
2694 staticpro (&Qvector
);
2695 staticpro (&Qchar_table
);
2696 staticpro (&Qbool_vector
);
2700 defsubr (&Stype_of
);
2705 defsubr (&Sintegerp
);
2706 defsubr (&Sinteger_or_marker_p
);
2707 defsubr (&Snumberp
);
2708 defsubr (&Snumber_or_marker_p
);
2709 #ifdef LISP_FLOAT_TYPE
2711 #endif /* LISP_FLOAT_TYPE */
2712 defsubr (&Snatnump
);
2713 defsubr (&Ssymbolp
);
2714 defsubr (&Sstringp
);
2715 defsubr (&Svectorp
);
2716 defsubr (&Schar_table_p
);
2717 defsubr (&Svector_or_char_table_p
);
2718 defsubr (&Sbool_vector_p
);
2720 defsubr (&Ssequencep
);
2721 defsubr (&Sbufferp
);
2722 defsubr (&Smarkerp
);
2724 defsubr (&Sbyte_code_function_p
);
2725 defsubr (&Schar_or_string_p
);
2728 defsubr (&Scar_safe
);
2729 defsubr (&Scdr_safe
);
2732 defsubr (&Ssymbol_function
);
2733 defsubr (&Sindirect_function
);
2734 defsubr (&Ssymbol_plist
);
2735 defsubr (&Ssymbol_name
);
2736 defsubr (&Smakunbound
);
2737 defsubr (&Sfmakunbound
);
2739 defsubr (&Sfboundp
);
2741 defsubr (&Sdefalias
);
2742 defsubr (&Ssetplist
);
2743 defsubr (&Ssymbol_value
);
2745 defsubr (&Sdefault_boundp
);
2746 defsubr (&Sdefault_value
);
2747 defsubr (&Sset_default
);
2748 defsubr (&Ssetq_default
);
2749 defsubr (&Smake_variable_buffer_local
);
2750 defsubr (&Smake_local_variable
);
2751 defsubr (&Skill_local_variable
);
2752 defsubr (&Slocal_variable_p
);
2753 defsubr (&Slocal_variable_if_set_p
);
2756 defsubr (&Snumber_to_string
);
2757 defsubr (&Sstring_to_number
);
2758 defsubr (&Seqlsign
);
2782 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2789 #if defined(USG) && !defined(POSIX_SIGNALS)
2790 /* USG systems forget handlers when they are used;
2791 must reestablish each time */
2792 signal (signo
, arith_error
);
2795 /* VMS systems are like USG. */
2796 signal (signo
, arith_error
);
2800 #else /* not BSD4_1 */
2801 sigsetmask (SIGEMPTYMASK
);
2802 #endif /* not BSD4_1 */
2804 Fsignal (Qarith_error
, Qnil
);
2809 /* Don't do this if just dumping out.
2810 We don't want to call `signal' in this case
2811 so that we don't have trouble with dumping
2812 signal-delivering routines in an inconsistent state. */
2816 #endif /* CANNOT_DUMP */
2817 signal (SIGFPE
, arith_error
);
2820 signal (SIGEMT
, arith_error
);