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 Qboundp
, Qfboundp
;
51 #ifdef LISP_FLOAT_TYPE
53 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
56 static Lisp_Object
swap_in_symval_forwarding ();
59 wrong_type_argument (predicate
, value
)
60 register Lisp_Object predicate
, value
;
62 register Lisp_Object tem
;
65 if (!EQ (Vmocklisp_arguments
, Qt
))
67 if (XTYPE (value
) == Lisp_String
&&
68 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
69 return Fstring_to_int (value
, Qt
);
70 if (XTYPE (value
) == Lisp_Int
&& EQ (predicate
, Qstringp
))
71 return Fint_to_string (value
);
73 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
74 tem
= call1 (predicate
, value
);
82 error ("Attempt to modify read-only object");
86 args_out_of_range (a1
, a2
)
90 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
94 args_out_of_range_3 (a1
, a2
, a3
)
95 Lisp_Object a1
, a2
, a3
;
98 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
105 register Lisp_Object val
;
106 XSET (val
, Lisp_Int
, num
);
110 /* On some machines, XINT needs a temporary location.
111 Here it is, in case it is needed. */
113 int sign_extend_temp
;
115 /* On a few machines, XINT can only be done by calling this. */
118 sign_extend_lisp_int (num
)
121 if (num
& (1 << (VALBITS
- 1)))
122 return num
| ((-1) << VALBITS
);
124 return num
& ((1 << VALBITS
) - 1);
127 /* Data type predicates */
129 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
130 "T if the two args are the same Lisp object.")
132 Lisp_Object obj1
, obj2
;
139 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
148 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
152 if (XTYPE (obj
) == Lisp_Cons
)
157 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
161 if (XTYPE (obj
) == Lisp_Cons
)
166 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
170 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
175 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
179 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
184 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
188 if (XTYPE (obj
) == Lisp_Symbol
)
193 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
197 if (XTYPE (obj
) == Lisp_Vector
)
202 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
206 if (XTYPE (obj
) == Lisp_String
)
211 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
215 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
220 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
221 "T if OBJECT is a sequence (list or array).")
223 register Lisp_Object obj
;
225 if (CONSP (obj
) || NILP (obj
) ||
226 XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
231 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
235 if (XTYPE (obj
) == Lisp_Buffer
)
240 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
244 if (XTYPE (obj
) == Lisp_Marker
)
249 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
253 if (XTYPE (obj
) == Lisp_Subr
)
258 DEFUN ("compiled-function-p", Fcompiled_function_p
, Scompiled_function_p
,
259 1, 1, 0, "T if OBJECT is a compiled function object.")
263 if (XTYPE (obj
) == Lisp_Compiled
)
268 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.")
270 register Lisp_Object obj
;
272 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
277 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is a number.")
281 if (XTYPE (obj
) == Lisp_Int
)
286 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
287 "T if OBJECT is an integer or a marker (editor pointer).")
289 register Lisp_Object obj
;
291 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
296 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0, "T if OBJECT is a nonnegative number.")
300 if (XTYPE (obj
) == Lisp_Int
&& XINT (obj
) >= 0)
305 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
306 "T if OBJECT is a number (floating point or integer).")
311 #ifdef LISP_FLOAT_TYPE
312 || XTYPE (obj
) == Lisp_Float
314 || XTYPE (obj
) == Lisp_Int
)
319 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
320 Snumber_or_marker_p
, 1, 1, 0,
321 "T if OBJECT is a number or a marker.")
325 if (XTYPE (obj
) == Lisp_Int
326 #ifdef LISP_FLOAT_TYPE
327 || XTYPE (obj
) == Lisp_Float
329 || XTYPE (obj
) == Lisp_Marker
)
334 #ifdef LISP_FLOAT_TYPE
335 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
336 "T if OBJECT is a floating point number.")
340 if (XTYPE (obj
) == Lisp_Float
)
344 #endif /* LISP_FLOAT_TYPE */
346 /* Extract and set components of lists */
348 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
349 "Return the car of CONSCELL. If arg is nil, return nil.\n\
350 Error if arg is not nil and not a cons cell. See also `car-safe'.")
352 register Lisp_Object list
;
356 if (XTYPE (list
) == Lisp_Cons
)
357 return XCONS (list
)->car
;
358 else if (EQ (list
, Qnil
))
361 list
= wrong_type_argument (Qlistp
, list
);
365 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
366 "Return the car of OBJECT if it is a cons cell, or else nil.")
370 if (XTYPE (object
) == Lisp_Cons
)
371 return XCONS (object
)->car
;
376 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
377 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
378 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
381 register Lisp_Object list
;
385 if (XTYPE (list
) == Lisp_Cons
)
386 return XCONS (list
)->cdr
;
387 else if (EQ (list
, Qnil
))
390 list
= wrong_type_argument (Qlistp
, list
);
394 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
395 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
399 if (XTYPE (object
) == Lisp_Cons
)
400 return XCONS (object
)->cdr
;
405 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
406 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
408 register Lisp_Object cell
, newcar
;
410 if (XTYPE (cell
) != Lisp_Cons
)
411 cell
= wrong_type_argument (Qconsp
, cell
);
414 XCONS (cell
)->car
= newcar
;
418 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
419 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
421 register Lisp_Object cell
, newcdr
;
423 if (XTYPE (cell
) != Lisp_Cons
)
424 cell
= wrong_type_argument (Qconsp
, cell
);
427 XCONS (cell
)->cdr
= newcdr
;
431 /* Extract and set components of symbols */
433 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
435 register Lisp_Object sym
;
437 Lisp_Object valcontents
;
438 CHECK_SYMBOL (sym
, 0);
440 valcontents
= XSYMBOL (sym
)->value
;
442 #ifdef SWITCH_ENUM_BUG
443 switch ((int) XTYPE (valcontents
))
445 switch (XTYPE (valcontents
))
448 case Lisp_Buffer_Local_Value
:
449 case Lisp_Some_Buffer_Local_Value
:
450 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
453 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
457 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
459 register Lisp_Object sym
;
461 CHECK_SYMBOL (sym
, 0);
462 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
463 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
467 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
469 register Lisp_Object sym
;
471 CHECK_SYMBOL (sym
, 0);
472 if (NILP (sym
) || EQ (sym
, Qt
))
473 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
474 Fset (sym
, Qunbound
);
478 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
480 register Lisp_Object sym
;
482 CHECK_SYMBOL (sym
, 0);
483 XSYMBOL (sym
)->function
= Qunbound
;
487 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
488 "Return SYMBOL's function definition. Error if that is void.")
490 register Lisp_Object symbol
;
492 CHECK_SYMBOL (symbol
, 0);
493 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
494 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
495 return XSYMBOL (symbol
)->function
;
498 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
500 register Lisp_Object sym
;
502 CHECK_SYMBOL (sym
, 0);
503 return XSYMBOL (sym
)->plist
;
506 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
508 register Lisp_Object sym
;
510 register Lisp_Object name
;
512 CHECK_SYMBOL (sym
, 0);
513 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
517 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
518 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
520 register Lisp_Object sym
, newdef
;
522 CHECK_SYMBOL (sym
, 0);
523 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
524 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
526 XSYMBOL (sym
)->function
= newdef
;
530 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
531 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
533 register Lisp_Object sym
, newplist
;
535 CHECK_SYMBOL (sym
, 0);
536 XSYMBOL (sym
)->plist
= newplist
;
541 /* Getting and setting values of symbols */
543 /* Given the raw contents of a symbol value cell,
544 return the Lisp value of the symbol.
545 This does not handle buffer-local variables; use
546 swap_in_symval_forwarding for that. */
549 do_symval_forwarding (valcontents
)
550 register Lisp_Object valcontents
;
552 register Lisp_Object val
;
553 #ifdef SWITCH_ENUM_BUG
554 switch ((int) XTYPE (valcontents
))
556 switch (XTYPE (valcontents
))
560 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
564 if (*XINTPTR (valcontents
))
569 return *XOBJFWD (valcontents
);
571 case Lisp_Buffer_Objfwd
:
572 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
577 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
578 of SYM. If SYM is buffer-local, VALCONTENTS should be the
579 buffer-independent contents of the value cell: forwarded just one
580 step past the buffer-localness. */
583 store_symval_forwarding (sym
, valcontents
, newval
)
585 register Lisp_Object valcontents
, newval
;
587 #ifdef SWITCH_ENUM_BUG
588 switch ((int) XTYPE (valcontents
))
590 switch (XTYPE (valcontents
))
594 CHECK_NUMBER (newval
, 1);
595 *XINTPTR (valcontents
) = XINT (newval
);
599 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
603 *XOBJFWD (valcontents
) = newval
;
606 case Lisp_Buffer_Objfwd
:
608 unsigned int offset
= XUINT (valcontents
);
610 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
612 if (! NILP (type
) && ! NILP (newval
)
613 && XTYPE (newval
) != XINT (type
))
614 buffer_slot_type_mismatch (valcontents
, newval
);
616 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
622 valcontents
= XSYMBOL (sym
)->value
;
623 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
624 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
625 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
627 XSYMBOL (sym
)->value
= newval
;
631 /* Set up the buffer-local symbol SYM for validity in the current
632 buffer. VALCONTENTS is the contents of its value cell.
633 Return the value forwarded one step past the buffer-local indicator. */
636 swap_in_symval_forwarding (sym
, valcontents
)
637 Lisp_Object sym
, valcontents
;
639 /* valcontents is a list
640 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
642 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
643 local_var_alist, that being the element whose car is this variable.
644 Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
645 does not have an element in its alist for this variable.
647 If the current buffer is not BUFFER, we store the current REALVALUE value into
648 CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
649 the buffer now current and set up CURRENT-ALIST-ELEMENT.
650 Then we set REALVALUE out of that element, and store into BUFFER.
651 Note that REALVALUE can be a forwarding pointer. */
653 register Lisp_Object tem1
;
654 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
656 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
658 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
659 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
660 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
662 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
663 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
664 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
665 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
667 return XCONS (valcontents
)->car
;
670 /* Find the value of a symbol, returning Qunbound if it's not bound.
671 This is helpful for code which just wants to get a variable's value
672 if it has one, without signalling an error.
673 Note that it must not be possible to quit
674 within this function. Great care is required for this. */
677 find_symbol_value (sym
)
680 register Lisp_Object valcontents
, tem1
;
681 register Lisp_Object val
;
682 CHECK_SYMBOL (sym
, 0);
683 valcontents
= XSYMBOL (sym
)->value
;
686 #ifdef SWITCH_ENUM_BUG
687 switch ((int) XTYPE (valcontents
))
689 switch (XTYPE (valcontents
))
692 case Lisp_Buffer_Local_Value
:
693 case Lisp_Some_Buffer_Local_Value
:
694 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
698 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
702 if (*XINTPTR (valcontents
))
707 return *XOBJFWD (valcontents
);
709 case Lisp_Buffer_Objfwd
:
710 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
719 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
720 "Return SYMBOL's value. Error if that is void.")
724 Lisp_Object val
= find_symbol_value (sym
);
726 if (EQ (val
, Qunbound
))
727 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
732 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
733 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
735 register Lisp_Object sym
, newval
;
737 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
739 #ifndef RTPC_REGISTER_BUG
740 register Lisp_Object valcontents
, tem1
, current_alist_element
;
741 #else /* RTPC_REGISTER_BUG */
742 register Lisp_Object tem1
;
743 Lisp_Object valcontents
, current_alist_element
;
744 #endif /* RTPC_REGISTER_BUG */
746 CHECK_SYMBOL (sym
, 0);
747 if (NILP (sym
) || EQ (sym
, Qt
))
748 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
749 valcontents
= XSYMBOL (sym
)->value
;
751 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
753 register int idx
= XUINT (valcontents
);
754 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
756 current_buffer
->local_var_flags
|= mask
;
759 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
760 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
762 /* valcontents is actually a pointer to a cons heading something like:
763 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
765 BUFFER is the last buffer for which this symbol's value was
768 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
769 local_var_alist, that being the element whose car is this
770 variable. Or it can be a pointer to the
771 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
772 have an element in its alist for this variable (that is, if
773 BUFFER sees the default value of this variable).
775 If we want to examine or set the value and BUFFER is current,
776 we just examine or set REALVALUE. If BUFFER is not current, we
777 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
778 then find the appropriate alist element for the buffer now
779 current and set up CURRENT-ALIST-ELEMENT. Then we set
780 REALVALUE out of that element, and store into BUFFER.
782 If we are setting the variable and the current buffer does
783 not have an alist entry for this variable, an alist entry is
786 Note that REALVALUE can be a forwarding pointer. Each time
787 it is examined or set, forwarding must be done. */
789 /* What value are we caching right now? */
790 current_alist_element
=
791 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
793 /* If the current buffer is not the buffer whose binding is
794 currently cached, or if it's a Lisp_Buffer_Local_Value and
795 we're looking at the default value, the cache is invalid; we
796 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
798 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
799 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
800 && XCONS (current_alist_element
)->car
== current_alist_element
))
802 /* Write out the cached value for the old buffer; copy it
803 back to its alist element. This works if the current
804 buffer only sees the default value, too. */
805 Fsetcdr (current_alist_element
,
806 do_symval_forwarding (XCONS (valcontents
)->car
));
808 /* Find the new value for CURRENT-ALIST-ELEMENT. */
809 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
812 /* This buffer still sees the default value. */
814 /* If the variable is a Lisp_Some_Buffer_Local_Value,
815 make CURRENT-ALIST-ELEMENT point to itself,
816 indicating that we're seeing the default value. */
817 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
818 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
820 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
821 new assoc for a local value and set
822 CURRENT-ALIST-ELEMENT to point to that. */
825 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
826 current_buffer
->local_var_alist
=
827 Fcons (tem1
, current_buffer
->local_var_alist
);
830 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
831 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
833 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
834 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
835 Lisp_Buffer
, current_buffer
);
837 valcontents
= XCONS (valcontents
)->car
;
840 /* If storing void (making the symbol void), forward only through
841 buffer-local indicator, not through Lisp_Objfwd, etc. */
843 store_symval_forwarding (sym
, Qnil
, newval
);
845 store_symval_forwarding (sym
, valcontents
, newval
);
850 /* Access or set a buffer-local symbol's default value. */
852 /* Return the default value of SYM, but don't check for voidness.
853 Return Qunbound or a Lisp_Void object if it is void. */
859 register Lisp_Object valcontents
;
861 CHECK_SYMBOL (sym
, 0);
862 valcontents
= XSYMBOL (sym
)->value
;
864 /* For a built-in buffer-local variable, get the default value
865 rather than letting do_symval_forwarding get the current value. */
866 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
868 register int idx
= XUINT (valcontents
);
870 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
871 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
874 /* Handle user-created local variables. */
875 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
876 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
878 /* If var is set up for a buffer that lacks a local value for it,
879 the current value is nominally the default value.
880 But the current value slot may be more up to date, since
881 ordinary setq stores just that slot. So use that. */
882 Lisp_Object current_alist_element
, alist_element_car
;
883 current_alist_element
884 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
885 alist_element_car
= XCONS (current_alist_element
)->car
;
886 if (EQ (alist_element_car
, current_alist_element
))
887 return do_symval_forwarding (XCONS (valcontents
)->car
);
889 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
891 /* For other variables, get the current value. */
892 return do_symval_forwarding (valcontents
);
895 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
896 "Return T if SYMBOL has a non-void default value.\n\
897 This is the value that is seen in buffers that do not have their own values\n\
902 register Lisp_Object value
;
904 value
= default_value (sym
);
905 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
909 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
910 "Return SYMBOL's default value.\n\
911 This is the value that is seen in buffers that do not have their own values\n\
912 for this variable. The default value is meaningful for variables with\n\
913 local bindings in certain buffers.")
917 register Lisp_Object value
;
919 value
= default_value (sym
);
920 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
921 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
925 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
926 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
927 The default value is seen in buffers that do not have their own values\n\
930 Lisp_Object sym
, value
;
932 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
934 CHECK_SYMBOL (sym
, 0);
935 valcontents
= XSYMBOL (sym
)->value
;
937 /* Handle variables like case-fold-search that have special slots
938 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
940 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
942 register int idx
= XUINT (valcontents
);
943 #ifndef RTPC_REGISTER_BUG
944 register struct buffer
*b
;
948 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
952 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
953 for (b
= all_buffers
; b
; b
= b
->next
)
954 if (!(b
->local_var_flags
& mask
))
955 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
960 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
961 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
962 return Fset (sym
, value
);
964 /* Store new value into the DEFAULT-VALUE slot */
965 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
967 /* If that slot is current, we must set the REALVALUE slot too */
968 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
969 alist_element_buffer
= Fcar (current_alist_element
);
970 if (EQ (alist_element_buffer
, current_alist_element
))
971 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
976 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
978 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
979 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
980 not have their own values for this variable.")
984 register Lisp_Object args_left
;
985 register Lisp_Object val
, sym
;
996 val
= Feval (Fcar (Fcdr (args_left
)));
997 sym
= Fcar (args_left
);
998 Fset_default (sym
, val
);
999 args_left
= Fcdr (Fcdr (args_left
));
1001 while (!NILP (args_left
));
1007 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1008 1, 1, "vMake Variable Buffer Local: ",
1009 "Make VARIABLE have a separate value for each buffer.\n\
1010 At any time, the value for the current buffer is in effect.\n\
1011 There is also a default value which is seen in any buffer which has not yet\n\
1012 set its own value.\n\
1013 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1014 for the current buffer if it was previously using the default value.\n\
1015 The function `default-value' gets the default value and `set-default' sets it.")
1017 register Lisp_Object sym
;
1019 register Lisp_Object tem
, valcontents
;
1021 CHECK_SYMBOL (sym
, 0);
1023 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1024 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1026 valcontents
= XSYMBOL (sym
)->value
;
1027 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1028 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1030 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1032 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1035 if (EQ (valcontents
, Qunbound
))
1036 XSYMBOL (sym
)->value
= Qnil
;
1037 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1038 XCONS (tem
)->car
= tem
;
1039 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1040 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1044 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1045 1, 1, "vMake Local Variable: ",
1046 "Make VARIABLE have a separate value in the current buffer.\n\
1047 Other buffers will continue to share a common default value.\n\
1048 See also `make-variable-buffer-local'.\n\n\
1049 If the variable is already arranged to become local when set,\n\
1050 this function causes a local value to exist for this buffer,\n\
1051 just as if the variable were set.")
1053 register Lisp_Object sym
;
1055 register Lisp_Object tem
, valcontents
;
1057 CHECK_SYMBOL (sym
, 0);
1059 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1060 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1062 valcontents
= XSYMBOL (sym
)->value
;
1063 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1064 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1066 tem
= Fboundp (sym
);
1068 /* Make sure the symbol has a local value in this particular buffer,
1069 by setting it to the same value it already has. */
1070 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1073 /* Make sure sym is set up to hold per-buffer values */
1074 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1076 if (EQ (valcontents
, Qunbound
))
1077 XSYMBOL (sym
)->value
= Qnil
;
1078 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1079 XCONS (tem
)->car
= tem
;
1080 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1081 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1083 /* Make sure this buffer has its own value of sym */
1084 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1087 current_buffer
->local_var_alist
1088 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1089 current_buffer
->local_var_alist
);
1091 /* Make sure symbol does not think it is set up for this buffer;
1092 force it to look once again for this buffer's value */
1094 /* This local variable avoids "expression too complex" on IBM RT. */
1097 xs
= XSYMBOL (sym
)->value
;
1098 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1099 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1106 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1107 1, 1, "vKill Local Variable: ",
1108 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1109 From now on the default value will apply in this buffer.")
1111 register Lisp_Object sym
;
1113 register Lisp_Object tem
, valcontents
;
1115 CHECK_SYMBOL (sym
, 0);
1117 valcontents
= XSYMBOL (sym
)->value
;
1119 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1121 register int idx
= XUINT (valcontents
);
1122 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1126 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1127 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1128 current_buffer
->local_var_flags
&= ~mask
;
1133 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1134 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1137 /* Get rid of this buffer's alist element, if any */
1139 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1141 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1143 /* Make sure symbol does not think it is set up for this buffer;
1144 force it to look once again for this buffer's value */
1147 sv
= XSYMBOL (sym
)->value
;
1148 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1149 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1155 /* Find the function at the end of a chain of symbol function indirections. */
1157 /* If OBJECT is a symbol, find the end of its function chain and
1158 return the value found there. If OBJECT is not a symbol, just
1159 return it. If there is a cycle in the function chain, signal a
1160 cyclic-function-indirection error.
1162 This is like Findirect_function, except that it doesn't signal an
1163 error if the chain ends up unbound. */
1165 indirect_function (object
, error
)
1166 register Lisp_Object object
;
1168 Lisp_Object tortise
, hare
;
1170 hare
= tortise
= object
;
1174 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1176 hare
= XSYMBOL (hare
)->function
;
1177 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1179 hare
= XSYMBOL (hare
)->function
;
1181 tortise
= XSYMBOL (tortise
)->function
;
1183 if (EQ (hare
, tortise
))
1184 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1190 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1191 "Return the function at the end of OBJECT's function chain.\n\
1192 If OBJECT is a symbol, follow all function indirections and return the final\n\
1193 function binding.\n\
1194 If OBJECT is not a symbol, just return it.\n\
1195 Signal a void-function error if the final symbol is unbound.\n\
1196 Signal a cyclic-function-indirection error if there is a loop in the\n\
1197 function chain of symbols.")
1199 register Lisp_Object object
;
1203 result
= indirect_function (object
);
1205 if (EQ (result
, Qunbound
))
1206 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1210 /* Extract and set vector and string elements */
1212 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1213 "Return the element of ARRAY at index INDEX.\n\
1214 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1216 register Lisp_Object array
;
1219 register int idxval
;
1221 CHECK_NUMBER (idx
, 1);
1222 idxval
= XINT (idx
);
1223 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1224 && XTYPE (array
) != Lisp_Compiled
)
1225 array
= wrong_type_argument (Qarrayp
, array
);
1226 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1227 args_out_of_range (array
, idx
);
1228 if (XTYPE (array
) == Lisp_String
)
1231 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1235 return XVECTOR (array
)->contents
[idxval
];
1238 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1239 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1240 ARRAY may be a vector or a string. INDEX starts at 0.")
1241 (array
, idx
, newelt
)
1242 register Lisp_Object array
;
1243 Lisp_Object idx
, newelt
;
1245 register int idxval
;
1247 CHECK_NUMBER (idx
, 1);
1248 idxval
= XINT (idx
);
1249 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1250 array
= wrong_type_argument (Qarrayp
, array
);
1251 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1252 args_out_of_range (array
, idx
);
1253 CHECK_IMPURE (array
);
1255 if (XTYPE (array
) == Lisp_Vector
)
1256 XVECTOR (array
)->contents
[idxval
] = newelt
;
1259 CHECK_NUMBER (newelt
, 2);
1260 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1267 Farray_length (array
)
1268 register Lisp_Object array
;
1270 register Lisp_Object size
;
1271 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1272 && XTYPE (array
) != Lisp_Compiled
)
1273 array
= wrong_type_argument (Qarrayp
, array
);
1274 XFASTINT (size
) = XVECTOR (array
)->size
;
1278 /* Arithmetic functions */
1280 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1283 arithcompare (num1
, num2
, comparison
)
1284 Lisp_Object num1
, num2
;
1285 enum comparison comparison
;
1290 #ifdef LISP_FLOAT_TYPE
1291 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1292 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1294 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1297 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1298 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1301 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1302 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1303 #endif /* LISP_FLOAT_TYPE */
1308 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1313 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1318 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1323 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1328 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1333 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1339 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1340 "T if two args, both numbers or markers, are equal.")
1342 register Lisp_Object num1
, num2
;
1344 return arithcompare (num1
, num2
, equal
);
1347 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1348 "T if first arg is less than second arg. Both must be numbers or markers.")
1350 register Lisp_Object num1
, num2
;
1352 return arithcompare (num1
, num2
, less
);
1355 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1356 "T if first arg is greater than second arg. Both must be numbers or markers.")
1358 register Lisp_Object num1
, num2
;
1360 return arithcompare (num1
, num2
, grtr
);
1363 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1364 "T if first arg is less than or equal to second arg.\n\
1365 Both must be numbers or markers.")
1367 register Lisp_Object num1
, num2
;
1369 return arithcompare (num1
, num2
, less_or_equal
);
1372 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1373 "T if first arg is greater than or equal to second arg.\n\
1374 Both must be numbers or markers.")
1376 register Lisp_Object num1
, num2
;
1378 return arithcompare (num1
, num2
, grtr_or_equal
);
1381 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1382 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1384 register Lisp_Object num1
, num2
;
1386 return arithcompare (num1
, num2
, notequal
);
1389 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1391 register Lisp_Object num
;
1393 #ifdef LISP_FLOAT_TYPE
1394 CHECK_NUMBER_OR_FLOAT (num
, 0);
1396 if (XTYPE(num
) == Lisp_Float
)
1398 if (XFLOAT(num
)->data
== 0.0)
1403 CHECK_NUMBER (num
, 0);
1404 #endif /* LISP_FLOAT_TYPE */
1411 DEFUN ("int-to-string", Fint_to_string
, Sint_to_string
, 1, 1, 0,
1412 "Convert INT to a string by printing it in decimal.\n\
1413 Uses a minus sign if negative.")
1419 #ifndef LISP_FLOAT_TYPE
1420 CHECK_NUMBER (num
, 0);
1422 CHECK_NUMBER_OR_FLOAT (num
, 0);
1424 if (XTYPE(num
) == Lisp_Float
)
1426 char pigbuf
[350]; /* see comments in float_to_string */
1428 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1429 return build_string (pigbuf
);
1431 #endif /* LISP_FLOAT_TYPE */
1433 sprintf (buffer
, "%d", XINT (num
));
1434 return build_string (buffer
);
1437 DEFUN ("string-to-int", Fstring_to_int
, Sstring_to_int
, 1, 1, 0,
1438 "Convert STRING to an integer by parsing it as a decimal number.")
1440 register Lisp_Object str
;
1442 CHECK_STRING (str
, 0);
1444 #ifdef LISP_FLOAT_TYPE
1445 if (isfloat_string (XSTRING (str
)->data
))
1446 return make_float (atof (XSTRING (str
)->data
));
1447 #endif /* LISP_FLOAT_TYPE */
1449 return make_number (atoi (XSTRING (str
)->data
));
1453 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1460 register Lisp_Object
*args
;
1462 register Lisp_Object val
;
1463 register int argnum
;
1467 #ifdef SWITCH_ENUM_BUG
1484 for (argnum
= 0; argnum
< nargs
; argnum
++)
1486 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1487 #ifdef LISP_FLOAT_TYPE
1488 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1490 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1491 return (float_arith_driver ((double) accum
, argnum
, code
,
1494 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1495 #endif /* LISP_FLOAT_TYPE */
1496 args
[argnum
] = val
; /* runs into a compiler bug. */
1497 next
= XINT (args
[argnum
]);
1498 #ifdef SWITCH_ENUM_BUG
1504 case Aadd
: accum
+= next
; break;
1506 if (!argnum
&& nargs
!= 1)
1510 case Amult
: accum
*= next
; break;
1512 if (!argnum
) accum
= next
;
1515 case Alogand
: accum
&= next
; break;
1516 case Alogior
: accum
|= next
; break;
1517 case Alogxor
: accum
^= next
; break;
1518 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1519 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1523 XSET (val
, Lisp_Int
, accum
);
1527 #ifdef LISP_FLOAT_TYPE
1529 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1531 register int argnum
;
1534 register Lisp_Object
*args
;
1536 register Lisp_Object val
;
1539 for (; argnum
< nargs
; argnum
++)
1541 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1542 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1544 if (XTYPE (val
) == Lisp_Float
)
1546 next
= XFLOAT (val
)->data
;
1550 args
[argnum
] = val
; /* runs into a compiler bug. */
1551 next
= XINT (args
[argnum
]);
1553 #ifdef SWITCH_ENUM_BUG
1563 if (!argnum
&& nargs
!= 1)
1579 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1581 if (!argnum
|| next
> accum
)
1585 if (!argnum
|| next
< accum
)
1591 return make_float (accum
);
1593 #endif /* LISP_FLOAT_TYPE */
1595 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1596 "Return sum of any number of arguments, which are numbers or markers.")
1601 return arith_driver (Aadd
, nargs
, args
);
1604 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1605 "Negate number or subtract numbers or markers.\n\
1606 With one arg, negates it. With more than one arg,\n\
1607 subtracts all but the first from the first.")
1612 return arith_driver (Asub
, nargs
, args
);
1615 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1616 "Returns product of any number of arguments, which are numbers or markers.")
1621 return arith_driver (Amult
, nargs
, args
);
1624 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1625 "Returns first argument divided by all the remaining arguments.\n\
1626 The arguments must be numbers or markers.")
1631 return arith_driver (Adiv
, nargs
, args
);
1634 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1635 "Returns remainder of first arg divided by second.\n\
1636 Both must be numbers or markers.")
1638 register Lisp_Object num1
, num2
;
1642 #ifdef LISP_FLOAT_TYPE
1643 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1644 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1646 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1650 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1651 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1659 return (make_float (f1
));
1661 #else /* not LISP_FLOAT_TYPE */
1662 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1663 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1664 #endif /* not LISP_FLOAT_TYPE */
1666 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1670 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1671 "Return largest of all the arguments (which must be numbers or markers).\n\
1672 The value is always a number; markers are converted to numbers.")
1677 return arith_driver (Amax
, nargs
, args
);
1680 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1681 "Return smallest of all the arguments (which must be numbers or markers).\n\
1682 The value is always a number; markers are converted to numbers.")
1687 return arith_driver (Amin
, nargs
, args
);
1690 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1691 "Return bitwise-and of all the arguments.\n\
1692 Arguments may be integers, or markers converted to integers.")
1697 return arith_driver (Alogand
, nargs
, args
);
1700 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1701 "Return bitwise-or of all the arguments.\n\
1702 Arguments may be integers, or markers converted to integers.")
1707 return arith_driver (Alogior
, nargs
, args
);
1710 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1711 "Return bitwise-exclusive-or of all the arguments.\n\
1712 Arguments may be integers, or markers converted to integers.")
1717 return arith_driver (Alogxor
, nargs
, args
);
1720 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1721 "Return VALUE with its bits shifted left by COUNT.\n\
1722 If COUNT is negative, shifting is actually to the right.\n\
1723 In this case, the sign bit is duplicated.")
1725 register Lisp_Object num1
, num2
;
1727 register Lisp_Object val
;
1729 CHECK_NUMBER (num1
, 0);
1730 CHECK_NUMBER (num2
, 1);
1732 if (XINT (num2
) > 0)
1733 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1735 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1739 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1740 "Return VALUE with its bits shifted left by COUNT.\n\
1741 If COUNT is negative, shifting is actually to the right.\n\
1742 In this case, zeros are shifted in on the left.")
1744 register Lisp_Object num1
, num2
;
1746 register Lisp_Object val
;
1748 CHECK_NUMBER (num1
, 0);
1749 CHECK_NUMBER (num2
, 1);
1751 if (XINT (num2
) > 0)
1752 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1754 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1758 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1759 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1760 Markers are converted to integers.")
1762 register Lisp_Object num
;
1764 #ifdef LISP_FLOAT_TYPE
1765 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1767 if (XTYPE (num
) == Lisp_Float
)
1768 return (make_float (1.0 + XFLOAT (num
)->data
));
1770 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1771 #endif /* LISP_FLOAT_TYPE */
1773 XSETINT (num
, XFASTINT (num
) + 1);
1777 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1778 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1779 Markers are converted to integers.")
1781 register Lisp_Object num
;
1783 #ifdef LISP_FLOAT_TYPE
1784 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1786 if (XTYPE (num
) == Lisp_Float
)
1787 return (make_float (-1.0 + XFLOAT (num
)->data
));
1789 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1790 #endif /* LISP_FLOAT_TYPE */
1792 XSETINT (num
, XFASTINT (num
) - 1);
1796 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1797 "Return the bitwise complement of ARG. ARG must be an integer.")
1799 register Lisp_Object num
;
1801 CHECK_NUMBER (num
, 0);
1802 XSETINT (num
, ~XFASTINT (num
));
1809 Qquote
= intern ("quote");
1810 Qlambda
= intern ("lambda");
1811 Qsubr
= intern ("subr");
1812 Qerror_conditions
= intern ("error-conditions");
1813 Qerror_message
= intern ("error-message");
1814 Qtop_level
= intern ("top-level");
1816 Qerror
= intern ("error");
1817 Qquit
= intern ("quit");
1818 Qwrong_type_argument
= intern ("wrong-type-argument");
1819 Qargs_out_of_range
= intern ("args-out-of-range");
1820 Qvoid_function
= intern ("void-function");
1821 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
1822 Qvoid_variable
= intern ("void-variable");
1823 Qsetting_constant
= intern ("setting-constant");
1824 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1826 Qinvalid_function
= intern ("invalid-function");
1827 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1828 Qno_catch
= intern ("no-catch");
1829 Qend_of_file
= intern ("end-of-file");
1830 Qarith_error
= intern ("arith-error");
1831 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1832 Qend_of_buffer
= intern ("end-of-buffer");
1833 Qbuffer_read_only
= intern ("buffer-read-only");
1835 Qlistp
= intern ("listp");
1836 Qconsp
= intern ("consp");
1837 Qsymbolp
= intern ("symbolp");
1838 Qintegerp
= intern ("integerp");
1839 Qnatnump
= intern ("natnump");
1840 Qstringp
= intern ("stringp");
1841 Qarrayp
= intern ("arrayp");
1842 Qsequencep
= intern ("sequencep");
1843 Qbufferp
= intern ("bufferp");
1844 Qvectorp
= intern ("vectorp");
1845 Qchar_or_string_p
= intern ("char-or-string-p");
1846 Qmarkerp
= intern ("markerp");
1847 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1848 Qboundp
= intern ("boundp");
1849 Qfboundp
= intern ("fboundp");
1851 #ifdef LISP_FLOAT_TYPE
1852 Qfloatp
= intern ("floatp");
1853 Qnumberp
= intern ("numberp");
1854 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1855 #endif /* LISP_FLOAT_TYPE */
1857 Qcdr
= intern ("cdr");
1859 /* ERROR is used as a signaler for random errors for which nothing else is right */
1861 Fput (Qerror
, Qerror_conditions
,
1862 Fcons (Qerror
, Qnil
));
1863 Fput (Qerror
, Qerror_message
,
1864 build_string ("error"));
1866 Fput (Qquit
, Qerror_conditions
,
1867 Fcons (Qquit
, Qnil
));
1868 Fput (Qquit
, Qerror_message
,
1869 build_string ("Quit"));
1871 Fput (Qwrong_type_argument
, Qerror_conditions
,
1872 Fcons (Qwrong_type_argument
, Fcons (Qerror
, Qnil
)));
1873 Fput (Qwrong_type_argument
, Qerror_message
,
1874 build_string ("Wrong type argument"));
1876 Fput (Qargs_out_of_range
, Qerror_conditions
,
1877 Fcons (Qargs_out_of_range
, Fcons (Qerror
, Qnil
)));
1878 Fput (Qargs_out_of_range
, Qerror_message
,
1879 build_string ("Args out of range"));
1881 Fput (Qvoid_function
, Qerror_conditions
,
1882 Fcons (Qvoid_function
, Fcons (Qerror
, Qnil
)));
1883 Fput (Qvoid_function
, Qerror_message
,
1884 build_string ("Symbol's function definition is void"));
1886 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
1887 Fcons (Qcyclic_function_indirection
, Fcons (Qerror
, Qnil
)));
1888 Fput (Qcyclic_function_indirection
, Qerror_message
,
1889 build_string ("Symbol's chain of function indirections contains a loop"));
1891 Fput (Qvoid_variable
, Qerror_conditions
,
1892 Fcons (Qvoid_variable
, Fcons (Qerror
, Qnil
)));
1893 Fput (Qvoid_variable
, Qerror_message
,
1894 build_string ("Symbol's value as variable is void"));
1896 Fput (Qsetting_constant
, Qerror_conditions
,
1897 Fcons (Qsetting_constant
, Fcons (Qerror
, Qnil
)));
1898 Fput (Qsetting_constant
, Qerror_message
,
1899 build_string ("Attempt to set a constant symbol"));
1901 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
1902 Fcons (Qinvalid_read_syntax
, Fcons (Qerror
, Qnil
)));
1903 Fput (Qinvalid_read_syntax
, Qerror_message
,
1904 build_string ("Invalid read syntax"));
1906 Fput (Qinvalid_function
, Qerror_conditions
,
1907 Fcons (Qinvalid_function
, Fcons (Qerror
, Qnil
)));
1908 Fput (Qinvalid_function
, Qerror_message
,
1909 build_string ("Invalid function"));
1911 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
1912 Fcons (Qwrong_number_of_arguments
, Fcons (Qerror
, Qnil
)));
1913 Fput (Qwrong_number_of_arguments
, Qerror_message
,
1914 build_string ("Wrong number of arguments"));
1916 Fput (Qno_catch
, Qerror_conditions
,
1917 Fcons (Qno_catch
, Fcons (Qerror
, Qnil
)));
1918 Fput (Qno_catch
, Qerror_message
,
1919 build_string ("No catch for tag"));
1921 Fput (Qend_of_file
, Qerror_conditions
,
1922 Fcons (Qend_of_file
, Fcons (Qerror
, Qnil
)));
1923 Fput (Qend_of_file
, Qerror_message
,
1924 build_string ("End of file during parsing"));
1926 Fput (Qarith_error
, Qerror_conditions
,
1927 Fcons (Qarith_error
, Fcons (Qerror
, Qnil
)));
1928 Fput (Qarith_error
, Qerror_message
,
1929 build_string ("Arithmetic error"));
1931 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
1932 Fcons (Qbeginning_of_buffer
, Fcons (Qerror
, Qnil
)));
1933 Fput (Qbeginning_of_buffer
, Qerror_message
,
1934 build_string ("Beginning of buffer"));
1936 Fput (Qend_of_buffer
, Qerror_conditions
,
1937 Fcons (Qend_of_buffer
, Fcons (Qerror
, Qnil
)));
1938 Fput (Qend_of_buffer
, Qerror_message
,
1939 build_string ("End of buffer"));
1941 Fput (Qbuffer_read_only
, Qerror_conditions
,
1942 Fcons (Qbuffer_read_only
, Fcons (Qerror
, Qnil
)));
1943 Fput (Qbuffer_read_only
, Qerror_message
,
1944 build_string ("Buffer is read-only"));
1948 staticpro (&Qquote
);
1949 staticpro (&Qlambda
);
1951 staticpro (&Qunbound
);
1952 staticpro (&Qerror_conditions
);
1953 staticpro (&Qerror_message
);
1954 staticpro (&Qtop_level
);
1956 staticpro (&Qerror
);
1958 staticpro (&Qwrong_type_argument
);
1959 staticpro (&Qargs_out_of_range
);
1960 staticpro (&Qvoid_function
);
1961 staticpro (&Qcyclic_function_indirection
);
1962 staticpro (&Qvoid_variable
);
1963 staticpro (&Qsetting_constant
);
1964 staticpro (&Qinvalid_read_syntax
);
1965 staticpro (&Qwrong_number_of_arguments
);
1966 staticpro (&Qinvalid_function
);
1967 staticpro (&Qno_catch
);
1968 staticpro (&Qend_of_file
);
1969 staticpro (&Qarith_error
);
1970 staticpro (&Qbeginning_of_buffer
);
1971 staticpro (&Qend_of_buffer
);
1972 staticpro (&Qbuffer_read_only
);
1974 staticpro (&Qlistp
);
1975 staticpro (&Qconsp
);
1976 staticpro (&Qsymbolp
);
1977 staticpro (&Qintegerp
);
1978 staticpro (&Qnatnump
);
1979 staticpro (&Qstringp
);
1980 staticpro (&Qarrayp
);
1981 staticpro (&Qsequencep
);
1982 staticpro (&Qbufferp
);
1983 staticpro (&Qvectorp
);
1984 staticpro (&Qchar_or_string_p
);
1985 staticpro (&Qmarkerp
);
1986 staticpro (&Qinteger_or_marker_p
);
1987 #ifdef LISP_FLOAT_TYPE
1988 staticpro (&Qfloatp
);
1989 staticpro (&Qnumberp
);
1990 staticpro (&Qnumber_or_marker_p
);
1991 #endif /* LISP_FLOAT_TYPE */
1993 staticpro (&Qboundp
);
1994 staticpro (&Qfboundp
);
2003 defsubr (&Sintegerp
);
2004 defsubr (&Sinteger_or_marker_p
);
2005 defsubr (&Snumberp
);
2006 defsubr (&Snumber_or_marker_p
);
2007 #ifdef LISP_FLOAT_TYPE
2009 #endif /* LISP_FLOAT_TYPE */
2010 defsubr (&Snatnump
);
2011 defsubr (&Ssymbolp
);
2012 defsubr (&Sstringp
);
2013 defsubr (&Svectorp
);
2015 defsubr (&Ssequencep
);
2016 defsubr (&Sbufferp
);
2017 defsubr (&Smarkerp
);
2019 defsubr (&Scompiled_function_p
);
2020 defsubr (&Schar_or_string_p
);
2023 defsubr (&Scar_safe
);
2024 defsubr (&Scdr_safe
);
2027 defsubr (&Ssymbol_function
);
2028 defsubr (&Sindirect_function
);
2029 defsubr (&Ssymbol_plist
);
2030 defsubr (&Ssymbol_name
);
2031 defsubr (&Smakunbound
);
2032 defsubr (&Sfmakunbound
);
2034 defsubr (&Sfboundp
);
2036 defsubr (&Ssetplist
);
2037 defsubr (&Ssymbol_value
);
2039 defsubr (&Sdefault_boundp
);
2040 defsubr (&Sdefault_value
);
2041 defsubr (&Sset_default
);
2042 defsubr (&Ssetq_default
);
2043 defsubr (&Smake_variable_buffer_local
);
2044 defsubr (&Smake_local_variable
);
2045 defsubr (&Skill_local_variable
);
2048 defsubr (&Sint_to_string
);
2049 defsubr (&Sstring_to_int
);
2050 defsubr (&Seqlsign
);
2079 /* USG systems forget handlers when they are used;
2080 must reestablish each time */
2081 signal (signo
, arith_error
);
2084 /* VMS systems are like USG. */
2085 signal (signo
, arith_error
);
2089 #else /* not BSD4_1 */
2090 sigsetmask (SIGEMPTYMASK
);
2091 #endif /* not BSD4_1 */
2093 Fsignal (Qarith_error
, Qnil
);
2098 /* Don't do this if just dumping out.
2099 We don't want to call `signal' in this case
2100 so that we don't have trouble with dumping
2101 signal-delivering routines in an inconsistent state. */
2105 #endif /* CANNOT_DUMP */
2106 signal (SIGFPE
, arith_error
);
2109 signal (SIGEMT
, arith_error
);