1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA. */
31 #include "syssignal.h"
33 #ifdef LISP_FLOAT_TYPE
35 #endif /* LISP_FLOAT_TYPE */
37 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
38 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
39 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
40 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
41 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
42 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
43 Lisp_Object Qend_of_file
, Qarith_error
;
44 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
45 Lisp_Object Qintegerp
, Qnatnump
, Qsymbolp
, Qlistp
, Qconsp
;
46 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
47 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
48 Lisp_Object Qbuffer_or_string_p
;
49 Lisp_Object Qboundp
, Qfboundp
;
52 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
53 Lisp_Object Qoverflow_error
, Qunderflow_error
;
55 #ifdef LISP_FLOAT_TYPE
57 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
60 static Lisp_Object
swap_in_symval_forwarding ();
63 wrong_type_argument (predicate
, value
)
64 register Lisp_Object predicate
, value
;
66 register Lisp_Object tem
;
69 if (!EQ (Vmocklisp_arguments
, Qt
))
71 if (XTYPE (value
) == Lisp_String
&&
72 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
73 return Fstring_to_number (value
);
74 if (XTYPE (value
) == Lisp_Int
&& EQ (predicate
, Qstringp
))
75 return Fnumber_to_string (value
);
77 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
78 tem
= call1 (predicate
, value
);
86 error ("Attempt to modify read-only object");
90 args_out_of_range (a1
, a2
)
94 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
98 args_out_of_range_3 (a1
, a2
, a3
)
99 Lisp_Object a1
, a2
, a3
;
102 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
109 register Lisp_Object val
;
110 XSET (val
, Lisp_Int
, num
);
114 /* On some machines, XINT needs a temporary location.
115 Here it is, in case it is needed. */
117 int sign_extend_temp
;
119 /* On a few machines, XINT can only be done by calling this. */
122 sign_extend_lisp_int (num
)
125 if (num
& (1 << (VALBITS
- 1)))
126 return num
| ((-1) << VALBITS
);
128 return num
& ((1 << VALBITS
) - 1);
131 /* Data type predicates */
133 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
134 "T if the two args are the same Lisp object.")
136 Lisp_Object obj1
, obj2
;
143 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
152 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
156 if (XTYPE (obj
) == Lisp_Cons
)
161 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
165 if (XTYPE (obj
) == Lisp_Cons
)
170 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
174 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
179 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
183 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
188 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
192 if (XTYPE (obj
) == Lisp_Symbol
)
197 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
201 if (XTYPE (obj
) == Lisp_Vector
)
206 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
210 if (XTYPE (obj
) == Lisp_String
)
215 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
219 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
224 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
225 "T if OBJECT is a sequence (list or array).")
227 register Lisp_Object obj
;
229 if (CONSP (obj
) || NILP (obj
) ||
230 XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
235 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
239 if (XTYPE (obj
) == Lisp_Buffer
)
244 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
248 if (XTYPE (obj
) == Lisp_Marker
)
253 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
257 if (XTYPE (obj
) == Lisp_Subr
)
262 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
263 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
267 if (XTYPE (obj
) == Lisp_Compiled
)
272 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0, "T if OBJECT is a character (a number) or a string.")
274 register Lisp_Object obj
;
276 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
281 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is a number.")
285 if (XTYPE (obj
) == Lisp_Int
)
290 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
291 "T if OBJECT is an integer or a marker (editor pointer).")
293 register Lisp_Object obj
;
295 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
300 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0, "T if OBJECT is a nonnegative number.")
304 if (XTYPE (obj
) == Lisp_Int
&& XINT (obj
) >= 0)
309 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
310 "T if OBJECT is a number (floating point or integer).")
320 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
321 Snumber_or_marker_p
, 1, 1, 0,
322 "T if OBJECT is a number or a marker.")
327 || XTYPE (obj
) == Lisp_Marker
)
332 #ifdef LISP_FLOAT_TYPE
333 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
334 "T if OBJECT is a floating point number.")
338 if (XTYPE (obj
) == Lisp_Float
)
342 #endif /* LISP_FLOAT_TYPE */
344 /* Extract and set components of lists */
346 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
347 "Return the car of CONSCELL. If arg is nil, return nil.\n\
348 Error if arg is not nil and not a cons cell. See also `car-safe'.")
350 register Lisp_Object list
;
354 if (XTYPE (list
) == Lisp_Cons
)
355 return XCONS (list
)->car
;
356 else if (EQ (list
, Qnil
))
359 list
= wrong_type_argument (Qlistp
, list
);
363 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
364 "Return the car of OBJECT if it is a cons cell, or else nil.")
368 if (XTYPE (object
) == Lisp_Cons
)
369 return XCONS (object
)->car
;
374 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
375 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
376 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
379 register Lisp_Object list
;
383 if (XTYPE (list
) == Lisp_Cons
)
384 return XCONS (list
)->cdr
;
385 else if (EQ (list
, Qnil
))
388 list
= wrong_type_argument (Qlistp
, list
);
392 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
393 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
397 if (XTYPE (object
) == Lisp_Cons
)
398 return XCONS (object
)->cdr
;
403 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
404 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
406 register Lisp_Object cell
, newcar
;
408 if (XTYPE (cell
) != Lisp_Cons
)
409 cell
= wrong_type_argument (Qconsp
, cell
);
412 XCONS (cell
)->car
= newcar
;
416 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
417 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
419 register Lisp_Object cell
, newcdr
;
421 if (XTYPE (cell
) != Lisp_Cons
)
422 cell
= wrong_type_argument (Qconsp
, cell
);
425 XCONS (cell
)->cdr
= newcdr
;
429 /* Extract and set components of symbols */
431 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
433 register Lisp_Object sym
;
435 Lisp_Object valcontents
;
436 CHECK_SYMBOL (sym
, 0);
438 valcontents
= XSYMBOL (sym
)->value
;
440 #ifdef SWITCH_ENUM_BUG
441 switch ((int) XTYPE (valcontents
))
443 switch (XTYPE (valcontents
))
446 case Lisp_Buffer_Local_Value
:
447 case Lisp_Some_Buffer_Local_Value
:
448 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
451 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
455 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
457 register Lisp_Object sym
;
459 CHECK_SYMBOL (sym
, 0);
460 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
461 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
465 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
467 register Lisp_Object sym
;
469 CHECK_SYMBOL (sym
, 0);
470 if (NILP (sym
) || EQ (sym
, Qt
))
471 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
472 Fset (sym
, Qunbound
);
476 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
478 register Lisp_Object sym
;
480 CHECK_SYMBOL (sym
, 0);
481 XSYMBOL (sym
)->function
= Qunbound
;
485 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
486 "Return SYMBOL's function definition. Error if that is void.")
488 register Lisp_Object symbol
;
490 CHECK_SYMBOL (symbol
, 0);
491 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
492 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
493 return XSYMBOL (symbol
)->function
;
496 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
498 register Lisp_Object sym
;
500 CHECK_SYMBOL (sym
, 0);
501 return XSYMBOL (sym
)->plist
;
504 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
506 register Lisp_Object sym
;
508 register Lisp_Object name
;
510 CHECK_SYMBOL (sym
, 0);
511 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
515 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
516 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
518 register Lisp_Object sym
, newdef
;
520 CHECK_SYMBOL (sym
, 0);
521 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
522 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
524 XSYMBOL (sym
)->function
= newdef
;
528 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
529 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
530 Associates the function with the current load file, if any.")
532 register Lisp_Object sym
, newdef
;
534 CHECK_SYMBOL (sym
, 0);
535 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
536 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
538 XSYMBOL (sym
)->function
= newdef
;
539 LOADHIST_ATTACH (sym
);
543 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
544 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
546 register Lisp_Object sym
, newplist
;
548 CHECK_SYMBOL (sym
, 0);
549 XSYMBOL (sym
)->plist
= newplist
;
554 /* Getting and setting values of symbols */
556 /* Given the raw contents of a symbol value cell,
557 return the Lisp value of the symbol.
558 This does not handle buffer-local variables; use
559 swap_in_symval_forwarding for that. */
562 do_symval_forwarding (valcontents
)
563 register Lisp_Object valcontents
;
565 register Lisp_Object val
;
566 #ifdef SWITCH_ENUM_BUG
567 switch ((int) XTYPE (valcontents
))
569 switch (XTYPE (valcontents
))
573 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
577 if (*XINTPTR (valcontents
))
582 return *XOBJFWD (valcontents
);
584 case Lisp_Buffer_Objfwd
:
585 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
590 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
591 of SYM. If SYM is buffer-local, VALCONTENTS should be the
592 buffer-independent contents of the value cell: forwarded just one
593 step past the buffer-localness. */
596 store_symval_forwarding (sym
, valcontents
, newval
)
598 register Lisp_Object valcontents
, newval
;
600 #ifdef SWITCH_ENUM_BUG
601 switch ((int) XTYPE (valcontents
))
603 switch (XTYPE (valcontents
))
607 CHECK_NUMBER (newval
, 1);
608 *XINTPTR (valcontents
) = XINT (newval
);
612 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
616 *XOBJFWD (valcontents
) = newval
;
619 case Lisp_Buffer_Objfwd
:
621 unsigned int offset
= XUINT (valcontents
);
623 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
625 if (! NILP (type
) && ! NILP (newval
)
626 && XTYPE (newval
) != XINT (type
))
627 buffer_slot_type_mismatch (valcontents
, newval
);
629 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
635 valcontents
= XSYMBOL (sym
)->value
;
636 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
637 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
638 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
640 XSYMBOL (sym
)->value
= newval
;
644 /* Set up the buffer-local symbol SYM for validity in the current
645 buffer. VALCONTENTS is the contents of its value cell.
646 Return the value forwarded one step past the buffer-local indicator. */
649 swap_in_symval_forwarding (sym
, valcontents
)
650 Lisp_Object sym
, valcontents
;
652 /* valcontents is a list
653 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
655 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
656 local_var_alist, that being the element whose car is this
657 variable. Or it can be a pointer to the
658 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
659 an element in its alist for this variable.
661 If the current buffer is not BUFFER, we store the current
662 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
663 appropriate alist element for the buffer now current and set up
664 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
665 element, and store into BUFFER.
667 Note that REALVALUE can be a forwarding pointer. */
669 register Lisp_Object tem1
;
670 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
672 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
674 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
675 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
676 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
678 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
679 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
680 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
681 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
683 return XCONS (valcontents
)->car
;
686 /* Find the value of a symbol, returning Qunbound if it's not bound.
687 This is helpful for code which just wants to get a variable's value
688 if it has one, without signalling an error.
689 Note that it must not be possible to quit
690 within this function. Great care is required for this. */
693 find_symbol_value (sym
)
696 register Lisp_Object valcontents
, tem1
;
697 register Lisp_Object val
;
698 CHECK_SYMBOL (sym
, 0);
699 valcontents
= XSYMBOL (sym
)->value
;
702 #ifdef SWITCH_ENUM_BUG
703 switch ((int) XTYPE (valcontents
))
705 switch (XTYPE (valcontents
))
708 case Lisp_Buffer_Local_Value
:
709 case Lisp_Some_Buffer_Local_Value
:
710 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
714 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
718 if (*XINTPTR (valcontents
))
723 return *XOBJFWD (valcontents
);
725 case Lisp_Buffer_Objfwd
:
726 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
735 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
736 "Return SYMBOL's value. Error if that is void.")
740 Lisp_Object val
= find_symbol_value (sym
);
742 if (EQ (val
, Qunbound
))
743 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
748 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
749 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
751 register Lisp_Object sym
, newval
;
753 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
755 #ifndef RTPC_REGISTER_BUG
756 register Lisp_Object valcontents
, tem1
, current_alist_element
;
757 #else /* RTPC_REGISTER_BUG */
758 register Lisp_Object tem1
;
759 Lisp_Object valcontents
, current_alist_element
;
760 #endif /* RTPC_REGISTER_BUG */
762 CHECK_SYMBOL (sym
, 0);
763 if (NILP (sym
) || EQ (sym
, Qt
))
764 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
765 valcontents
= XSYMBOL (sym
)->value
;
767 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
769 register int idx
= XUINT (valcontents
);
770 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
772 current_buffer
->local_var_flags
|= mask
;
775 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
776 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
778 /* valcontents is actually a pointer to a cons heading something like:
779 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
781 BUFFER is the last buffer for which this symbol's value was
784 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
785 local_var_alist, that being the element whose car is this
786 variable. Or it can be a pointer to the
787 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
788 have an element in its alist for this variable (that is, if
789 BUFFER sees the default value of this variable).
791 If we want to examine or set the value and BUFFER is current,
792 we just examine or set REALVALUE. If BUFFER is not current, we
793 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
794 then find the appropriate alist element for the buffer now
795 current and set up CURRENT-ALIST-ELEMENT. Then we set
796 REALVALUE out of that element, and store into BUFFER.
798 If we are setting the variable and the current buffer does
799 not have an alist entry for this variable, an alist entry is
802 Note that REALVALUE can be a forwarding pointer. Each time
803 it is examined or set, forwarding must be done. */
805 /* What value are we caching right now? */
806 current_alist_element
=
807 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
809 /* If the current buffer is not the buffer whose binding is
810 currently cached, or if it's a Lisp_Buffer_Local_Value and
811 we're looking at the default value, the cache is invalid; we
812 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
814 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
815 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
816 && EQ (XCONS (current_alist_element
)->car
,
817 current_alist_element
)))
819 /* Write out the cached value for the old buffer; copy it
820 back to its alist element. This works if the current
821 buffer only sees the default value, too. */
822 Fsetcdr (current_alist_element
,
823 do_symval_forwarding (XCONS (valcontents
)->car
));
825 /* Find the new value for CURRENT-ALIST-ELEMENT. */
826 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
829 /* This buffer still sees the default value. */
831 /* If the variable is a Lisp_Some_Buffer_Local_Value,
832 make CURRENT-ALIST-ELEMENT point to itself,
833 indicating that we're seeing the default value. */
834 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
835 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
837 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
838 new assoc for a local value and set
839 CURRENT-ALIST-ELEMENT to point to that. */
842 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
843 current_buffer
->local_var_alist
=
844 Fcons (tem1
, current_buffer
->local_var_alist
);
847 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
848 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
850 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
851 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
852 Lisp_Buffer
, current_buffer
);
854 valcontents
= XCONS (valcontents
)->car
;
857 /* If storing void (making the symbol void), forward only through
858 buffer-local indicator, not through Lisp_Objfwd, etc. */
860 store_symval_forwarding (sym
, Qnil
, newval
);
862 store_symval_forwarding (sym
, valcontents
, newval
);
867 /* Access or set a buffer-local symbol's default value. */
869 /* Return the default value of SYM, but don't check for voidness.
870 Return Qunbound or a Lisp_Void object if it is void. */
876 register Lisp_Object valcontents
;
878 CHECK_SYMBOL (sym
, 0);
879 valcontents
= XSYMBOL (sym
)->value
;
881 /* For a built-in buffer-local variable, get the default value
882 rather than letting do_symval_forwarding get the current value. */
883 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
885 register int idx
= XUINT (valcontents
);
887 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
888 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
891 /* Handle user-created local variables. */
892 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
893 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
895 /* If var is set up for a buffer that lacks a local value for it,
896 the current value is nominally the default value.
897 But the current value slot may be more up to date, since
898 ordinary setq stores just that slot. So use that. */
899 Lisp_Object current_alist_element
, alist_element_car
;
900 current_alist_element
901 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
902 alist_element_car
= XCONS (current_alist_element
)->car
;
903 if (EQ (alist_element_car
, current_alist_element
))
904 return do_symval_forwarding (XCONS (valcontents
)->car
);
906 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
908 /* For other variables, get the current value. */
909 return do_symval_forwarding (valcontents
);
912 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
913 "Return T if SYMBOL has a non-void default value.\n\
914 This is the value that is seen in buffers that do not have their own values\n\
919 register Lisp_Object value
;
921 value
= default_value (sym
);
922 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
926 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
927 "Return SYMBOL's default value.\n\
928 This is the value that is seen in buffers that do not have their own values\n\
929 for this variable. The default value is meaningful for variables with\n\
930 local bindings in certain buffers.")
934 register Lisp_Object value
;
936 value
= default_value (sym
);
937 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
938 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
942 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
943 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
944 The default value is seen in buffers that do not have their own values\n\
947 Lisp_Object sym
, value
;
949 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
951 CHECK_SYMBOL (sym
, 0);
952 valcontents
= XSYMBOL (sym
)->value
;
954 /* Handle variables like case-fold-search that have special slots
955 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
957 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
959 register int idx
= XUINT (valcontents
);
960 #ifndef RTPC_REGISTER_BUG
961 register struct buffer
*b
;
965 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
969 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
970 for (b
= all_buffers
; b
; b
= b
->next
)
971 if (!(b
->local_var_flags
& mask
))
972 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
977 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
978 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
979 return Fset (sym
, value
);
981 /* Store new value into the DEFAULT-VALUE slot */
982 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
984 /* If that slot is current, we must set the REALVALUE slot too */
985 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
986 alist_element_buffer
= Fcar (current_alist_element
);
987 if (EQ (alist_element_buffer
, current_alist_element
))
988 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
993 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
995 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
996 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
997 not have their own values for this variable.")
1001 register Lisp_Object args_left
;
1002 register Lisp_Object val
, sym
;
1003 struct gcpro gcpro1
;
1013 val
= Feval (Fcar (Fcdr (args_left
)));
1014 sym
= Fcar (args_left
);
1015 Fset_default (sym
, val
);
1016 args_left
= Fcdr (Fcdr (args_left
));
1018 while (!NILP (args_left
));
1024 /* Lisp functions for creating and removing buffer-local variables. */
1026 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1027 1, 1, "vMake Variable Buffer Local: ",
1028 "Make VARIABLE have a separate value for each buffer.\n\
1029 At any time, the value for the current buffer is in effect.\n\
1030 There is also a default value which is seen in any buffer which has not yet\n\
1031 set its own value.\n\
1032 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1033 for the current buffer if it was previously using the default value.\n\
1034 The function `default-value' gets the default value and `set-default' sets it.")
1036 register Lisp_Object sym
;
1038 register Lisp_Object tem
, valcontents
;
1040 CHECK_SYMBOL (sym
, 0);
1042 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1043 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1045 valcontents
= XSYMBOL (sym
)->value
;
1046 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1047 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1049 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1051 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1054 if (EQ (valcontents
, Qunbound
))
1055 XSYMBOL (sym
)->value
= Qnil
;
1056 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1057 XCONS (tem
)->car
= tem
;
1058 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1059 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1063 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1064 1, 1, "vMake Local Variable: ",
1065 "Make VARIABLE have a separate value in the current buffer.\n\
1066 Other buffers will continue to share a common default value.\n\
1067 See also `make-variable-buffer-local'.\n\n\
1068 If the variable is already arranged to become local when set,\n\
1069 this function causes a local value to exist for this buffer,\n\
1070 just as if the variable were set.")
1072 register Lisp_Object sym
;
1074 register Lisp_Object tem
, valcontents
;
1076 CHECK_SYMBOL (sym
, 0);
1078 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1079 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1081 valcontents
= XSYMBOL (sym
)->value
;
1082 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1083 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1085 tem
= Fboundp (sym
);
1087 /* Make sure the symbol has a local value in this particular buffer,
1088 by setting it to the same value it already has. */
1089 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1092 /* Make sure sym is set up to hold per-buffer values */
1093 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1095 if (EQ (valcontents
, Qunbound
))
1096 XSYMBOL (sym
)->value
= Qnil
;
1097 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1098 XCONS (tem
)->car
= tem
;
1099 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1100 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1102 /* Make sure this buffer has its own value of sym */
1103 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1106 current_buffer
->local_var_alist
1107 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1108 current_buffer
->local_var_alist
);
1110 /* Make sure symbol does not think it is set up for this buffer;
1111 force it to look once again for this buffer's value */
1113 /* This local variable avoids "expression too complex" on IBM RT. */
1116 xs
= XSYMBOL (sym
)->value
;
1117 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1118 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1122 /* If the symbol forwards into a C variable, then swap in the
1123 variable for this buffer immediately. If C code modifies the
1124 variable before we swap in, then that new value will clobber the
1125 default value the next time we swap. */
1126 valcontents
= XCONS (XSYMBOL (sym
)->value
)->car
;
1127 if (XTYPE (valcontents
) == Lisp_Intfwd
1128 || XTYPE (valcontents
) == Lisp_Boolfwd
1129 || XTYPE (valcontents
) == Lisp_Objfwd
)
1130 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1135 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1136 1, 1, "vKill Local Variable: ",
1137 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1138 From now on the default value will apply in this buffer.")
1140 register Lisp_Object sym
;
1142 register Lisp_Object tem
, valcontents
;
1144 CHECK_SYMBOL (sym
, 0);
1146 valcontents
= XSYMBOL (sym
)->value
;
1148 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1150 register int idx
= XUINT (valcontents
);
1151 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1155 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1156 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1157 current_buffer
->local_var_flags
&= ~mask
;
1162 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1163 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1166 /* Get rid of this buffer's alist element, if any */
1168 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1170 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1172 /* Make sure symbol does not think it is set up for this buffer;
1173 force it to look once again for this buffer's value */
1176 sv
= XSYMBOL (sym
)->value
;
1177 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1178 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1184 /* Find the function at the end of a chain of symbol function indirections. */
1186 /* If OBJECT is a symbol, find the end of its function chain and
1187 return the value found there. If OBJECT is not a symbol, just
1188 return it. If there is a cycle in the function chain, signal a
1189 cyclic-function-indirection error.
1191 This is like Findirect_function, except that it doesn't signal an
1192 error if the chain ends up unbound. */
1194 indirect_function (object
)
1195 register Lisp_Object object
;
1197 Lisp_Object tortise
, hare
;
1199 hare
= tortise
= object
;
1203 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1205 hare
= XSYMBOL (hare
)->function
;
1206 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1208 hare
= XSYMBOL (hare
)->function
;
1210 tortise
= XSYMBOL (tortise
)->function
;
1212 if (EQ (hare
, tortise
))
1213 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1219 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1220 "Return the function at the end of OBJECT's function chain.\n\
1221 If OBJECT is a symbol, follow all function indirections and return the final\n\
1222 function binding.\n\
1223 If OBJECT is not a symbol, just return it.\n\
1224 Signal a void-function error if the final symbol is unbound.\n\
1225 Signal a cyclic-function-indirection error if there is a loop in the\n\
1226 function chain of symbols.")
1228 register Lisp_Object object
;
1232 result
= indirect_function (object
);
1234 if (EQ (result
, Qunbound
))
1235 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1239 /* Extract and set vector and string elements */
1241 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1242 "Return the element of ARRAY at index INDEX.\n\
1243 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1245 register Lisp_Object array
;
1248 register int idxval
;
1250 CHECK_NUMBER (idx
, 1);
1251 idxval
= XINT (idx
);
1252 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1253 && XTYPE (array
) != Lisp_Compiled
)
1254 array
= wrong_type_argument (Qarrayp
, array
);
1255 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1256 args_out_of_range (array
, idx
);
1257 if (XTYPE (array
) == Lisp_String
)
1260 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1264 return XVECTOR (array
)->contents
[idxval
];
1267 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1268 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1269 ARRAY may be a vector or a string. INDEX starts at 0.")
1270 (array
, idx
, newelt
)
1271 register Lisp_Object array
;
1272 Lisp_Object idx
, newelt
;
1274 register int idxval
;
1276 CHECK_NUMBER (idx
, 1);
1277 idxval
= XINT (idx
);
1278 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1279 array
= wrong_type_argument (Qarrayp
, array
);
1280 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1281 args_out_of_range (array
, idx
);
1282 CHECK_IMPURE (array
);
1284 if (XTYPE (array
) == Lisp_Vector
)
1285 XVECTOR (array
)->contents
[idxval
] = newelt
;
1288 CHECK_NUMBER (newelt
, 2);
1289 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1296 Farray_length (array
)
1297 register Lisp_Object array
;
1299 register Lisp_Object size
;
1300 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1301 && XTYPE (array
) != Lisp_Compiled
)
1302 array
= wrong_type_argument (Qarrayp
, array
);
1303 XFASTINT (size
) = XVECTOR (array
)->size
;
1307 /* Arithmetic functions */
1309 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1312 arithcompare (num1
, num2
, comparison
)
1313 Lisp_Object num1
, num2
;
1314 enum comparison comparison
;
1319 #ifdef LISP_FLOAT_TYPE
1320 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1321 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1323 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1326 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1327 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1330 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1331 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1332 #endif /* LISP_FLOAT_TYPE */
1337 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1342 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1347 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1352 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1357 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1362 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1371 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1372 "T if two args, both numbers or markers, are equal.")
1374 register Lisp_Object num1
, num2
;
1376 return arithcompare (num1
, num2
, equal
);
1379 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1380 "T if first arg is less than second arg. Both must be numbers or markers.")
1382 register Lisp_Object num1
, num2
;
1384 return arithcompare (num1
, num2
, less
);
1387 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1388 "T if first arg is greater than second arg. Both must be numbers or markers.")
1390 register Lisp_Object num1
, num2
;
1392 return arithcompare (num1
, num2
, grtr
);
1395 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1396 "T if first arg is less than or equal to second arg.\n\
1397 Both must be numbers or markers.")
1399 register Lisp_Object num1
, num2
;
1401 return arithcompare (num1
, num2
, less_or_equal
);
1404 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1405 "T if first arg is greater than or equal to second arg.\n\
1406 Both must be numbers or markers.")
1408 register Lisp_Object num1
, num2
;
1410 return arithcompare (num1
, num2
, grtr_or_equal
);
1413 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1414 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1416 register Lisp_Object num1
, num2
;
1418 return arithcompare (num1
, num2
, notequal
);
1421 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1423 register Lisp_Object num
;
1425 #ifdef LISP_FLOAT_TYPE
1426 CHECK_NUMBER_OR_FLOAT (num
, 0);
1428 if (XTYPE(num
) == Lisp_Float
)
1430 if (XFLOAT(num
)->data
== 0.0)
1435 CHECK_NUMBER (num
, 0);
1436 #endif /* LISP_FLOAT_TYPE */
1443 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1449 unsigned int top
= i
>> 16;
1450 unsigned int bot
= i
& 0xFFFF;
1452 return make_number (bot
);
1454 return Fcons (make_number (-1), make_number (bot
));
1455 return Fcons (make_number (top
), make_number (bot
));
1465 top
= XCONS (c
)->car
;
1466 bot
= XCONS (c
)->cdr
;
1468 bot
= XCONS (bot
)->car
;
1469 return ((XINT (top
) << 16) | XINT (bot
));
1472 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1473 "Convert NUM to a string by printing it in decimal.\n\
1474 Uses a minus sign if negative.\n\
1475 NUM may be an integer or a floating point number.")
1481 #ifndef LISP_FLOAT_TYPE
1482 CHECK_NUMBER (num
, 0);
1484 CHECK_NUMBER_OR_FLOAT (num
, 0);
1486 if (XTYPE(num
) == Lisp_Float
)
1488 char pigbuf
[350]; /* see comments in float_to_string */
1490 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1491 return build_string (pigbuf
);
1493 #endif /* LISP_FLOAT_TYPE */
1495 sprintf (buffer
, "%d", XINT (num
));
1496 return build_string (buffer
);
1499 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1500 "Convert STRING to a number by parsing it as a decimal number.\n\
1501 This parses both integers and floating point numbers.")
1503 register Lisp_Object str
;
1507 CHECK_STRING (str
, 0);
1509 p
= XSTRING (str
)->data
;
1511 /* Skip any whitespace at the front of the number. Some versions of
1512 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1513 while (*p
== ' ' || *p
== '\t')
1516 #ifdef LISP_FLOAT_TYPE
1517 if (isfloat_string (p
))
1518 return make_float (atof (p
));
1519 #endif /* LISP_FLOAT_TYPE */
1521 return make_number (atoi (p
));
1525 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1527 extern Lisp_Object
float_arith_driver ();
1534 register Lisp_Object
*args
;
1536 register Lisp_Object val
;
1537 register int argnum
;
1541 #ifdef SWITCH_ENUM_BUG
1558 for (argnum
= 0; argnum
< nargs
; argnum
++)
1560 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1561 #ifdef LISP_FLOAT_TYPE
1562 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1564 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1565 return (float_arith_driver ((double) accum
, argnum
, code
,
1568 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1569 #endif /* LISP_FLOAT_TYPE */
1570 args
[argnum
] = val
; /* runs into a compiler bug. */
1571 next
= XINT (args
[argnum
]);
1572 #ifdef SWITCH_ENUM_BUG
1578 case Aadd
: accum
+= next
; break;
1580 if (!argnum
&& nargs
!= 1)
1584 case Amult
: accum
*= next
; break;
1586 if (!argnum
) accum
= next
;
1589 case Alogand
: accum
&= next
; break;
1590 case Alogior
: accum
|= next
; break;
1591 case Alogxor
: accum
^= next
; break;
1592 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1593 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1597 XSET (val
, Lisp_Int
, accum
);
1601 #ifdef LISP_FLOAT_TYPE
1603 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1605 register int argnum
;
1608 register Lisp_Object
*args
;
1610 register Lisp_Object val
;
1613 for (; argnum
< nargs
; argnum
++)
1615 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1616 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1618 if (XTYPE (val
) == Lisp_Float
)
1620 next
= XFLOAT (val
)->data
;
1624 args
[argnum
] = val
; /* runs into a compiler bug. */
1625 next
= XINT (args
[argnum
]);
1627 #ifdef SWITCH_ENUM_BUG
1637 if (!argnum
&& nargs
!= 1)
1653 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1655 if (!argnum
|| next
> accum
)
1659 if (!argnum
|| next
< accum
)
1665 return make_float (accum
);
1667 #endif /* LISP_FLOAT_TYPE */
1669 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1670 "Return sum of any number of arguments, which are numbers or markers.")
1675 return arith_driver (Aadd
, nargs
, args
);
1678 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1679 "Negate number or subtract numbers or markers.\n\
1680 With one arg, negates it. With more than one arg,\n\
1681 subtracts all but the first from the first.")
1686 return arith_driver (Asub
, nargs
, args
);
1689 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1690 "Returns product of any number of arguments, which are numbers or markers.")
1695 return arith_driver (Amult
, nargs
, args
);
1698 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1699 "Returns first argument divided by all the remaining arguments.\n\
1700 The arguments must be numbers or markers.")
1705 return arith_driver (Adiv
, nargs
, args
);
1708 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1709 "Returns remainder of first arg divided by second.\n\
1710 Both must be numbers or markers.")
1712 register Lisp_Object num1
, num2
;
1716 #ifdef LISP_FLOAT_TYPE
1717 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1718 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1720 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1724 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1725 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1726 #if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux)
1733 return (make_float (f1
));
1735 #else /* not LISP_FLOAT_TYPE */
1736 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1737 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1738 #endif /* not LISP_FLOAT_TYPE */
1740 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1744 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1745 "Return largest of all the arguments (which must be numbers or markers).\n\
1746 The value is always a number; markers are converted to numbers.")
1751 return arith_driver (Amax
, nargs
, args
);
1754 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1755 "Return smallest of all the arguments (which must be numbers or markers).\n\
1756 The value is always a number; markers are converted to numbers.")
1761 return arith_driver (Amin
, nargs
, args
);
1764 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1765 "Return bitwise-and of all the arguments.\n\
1766 Arguments may be integers, or markers converted to integers.")
1771 return arith_driver (Alogand
, nargs
, args
);
1774 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1775 "Return bitwise-or of all the arguments.\n\
1776 Arguments may be integers, or markers converted to integers.")
1781 return arith_driver (Alogior
, nargs
, args
);
1784 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1785 "Return bitwise-exclusive-or of all the arguments.\n\
1786 Arguments may be integers, or markers converted to integers.")
1791 return arith_driver (Alogxor
, nargs
, args
);
1794 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1795 "Return VALUE with its bits shifted left by COUNT.\n\
1796 If COUNT is negative, shifting is actually to the right.\n\
1797 In this case, the sign bit is duplicated.")
1799 register Lisp_Object num1
, num2
;
1801 register Lisp_Object val
;
1803 CHECK_NUMBER (num1
, 0);
1804 CHECK_NUMBER (num2
, 1);
1806 if (XINT (num2
) > 0)
1807 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1809 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1813 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1814 "Return VALUE with its bits shifted left by COUNT.\n\
1815 If COUNT is negative, shifting is actually to the right.\n\
1816 In this case, zeros are shifted in on the left.")
1818 register Lisp_Object num1
, num2
;
1820 register Lisp_Object val
;
1822 CHECK_NUMBER (num1
, 0);
1823 CHECK_NUMBER (num2
, 1);
1825 if (XINT (num2
) > 0)
1826 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1828 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1832 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1833 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1834 Markers are converted to integers.")
1836 register Lisp_Object num
;
1838 #ifdef LISP_FLOAT_TYPE
1839 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1841 if (XTYPE (num
) == Lisp_Float
)
1842 return (make_float (1.0 + XFLOAT (num
)->data
));
1844 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1845 #endif /* LISP_FLOAT_TYPE */
1847 XSETINT (num
, XFASTINT (num
) + 1);
1851 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1852 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1853 Markers are converted to integers.")
1855 register Lisp_Object num
;
1857 #ifdef LISP_FLOAT_TYPE
1858 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1860 if (XTYPE (num
) == Lisp_Float
)
1861 return (make_float (-1.0 + XFLOAT (num
)->data
));
1863 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1864 #endif /* LISP_FLOAT_TYPE */
1866 XSETINT (num
, XFASTINT (num
) - 1);
1870 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1871 "Return the bitwise complement of ARG. ARG must be an integer.")
1873 register Lisp_Object num
;
1875 CHECK_NUMBER (num
, 0);
1876 XSETINT (num
, ~XFASTINT (num
));
1883 Lisp_Object error_tail
, arith_tail
;
1885 Qquote
= intern ("quote");
1886 Qlambda
= intern ("lambda");
1887 Qsubr
= intern ("subr");
1888 Qerror_conditions
= intern ("error-conditions");
1889 Qerror_message
= intern ("error-message");
1890 Qtop_level
= intern ("top-level");
1892 Qerror
= intern ("error");
1893 Qquit
= intern ("quit");
1894 Qwrong_type_argument
= intern ("wrong-type-argument");
1895 Qargs_out_of_range
= intern ("args-out-of-range");
1896 Qvoid_function
= intern ("void-function");
1897 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
1898 Qvoid_variable
= intern ("void-variable");
1899 Qsetting_constant
= intern ("setting-constant");
1900 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1902 Qinvalid_function
= intern ("invalid-function");
1903 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1904 Qno_catch
= intern ("no-catch");
1905 Qend_of_file
= intern ("end-of-file");
1906 Qarith_error
= intern ("arith-error");
1907 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1908 Qend_of_buffer
= intern ("end-of-buffer");
1909 Qbuffer_read_only
= intern ("buffer-read-only");
1911 Qlistp
= intern ("listp");
1912 Qconsp
= intern ("consp");
1913 Qsymbolp
= intern ("symbolp");
1914 Qintegerp
= intern ("integerp");
1915 Qnatnump
= intern ("natnump");
1916 Qstringp
= intern ("stringp");
1917 Qarrayp
= intern ("arrayp");
1918 Qsequencep
= intern ("sequencep");
1919 Qbufferp
= intern ("bufferp");
1920 Qvectorp
= intern ("vectorp");
1921 Qchar_or_string_p
= intern ("char-or-string-p");
1922 Qmarkerp
= intern ("markerp");
1923 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
1924 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1925 Qboundp
= intern ("boundp");
1926 Qfboundp
= intern ("fboundp");
1928 #ifdef LISP_FLOAT_TYPE
1929 Qfloatp
= intern ("floatp");
1930 Qnumberp
= intern ("numberp");
1931 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1932 #endif /* LISP_FLOAT_TYPE */
1934 Qcdr
= intern ("cdr");
1936 error_tail
= Fcons (Qerror
, Qnil
);
1938 /* ERROR is used as a signaler for random errors for which nothing else is right */
1940 Fput (Qerror
, Qerror_conditions
,
1942 Fput (Qerror
, Qerror_message
,
1943 build_string ("error"));
1945 Fput (Qquit
, Qerror_conditions
,
1946 Fcons (Qquit
, Qnil
));
1947 Fput (Qquit
, Qerror_message
,
1948 build_string ("Quit"));
1950 Fput (Qwrong_type_argument
, Qerror_conditions
,
1951 Fcons (Qwrong_type_argument
, error_tail
));
1952 Fput (Qwrong_type_argument
, Qerror_message
,
1953 build_string ("Wrong type argument"));
1955 Fput (Qargs_out_of_range
, Qerror_conditions
,
1956 Fcons (Qargs_out_of_range
, error_tail
));
1957 Fput (Qargs_out_of_range
, Qerror_message
,
1958 build_string ("Args out of range"));
1960 Fput (Qvoid_function
, Qerror_conditions
,
1961 Fcons (Qvoid_function
, error_tail
));
1962 Fput (Qvoid_function
, Qerror_message
,
1963 build_string ("Symbol's function definition is void"));
1965 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
1966 Fcons (Qcyclic_function_indirection
, error_tail
));
1967 Fput (Qcyclic_function_indirection
, Qerror_message
,
1968 build_string ("Symbol's chain of function indirections contains a loop"));
1970 Fput (Qvoid_variable
, Qerror_conditions
,
1971 Fcons (Qvoid_variable
, error_tail
));
1972 Fput (Qvoid_variable
, Qerror_message
,
1973 build_string ("Symbol's value as variable is void"));
1975 Fput (Qsetting_constant
, Qerror_conditions
,
1976 Fcons (Qsetting_constant
, error_tail
));
1977 Fput (Qsetting_constant
, Qerror_message
,
1978 build_string ("Attempt to set a constant symbol"));
1980 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
1981 Fcons (Qinvalid_read_syntax
, error_tail
));
1982 Fput (Qinvalid_read_syntax
, Qerror_message
,
1983 build_string ("Invalid read syntax"));
1985 Fput (Qinvalid_function
, Qerror_conditions
,
1986 Fcons (Qinvalid_function
, error_tail
));
1987 Fput (Qinvalid_function
, Qerror_message
,
1988 build_string ("Invalid function"));
1990 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
1991 Fcons (Qwrong_number_of_arguments
, error_tail
));
1992 Fput (Qwrong_number_of_arguments
, Qerror_message
,
1993 build_string ("Wrong number of arguments"));
1995 Fput (Qno_catch
, Qerror_conditions
,
1996 Fcons (Qno_catch
, error_tail
));
1997 Fput (Qno_catch
, Qerror_message
,
1998 build_string ("No catch for tag"));
2000 Fput (Qend_of_file
, Qerror_conditions
,
2001 Fcons (Qend_of_file
, error_tail
));
2002 Fput (Qend_of_file
, Qerror_message
,
2003 build_string ("End of file during parsing"));
2005 arith_tail
= Fcons (Qarith_error
, error_tail
);
2006 Fput (Qarith_error
, Qerror_conditions
,
2008 Fput (Qarith_error
, Qerror_message
,
2009 build_string ("Arithmetic error"));
2011 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2012 Fcons (Qbeginning_of_buffer
, error_tail
));
2013 Fput (Qbeginning_of_buffer
, Qerror_message
,
2014 build_string ("Beginning of buffer"));
2016 Fput (Qend_of_buffer
, Qerror_conditions
,
2017 Fcons (Qend_of_buffer
, error_tail
));
2018 Fput (Qend_of_buffer
, Qerror_message
,
2019 build_string ("End of buffer"));
2021 Fput (Qbuffer_read_only
, Qerror_conditions
,
2022 Fcons (Qbuffer_read_only
, error_tail
));
2023 Fput (Qbuffer_read_only
, Qerror_message
,
2024 build_string ("Buffer is read-only"));
2026 #ifdef LISP_FLOAT_TYPE
2027 Qrange_error
= intern ("range-error");
2028 Qdomain_error
= intern ("domain-error");
2029 Qsingularity_error
= intern ("singularity-error");
2030 Qoverflow_error
= intern ("overflow-error");
2031 Qunderflow_error
= intern ("underflow-error");
2033 Fput (Qdomain_error
, Qerror_conditions
,
2034 Fcons (Qdomain_error
, arith_tail
));
2035 Fput (Qdomain_error
, Qerror_message
,
2036 build_string ("Arithmetic domain error"));
2038 Fput (Qrange_error
, Qerror_conditions
,
2039 Fcons (Qrange_error
, arith_tail
));
2040 Fput (Qrange_error
, Qerror_message
,
2041 build_string ("Arithmetic range error"));
2043 Fput (Qsingularity_error
, Qerror_conditions
,
2044 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2045 Fput (Qsingularity_error
, Qerror_message
,
2046 build_string ("Arithmetic singularity error"));
2048 Fput (Qoverflow_error
, Qerror_conditions
,
2049 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2050 Fput (Qoverflow_error
, Qerror_message
,
2051 build_string ("Arithmetic overflow error"));
2053 Fput (Qunderflow_error
, Qerror_conditions
,
2054 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2055 Fput (Qunderflow_error
, Qerror_message
,
2056 build_string ("Arithmetic underflow error"));
2058 staticpro (&Qrange_error
);
2059 staticpro (&Qdomain_error
);
2060 staticpro (&Qsingularity_error
);
2061 staticpro (&Qoverflow_error
);
2062 staticpro (&Qunderflow_error
);
2063 #endif /* LISP_FLOAT_TYPE */
2067 staticpro (&Qquote
);
2068 staticpro (&Qlambda
);
2070 staticpro (&Qunbound
);
2071 staticpro (&Qerror_conditions
);
2072 staticpro (&Qerror_message
);
2073 staticpro (&Qtop_level
);
2075 staticpro (&Qerror
);
2077 staticpro (&Qwrong_type_argument
);
2078 staticpro (&Qargs_out_of_range
);
2079 staticpro (&Qvoid_function
);
2080 staticpro (&Qcyclic_function_indirection
);
2081 staticpro (&Qvoid_variable
);
2082 staticpro (&Qsetting_constant
);
2083 staticpro (&Qinvalid_read_syntax
);
2084 staticpro (&Qwrong_number_of_arguments
);
2085 staticpro (&Qinvalid_function
);
2086 staticpro (&Qno_catch
);
2087 staticpro (&Qend_of_file
);
2088 staticpro (&Qarith_error
);
2089 staticpro (&Qbeginning_of_buffer
);
2090 staticpro (&Qend_of_buffer
);
2091 staticpro (&Qbuffer_read_only
);
2093 staticpro (&Qlistp
);
2094 staticpro (&Qconsp
);
2095 staticpro (&Qsymbolp
);
2096 staticpro (&Qintegerp
);
2097 staticpro (&Qnatnump
);
2098 staticpro (&Qstringp
);
2099 staticpro (&Qarrayp
);
2100 staticpro (&Qsequencep
);
2101 staticpro (&Qbufferp
);
2102 staticpro (&Qvectorp
);
2103 staticpro (&Qchar_or_string_p
);
2104 staticpro (&Qmarkerp
);
2105 staticpro (&Qbuffer_or_string_p
);
2106 staticpro (&Qinteger_or_marker_p
);
2107 #ifdef LISP_FLOAT_TYPE
2108 staticpro (&Qfloatp
);
2109 staticpro (&Qnumberp
);
2110 staticpro (&Qnumber_or_marker_p
);
2111 #endif /* LISP_FLOAT_TYPE */
2113 staticpro (&Qboundp
);
2114 staticpro (&Qfboundp
);
2123 defsubr (&Sintegerp
);
2124 defsubr (&Sinteger_or_marker_p
);
2125 defsubr (&Snumberp
);
2126 defsubr (&Snumber_or_marker_p
);
2127 #ifdef LISP_FLOAT_TYPE
2129 #endif /* LISP_FLOAT_TYPE */
2130 defsubr (&Snatnump
);
2131 defsubr (&Ssymbolp
);
2132 defsubr (&Sstringp
);
2133 defsubr (&Svectorp
);
2135 defsubr (&Ssequencep
);
2136 defsubr (&Sbufferp
);
2137 defsubr (&Smarkerp
);
2139 defsubr (&Sbyte_code_function_p
);
2140 defsubr (&Schar_or_string_p
);
2143 defsubr (&Scar_safe
);
2144 defsubr (&Scdr_safe
);
2147 defsubr (&Ssymbol_function
);
2148 defsubr (&Sindirect_function
);
2149 defsubr (&Ssymbol_plist
);
2150 defsubr (&Ssymbol_name
);
2151 defsubr (&Smakunbound
);
2152 defsubr (&Sfmakunbound
);
2154 defsubr (&Sfboundp
);
2156 defsubr (&Sdefalias
);
2157 defsubr (&Ssetplist
);
2158 defsubr (&Ssymbol_value
);
2160 defsubr (&Sdefault_boundp
);
2161 defsubr (&Sdefault_value
);
2162 defsubr (&Sset_default
);
2163 defsubr (&Ssetq_default
);
2164 defsubr (&Smake_variable_buffer_local
);
2165 defsubr (&Smake_local_variable
);
2166 defsubr (&Skill_local_variable
);
2169 defsubr (&Snumber_to_string
);
2170 defsubr (&Sstring_to_number
);
2171 defsubr (&Seqlsign
);
2200 /* USG systems forget handlers when they are used;
2201 must reestablish each time */
2202 signal (signo
, arith_error
);
2205 /* VMS systems are like USG. */
2206 signal (signo
, arith_error
);
2210 #else /* not BSD4_1 */
2211 sigsetmask (SIGEMPTYMASK
);
2212 #endif /* not BSD4_1 */
2214 Fsignal (Qarith_error
, Qnil
);
2219 /* Don't do this if just dumping out.
2220 We don't want to call `signal' in this case
2221 so that we don't have trouble with dumping
2222 signal-delivering routines in an inconsistent state. */
2226 #endif /* CANNOT_DUMP */
2227 signal (SIGFPE
, arith_error
);
2230 signal (SIGEMT
, arith_error
);