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 "Return t if the two args are the same Lisp object.")
184 Lisp_Object obj1
, obj2
;
191 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return 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, "Return t if OBJECT is a cons cell.")
273 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "Return t if OBJECT is not a cons cell. This includes nil.")
282 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "Return t if OBJECT is a list. This includes nil.")
286 if (CONSP (object
) || NILP (object
))
291 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "Return t if OBJECT is not a list. Lists include nil.")
295 if (CONSP (object
) || NILP (object
))
300 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "Return t if OBJECT is a symbol.")
304 if (SYMBOLP (object
))
309 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "Return t if OBJECT is a vector.")
313 if (VECTORP (object
))
318 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "Return t if OBJECT is a string.")
322 if (STRINGP (object
))
327 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0, "Return 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 "Return 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, "Return t if OBJECT is a bool-vector.")
351 if (BOOL_VECTOR_P (object
))
356 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return 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 "Return 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, "Return t if OBJECT is an editor buffer.")
381 if (BUFFERP (object
))
386 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
390 if (MARKERP (object
))
395 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return 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, "Return t if OBJECT is a byte-compiled function object.")
409 if (COMPILEDP (object
))
414 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
415 "Return 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, "Return t if OBJECT is an integer.")
428 if (INTEGERP (object
))
433 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
434 "Return 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 "Return t if OBJECT is a nonnegative integer.")
448 if (NATNUMP (object
))
453 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
454 "Return 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 "Return 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 "Return 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, "Return 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, "Return 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
))
1713 /* VAL is a leaf. Create a sub char table with the
1714 default value VAL or XCHAR_TABLE (array)->defalt
1715 and look into it. */
1717 temp
= make_sub_char_table (NILP (val
)
1718 ? XCHAR_TABLE (array
)->defalt
1720 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1724 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1729 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1730 args_out_of_range (array
, idx
);
1731 CHECK_NUMBER (newelt
, 2);
1732 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1738 /* Arithmetic functions */
1740 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1743 arithcompare (num1
, num2
, comparison
)
1744 Lisp_Object num1
, num2
;
1745 enum comparison comparison
;
1750 #ifdef LISP_FLOAT_TYPE
1751 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1752 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1754 if (FLOATP (num1
) || FLOATP (num2
))
1757 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1758 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1761 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1762 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1763 #endif /* LISP_FLOAT_TYPE */
1768 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1773 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1778 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1783 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1788 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1793 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1802 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1803 "Return t if two args, both numbers or markers, are equal.")
1805 register Lisp_Object num1
, num2
;
1807 return arithcompare (num1
, num2
, equal
);
1810 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1811 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1813 register Lisp_Object num1
, num2
;
1815 return arithcompare (num1
, num2
, less
);
1818 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1819 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1821 register Lisp_Object num1
, num2
;
1823 return arithcompare (num1
, num2
, grtr
);
1826 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1827 "Return t if first arg is less than or equal to second arg.\n\
1828 Both must be numbers or markers.")
1830 register Lisp_Object num1
, num2
;
1832 return arithcompare (num1
, num2
, less_or_equal
);
1835 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1836 "Return t if first arg is greater than or equal to second arg.\n\
1837 Both must be numbers or markers.")
1839 register Lisp_Object num1
, num2
;
1841 return arithcompare (num1
, num2
, grtr_or_equal
);
1844 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1845 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1847 register Lisp_Object num1
, num2
;
1849 return arithcompare (num1
, num2
, notequal
);
1852 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1854 register Lisp_Object number
;
1856 #ifdef LISP_FLOAT_TYPE
1857 CHECK_NUMBER_OR_FLOAT (number
, 0);
1859 if (FLOATP (number
))
1861 if (XFLOAT(number
)->data
== 0.0)
1866 CHECK_NUMBER (number
, 0);
1867 #endif /* LISP_FLOAT_TYPE */
1874 /* Convert between long values and pairs of Lisp integers. */
1880 unsigned int top
= i
>> 16;
1881 unsigned int bot
= i
& 0xFFFF;
1883 return make_number (bot
);
1884 if (top
== (unsigned long)-1 >> 16)
1885 return Fcons (make_number (-1), make_number (bot
));
1886 return Fcons (make_number (top
), make_number (bot
));
1893 Lisp_Object top
, bot
;
1896 top
= XCONS (c
)->car
;
1897 bot
= XCONS (c
)->cdr
;
1899 bot
= XCONS (bot
)->car
;
1900 return ((XINT (top
) << 16) | XINT (bot
));
1903 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1904 "Convert NUMBER to a string by printing it in decimal.\n\
1905 Uses a minus sign if negative.\n\
1906 NUMBER may be an integer or a floating point number.")
1910 char buffer
[VALBITS
];
1912 #ifndef LISP_FLOAT_TYPE
1913 CHECK_NUMBER (number
, 0);
1915 CHECK_NUMBER_OR_FLOAT (number
, 0);
1917 if (FLOATP (number
))
1919 char pigbuf
[350]; /* see comments in float_to_string */
1921 float_to_string (pigbuf
, XFLOAT(number
)->data
);
1922 return build_string (pigbuf
);
1924 #endif /* LISP_FLOAT_TYPE */
1926 if (sizeof (int) == sizeof (EMACS_INT
))
1927 sprintf (buffer
, "%d", XINT (number
));
1928 else if (sizeof (long) == sizeof (EMACS_INT
))
1929 sprintf (buffer
, "%ld", XINT (number
));
1932 return build_string (buffer
);
1936 digit_to_number (character
, base
)
1937 int character
, base
;
1941 if (character
>= '0' && character
<= '9')
1942 digit
= character
- '0';
1943 else if (character
>= 'a' && character
<= 'z')
1944 digit
= character
- 'a' + 10;
1945 else if (character
>= 'A' && character
<= 'Z')
1946 digit
= character
- 'A' + 10;
1956 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
1957 "Convert STRING to a number by parsing it as a decimal number.\n\
1958 This parses both integers and floating point numbers.\n\
1959 It ignores leading spaces and tabs.\n\
1961 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
1962 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
1963 Floating point numbers always use base 10.")
1965 register Lisp_Object string
, base
;
1967 register unsigned char *p
;
1968 register int b
, digit
, v
= 0;
1971 CHECK_STRING (string
, 0);
1977 CHECK_NUMBER (base
, 1);
1979 if (b
< 2 || b
> 16)
1980 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
1983 p
= XSTRING (string
)->data
;
1985 /* Skip any whitespace at the front of the number. Some versions of
1986 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1987 while (*p
== ' ' || *p
== '\t')
1998 #ifdef LISP_FLOAT_TYPE
1999 if (isfloat_string (p
))
2000 return make_float (atof (p
));
2001 #endif /* LISP_FLOAT_TYPE */
2005 int digit
= digit_to_number (*p
++, b
);
2011 return make_number (negative
* v
);
2016 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2018 extern Lisp_Object
float_arith_driver ();
2019 extern Lisp_Object
fmod_float ();
2022 arith_driver (code
, nargs
, args
)
2025 register Lisp_Object
*args
;
2027 register Lisp_Object val
;
2028 register int argnum
;
2029 register EMACS_INT accum
;
2030 register EMACS_INT next
;
2032 switch (SWITCH_ENUM_CAST (code
))
2045 for (argnum
= 0; argnum
< nargs
; argnum
++)
2047 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2048 #ifdef LISP_FLOAT_TYPE
2049 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2051 if (FLOATP (val
)) /* time to do serious math */
2052 return (float_arith_driver ((double) accum
, argnum
, code
,
2055 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2056 #endif /* LISP_FLOAT_TYPE */
2057 args
[argnum
] = val
; /* runs into a compiler bug. */
2058 next
= XINT (args
[argnum
]);
2059 switch (SWITCH_ENUM_CAST (code
))
2061 case Aadd
: accum
+= next
; break;
2063 if (!argnum
&& nargs
!= 1)
2067 case Amult
: accum
*= next
; break;
2069 if (!argnum
) accum
= next
;
2073 Fsignal (Qarith_error
, Qnil
);
2077 case Alogand
: accum
&= next
; break;
2078 case Alogior
: accum
|= next
; break;
2079 case Alogxor
: accum
^= next
; break;
2080 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2081 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2085 XSETINT (val
, accum
);
2090 #define isnan(x) ((x) != (x))
2092 #ifdef LISP_FLOAT_TYPE
2095 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2097 register int argnum
;
2100 register Lisp_Object
*args
;
2102 register Lisp_Object val
;
2105 for (; argnum
< nargs
; argnum
++)
2107 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2108 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2112 next
= XFLOAT (val
)->data
;
2116 args
[argnum
] = val
; /* runs into a compiler bug. */
2117 next
= XINT (args
[argnum
]);
2119 switch (SWITCH_ENUM_CAST (code
))
2125 if (!argnum
&& nargs
!= 1)
2137 if (! IEEE_FLOATING_POINT
&& next
== 0)
2138 Fsignal (Qarith_error
, Qnil
);
2145 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2147 if (!argnum
|| isnan (next
) || next
> accum
)
2151 if (!argnum
|| isnan (next
) || next
< accum
)
2157 return make_float (accum
);
2159 #endif /* LISP_FLOAT_TYPE */
2161 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2162 "Return sum of any number of arguments, which are numbers or markers.")
2167 return arith_driver (Aadd
, nargs
, args
);
2170 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2171 "Negate number or subtract numbers or markers.\n\
2172 With one arg, negates it. With more than one arg,\n\
2173 subtracts all but the first from the first.")
2178 return arith_driver (Asub
, nargs
, args
);
2181 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2182 "Returns product of any number of arguments, which are numbers or markers.")
2187 return arith_driver (Amult
, nargs
, args
);
2190 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2191 "Returns first argument divided by all the remaining arguments.\n\
2192 The arguments must be numbers or markers.")
2197 return arith_driver (Adiv
, nargs
, args
);
2200 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2201 "Returns remainder of X divided by Y.\n\
2202 Both must be integers or markers.")
2204 register Lisp_Object x
, y
;
2208 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2209 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2211 if (XFASTINT (y
) == 0)
2212 Fsignal (Qarith_error
, Qnil
);
2214 XSETINT (val
, XINT (x
) % XINT (y
));
2228 /* If the magnitude of the result exceeds that of the divisor, or
2229 the sign of the result does not agree with that of the dividend,
2230 iterate with the reduced value. This does not yield a
2231 particularly accurate result, but at least it will be in the
2232 range promised by fmod. */
2234 r
-= f2
* floor (r
/ f2
);
2235 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2239 #endif /* ! HAVE_FMOD */
2241 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2242 "Returns X modulo Y.\n\
2243 The result falls between zero (inclusive) and Y (exclusive).\n\
2244 Both X and Y must be numbers or markers.")
2246 register Lisp_Object x
, y
;
2251 #ifdef LISP_FLOAT_TYPE
2252 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2253 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2255 if (FLOATP (x
) || FLOATP (y
))
2256 return fmod_float (x
, y
);
2258 #else /* not LISP_FLOAT_TYPE */
2259 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2260 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2261 #endif /* not LISP_FLOAT_TYPE */
2267 Fsignal (Qarith_error
, Qnil
);
2271 /* If the "remainder" comes out with the wrong sign, fix it. */
2272 if (i2
< 0 ? i1
> 0 : i1
< 0)
2279 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2280 "Return largest of all the arguments (which must be numbers or markers).\n\
2281 The value is always a number; markers are converted to numbers.")
2286 return arith_driver (Amax
, nargs
, args
);
2289 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2290 "Return smallest of all the arguments (which must be numbers or markers).\n\
2291 The value is always a number; markers are converted to numbers.")
2296 return arith_driver (Amin
, nargs
, args
);
2299 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2300 "Return bitwise-and of all the arguments.\n\
2301 Arguments may be integers, or markers converted to integers.")
2306 return arith_driver (Alogand
, nargs
, args
);
2309 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2310 "Return bitwise-or of all the arguments.\n\
2311 Arguments may be integers, or markers converted to integers.")
2316 return arith_driver (Alogior
, nargs
, args
);
2319 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2320 "Return bitwise-exclusive-or of all the arguments.\n\
2321 Arguments may be integers, or markers converted to integers.")
2326 return arith_driver (Alogxor
, nargs
, args
);
2329 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2330 "Return VALUE with its bits shifted left by COUNT.\n\
2331 If COUNT is negative, shifting is actually to the right.\n\
2332 In this case, the sign bit is duplicated.")
2334 register Lisp_Object value
, count
;
2336 register Lisp_Object val
;
2338 CHECK_NUMBER (value
, 0);
2339 CHECK_NUMBER (count
, 1);
2341 if (XINT (count
) > 0)
2342 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2344 XSETINT (val
, XINT (value
) >> -XINT (count
));
2348 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2349 "Return VALUE with its bits shifted left by COUNT.\n\
2350 If COUNT is negative, shifting is actually to the right.\n\
2351 In this case, zeros are shifted in on the left.")
2353 register Lisp_Object value
, count
;
2355 register Lisp_Object val
;
2357 CHECK_NUMBER (value
, 0);
2358 CHECK_NUMBER (count
, 1);
2360 if (XINT (count
) > 0)
2361 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2363 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2367 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2368 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2369 Markers are converted to integers.")
2371 register Lisp_Object number
;
2373 #ifdef LISP_FLOAT_TYPE
2374 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2376 if (FLOATP (number
))
2377 return (make_float (1.0 + XFLOAT (number
)->data
));
2379 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2380 #endif /* LISP_FLOAT_TYPE */
2382 XSETINT (number
, XINT (number
) + 1);
2386 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2387 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2388 Markers are converted to integers.")
2390 register Lisp_Object number
;
2392 #ifdef LISP_FLOAT_TYPE
2393 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2395 if (FLOATP (number
))
2396 return (make_float (-1.0 + XFLOAT (number
)->data
));
2398 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2399 #endif /* LISP_FLOAT_TYPE */
2401 XSETINT (number
, XINT (number
) - 1);
2405 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2406 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2408 register Lisp_Object number
;
2410 CHECK_NUMBER (number
, 0);
2411 XSETINT (number
, ~XINT (number
));
2418 Lisp_Object error_tail
, arith_tail
;
2420 Qquote
= intern ("quote");
2421 Qlambda
= intern ("lambda");
2422 Qsubr
= intern ("subr");
2423 Qerror_conditions
= intern ("error-conditions");
2424 Qerror_message
= intern ("error-message");
2425 Qtop_level
= intern ("top-level");
2427 Qerror
= intern ("error");
2428 Qquit
= intern ("quit");
2429 Qwrong_type_argument
= intern ("wrong-type-argument");
2430 Qargs_out_of_range
= intern ("args-out-of-range");
2431 Qvoid_function
= intern ("void-function");
2432 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2433 Qvoid_variable
= intern ("void-variable");
2434 Qsetting_constant
= intern ("setting-constant");
2435 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2437 Qinvalid_function
= intern ("invalid-function");
2438 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2439 Qno_catch
= intern ("no-catch");
2440 Qend_of_file
= intern ("end-of-file");
2441 Qarith_error
= intern ("arith-error");
2442 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2443 Qend_of_buffer
= intern ("end-of-buffer");
2444 Qbuffer_read_only
= intern ("buffer-read-only");
2445 Qmark_inactive
= intern ("mark-inactive");
2447 Qlistp
= intern ("listp");
2448 Qconsp
= intern ("consp");
2449 Qsymbolp
= intern ("symbolp");
2450 Qintegerp
= intern ("integerp");
2451 Qnatnump
= intern ("natnump");
2452 Qwholenump
= intern ("wholenump");
2453 Qstringp
= intern ("stringp");
2454 Qarrayp
= intern ("arrayp");
2455 Qsequencep
= intern ("sequencep");
2456 Qbufferp
= intern ("bufferp");
2457 Qvectorp
= intern ("vectorp");
2458 Qchar_or_string_p
= intern ("char-or-string-p");
2459 Qmarkerp
= intern ("markerp");
2460 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2461 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2462 Qboundp
= intern ("boundp");
2463 Qfboundp
= intern ("fboundp");
2465 #ifdef LISP_FLOAT_TYPE
2466 Qfloatp
= intern ("floatp");
2467 Qnumberp
= intern ("numberp");
2468 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2469 #endif /* LISP_FLOAT_TYPE */
2471 Qchar_table_p
= intern ("char-table-p");
2472 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2474 Qcdr
= intern ("cdr");
2476 /* Handle automatic advice activation */
2477 Qad_advice_info
= intern ("ad-advice-info");
2478 Qad_activate
= intern ("ad-activate");
2480 error_tail
= Fcons (Qerror
, Qnil
);
2482 /* ERROR is used as a signaler for random errors for which nothing else is right */
2484 Fput (Qerror
, Qerror_conditions
,
2486 Fput (Qerror
, Qerror_message
,
2487 build_string ("error"));
2489 Fput (Qquit
, Qerror_conditions
,
2490 Fcons (Qquit
, Qnil
));
2491 Fput (Qquit
, Qerror_message
,
2492 build_string ("Quit"));
2494 Fput (Qwrong_type_argument
, Qerror_conditions
,
2495 Fcons (Qwrong_type_argument
, error_tail
));
2496 Fput (Qwrong_type_argument
, Qerror_message
,
2497 build_string ("Wrong type argument"));
2499 Fput (Qargs_out_of_range
, Qerror_conditions
,
2500 Fcons (Qargs_out_of_range
, error_tail
));
2501 Fput (Qargs_out_of_range
, Qerror_message
,
2502 build_string ("Args out of range"));
2504 Fput (Qvoid_function
, Qerror_conditions
,
2505 Fcons (Qvoid_function
, error_tail
));
2506 Fput (Qvoid_function
, Qerror_message
,
2507 build_string ("Symbol's function definition is void"));
2509 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2510 Fcons (Qcyclic_function_indirection
, error_tail
));
2511 Fput (Qcyclic_function_indirection
, Qerror_message
,
2512 build_string ("Symbol's chain of function indirections contains a loop"));
2514 Fput (Qvoid_variable
, Qerror_conditions
,
2515 Fcons (Qvoid_variable
, error_tail
));
2516 Fput (Qvoid_variable
, Qerror_message
,
2517 build_string ("Symbol's value as variable is void"));
2519 Fput (Qsetting_constant
, Qerror_conditions
,
2520 Fcons (Qsetting_constant
, error_tail
));
2521 Fput (Qsetting_constant
, Qerror_message
,
2522 build_string ("Attempt to set a constant symbol"));
2524 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2525 Fcons (Qinvalid_read_syntax
, error_tail
));
2526 Fput (Qinvalid_read_syntax
, Qerror_message
,
2527 build_string ("Invalid read syntax"));
2529 Fput (Qinvalid_function
, Qerror_conditions
,
2530 Fcons (Qinvalid_function
, error_tail
));
2531 Fput (Qinvalid_function
, Qerror_message
,
2532 build_string ("Invalid function"));
2534 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2535 Fcons (Qwrong_number_of_arguments
, error_tail
));
2536 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2537 build_string ("Wrong number of arguments"));
2539 Fput (Qno_catch
, Qerror_conditions
,
2540 Fcons (Qno_catch
, error_tail
));
2541 Fput (Qno_catch
, Qerror_message
,
2542 build_string ("No catch for tag"));
2544 Fput (Qend_of_file
, Qerror_conditions
,
2545 Fcons (Qend_of_file
, error_tail
));
2546 Fput (Qend_of_file
, Qerror_message
,
2547 build_string ("End of file during parsing"));
2549 arith_tail
= Fcons (Qarith_error
, error_tail
);
2550 Fput (Qarith_error
, Qerror_conditions
,
2552 Fput (Qarith_error
, Qerror_message
,
2553 build_string ("Arithmetic error"));
2555 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2556 Fcons (Qbeginning_of_buffer
, error_tail
));
2557 Fput (Qbeginning_of_buffer
, Qerror_message
,
2558 build_string ("Beginning of buffer"));
2560 Fput (Qend_of_buffer
, Qerror_conditions
,
2561 Fcons (Qend_of_buffer
, error_tail
));
2562 Fput (Qend_of_buffer
, Qerror_message
,
2563 build_string ("End of buffer"));
2565 Fput (Qbuffer_read_only
, Qerror_conditions
,
2566 Fcons (Qbuffer_read_only
, error_tail
));
2567 Fput (Qbuffer_read_only
, Qerror_message
,
2568 build_string ("Buffer is read-only"));
2570 #ifdef LISP_FLOAT_TYPE
2571 Qrange_error
= intern ("range-error");
2572 Qdomain_error
= intern ("domain-error");
2573 Qsingularity_error
= intern ("singularity-error");
2574 Qoverflow_error
= intern ("overflow-error");
2575 Qunderflow_error
= intern ("underflow-error");
2577 Fput (Qdomain_error
, Qerror_conditions
,
2578 Fcons (Qdomain_error
, arith_tail
));
2579 Fput (Qdomain_error
, Qerror_message
,
2580 build_string ("Arithmetic domain error"));
2582 Fput (Qrange_error
, Qerror_conditions
,
2583 Fcons (Qrange_error
, arith_tail
));
2584 Fput (Qrange_error
, Qerror_message
,
2585 build_string ("Arithmetic range error"));
2587 Fput (Qsingularity_error
, Qerror_conditions
,
2588 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2589 Fput (Qsingularity_error
, Qerror_message
,
2590 build_string ("Arithmetic singularity error"));
2592 Fput (Qoverflow_error
, Qerror_conditions
,
2593 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2594 Fput (Qoverflow_error
, Qerror_message
,
2595 build_string ("Arithmetic overflow error"));
2597 Fput (Qunderflow_error
, Qerror_conditions
,
2598 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2599 Fput (Qunderflow_error
, Qerror_message
,
2600 build_string ("Arithmetic underflow error"));
2602 staticpro (&Qrange_error
);
2603 staticpro (&Qdomain_error
);
2604 staticpro (&Qsingularity_error
);
2605 staticpro (&Qoverflow_error
);
2606 staticpro (&Qunderflow_error
);
2607 #endif /* LISP_FLOAT_TYPE */
2611 staticpro (&Qquote
);
2612 staticpro (&Qlambda
);
2614 staticpro (&Qunbound
);
2615 staticpro (&Qerror_conditions
);
2616 staticpro (&Qerror_message
);
2617 staticpro (&Qtop_level
);
2619 staticpro (&Qerror
);
2621 staticpro (&Qwrong_type_argument
);
2622 staticpro (&Qargs_out_of_range
);
2623 staticpro (&Qvoid_function
);
2624 staticpro (&Qcyclic_function_indirection
);
2625 staticpro (&Qvoid_variable
);
2626 staticpro (&Qsetting_constant
);
2627 staticpro (&Qinvalid_read_syntax
);
2628 staticpro (&Qwrong_number_of_arguments
);
2629 staticpro (&Qinvalid_function
);
2630 staticpro (&Qno_catch
);
2631 staticpro (&Qend_of_file
);
2632 staticpro (&Qarith_error
);
2633 staticpro (&Qbeginning_of_buffer
);
2634 staticpro (&Qend_of_buffer
);
2635 staticpro (&Qbuffer_read_only
);
2636 staticpro (&Qmark_inactive
);
2638 staticpro (&Qlistp
);
2639 staticpro (&Qconsp
);
2640 staticpro (&Qsymbolp
);
2641 staticpro (&Qintegerp
);
2642 staticpro (&Qnatnump
);
2643 staticpro (&Qwholenump
);
2644 staticpro (&Qstringp
);
2645 staticpro (&Qarrayp
);
2646 staticpro (&Qsequencep
);
2647 staticpro (&Qbufferp
);
2648 staticpro (&Qvectorp
);
2649 staticpro (&Qchar_or_string_p
);
2650 staticpro (&Qmarkerp
);
2651 staticpro (&Qbuffer_or_string_p
);
2652 staticpro (&Qinteger_or_marker_p
);
2653 #ifdef LISP_FLOAT_TYPE
2654 staticpro (&Qfloatp
);
2655 staticpro (&Qnumberp
);
2656 staticpro (&Qnumber_or_marker_p
);
2657 #endif /* LISP_FLOAT_TYPE */
2658 staticpro (&Qchar_table_p
);
2659 staticpro (&Qvector_or_char_table_p
);
2661 staticpro (&Qboundp
);
2662 staticpro (&Qfboundp
);
2664 staticpro (&Qad_advice_info
);
2665 staticpro (&Qad_activate
);
2667 /* Types that type-of returns. */
2668 Qinteger
= intern ("integer");
2669 Qsymbol
= intern ("symbol");
2670 Qstring
= intern ("string");
2671 Qcons
= intern ("cons");
2672 Qmarker
= intern ("marker");
2673 Qoverlay
= intern ("overlay");
2674 Qfloat
= intern ("float");
2675 Qwindow_configuration
= intern ("window-configuration");
2676 Qprocess
= intern ("process");
2677 Qwindow
= intern ("window");
2678 /* Qsubr = intern ("subr"); */
2679 Qcompiled_function
= intern ("compiled-function");
2680 Qbuffer
= intern ("buffer");
2681 Qframe
= intern ("frame");
2682 Qvector
= intern ("vector");
2683 Qchar_table
= intern ("char-table");
2684 Qbool_vector
= intern ("bool-vector");
2686 staticpro (&Qinteger
);
2687 staticpro (&Qsymbol
);
2688 staticpro (&Qstring
);
2690 staticpro (&Qmarker
);
2691 staticpro (&Qoverlay
);
2692 staticpro (&Qfloat
);
2693 staticpro (&Qwindow_configuration
);
2694 staticpro (&Qprocess
);
2695 staticpro (&Qwindow
);
2696 /* staticpro (&Qsubr); */
2697 staticpro (&Qcompiled_function
);
2698 staticpro (&Qbuffer
);
2699 staticpro (&Qframe
);
2700 staticpro (&Qvector
);
2701 staticpro (&Qchar_table
);
2702 staticpro (&Qbool_vector
);
2706 defsubr (&Stype_of
);
2711 defsubr (&Sintegerp
);
2712 defsubr (&Sinteger_or_marker_p
);
2713 defsubr (&Snumberp
);
2714 defsubr (&Snumber_or_marker_p
);
2715 #ifdef LISP_FLOAT_TYPE
2717 #endif /* LISP_FLOAT_TYPE */
2718 defsubr (&Snatnump
);
2719 defsubr (&Ssymbolp
);
2720 defsubr (&Sstringp
);
2721 defsubr (&Svectorp
);
2722 defsubr (&Schar_table_p
);
2723 defsubr (&Svector_or_char_table_p
);
2724 defsubr (&Sbool_vector_p
);
2726 defsubr (&Ssequencep
);
2727 defsubr (&Sbufferp
);
2728 defsubr (&Smarkerp
);
2730 defsubr (&Sbyte_code_function_p
);
2731 defsubr (&Schar_or_string_p
);
2734 defsubr (&Scar_safe
);
2735 defsubr (&Scdr_safe
);
2738 defsubr (&Ssymbol_function
);
2739 defsubr (&Sindirect_function
);
2740 defsubr (&Ssymbol_plist
);
2741 defsubr (&Ssymbol_name
);
2742 defsubr (&Smakunbound
);
2743 defsubr (&Sfmakunbound
);
2745 defsubr (&Sfboundp
);
2747 defsubr (&Sdefalias
);
2748 defsubr (&Ssetplist
);
2749 defsubr (&Ssymbol_value
);
2751 defsubr (&Sdefault_boundp
);
2752 defsubr (&Sdefault_value
);
2753 defsubr (&Sset_default
);
2754 defsubr (&Ssetq_default
);
2755 defsubr (&Smake_variable_buffer_local
);
2756 defsubr (&Smake_local_variable
);
2757 defsubr (&Skill_local_variable
);
2758 defsubr (&Slocal_variable_p
);
2759 defsubr (&Slocal_variable_if_set_p
);
2762 defsubr (&Snumber_to_string
);
2763 defsubr (&Sstring_to_number
);
2764 defsubr (&Seqlsign
);
2788 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2795 #if defined(USG) && !defined(POSIX_SIGNALS)
2796 /* USG systems forget handlers when they are used;
2797 must reestablish each time */
2798 signal (signo
, arith_error
);
2801 /* VMS systems are like USG. */
2802 signal (signo
, arith_error
);
2806 #else /* not BSD4_1 */
2807 sigsetmask (SIGEMPTYMASK
);
2808 #endif /* not BSD4_1 */
2810 Fsignal (Qarith_error
, Qnil
);
2815 /* Don't do this if just dumping out.
2816 We don't want to call `signal' in this case
2817 so that we don't have trouble with dumping
2818 signal-delivering routines in an inconsistent state. */
2822 #endif /* CANNOT_DUMP */
2823 signal (SIGFPE
, arith_error
);
2826 signal (SIGEMT
, arith_error
);