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
:
607 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
) = newval
;
611 valcontents
= XSYMBOL (sym
)->value
;
612 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
613 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
614 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
616 XSYMBOL (sym
)->value
= newval
;
620 /* Set up the buffer-local symbol SYM for validity in the current
621 buffer. VALCONTENTS is the contents of its value cell.
622 Return the value forwarded one step past the buffer-local indicator. */
625 swap_in_symval_forwarding (sym
, valcontents
)
626 Lisp_Object sym
, valcontents
;
628 /* valcontents is a list
629 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
631 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
632 local_var_alist, that being the element whose car is this variable.
633 Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
634 does not have an element in its alist for this variable.
636 If the current buffer is not BUFFER, we store the current REALVALUE value into
637 CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
638 the buffer now current and set up CURRENT-ALIST-ELEMENT.
639 Then we set REALVALUE out of that element, and store into BUFFER.
640 Note that REALVALUE can be a forwarding pointer. */
642 register Lisp_Object tem1
;
643 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
645 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
647 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
648 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
649 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
651 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
652 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
653 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
654 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
656 return XCONS (valcontents
)->car
;
659 /* Find the value of a symbol, returning Qunbound if it's not bound.
660 This is helpful for code which just wants to get a variable's value
661 if it has one, without signalling an error.
662 Note that it must not be possible to quit
663 within this function. Great care is required for this. */
666 find_symbol_value (sym
)
669 register Lisp_Object valcontents
, tem1
;
670 register Lisp_Object val
;
671 CHECK_SYMBOL (sym
, 0);
672 valcontents
= XSYMBOL (sym
)->value
;
675 #ifdef SWITCH_ENUM_BUG
676 switch ((int) XTYPE (valcontents
))
678 switch (XTYPE (valcontents
))
681 case Lisp_Buffer_Local_Value
:
682 case Lisp_Some_Buffer_Local_Value
:
683 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
687 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
691 if (*XINTPTR (valcontents
))
696 return *XOBJFWD (valcontents
);
698 case Lisp_Buffer_Objfwd
:
699 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
708 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
709 "Return SYMBOL's value. Error if that is void.")
713 Lisp_Object val
= find_symbol_value (sym
);
715 if (EQ (val
, Qunbound
))
716 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
721 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
722 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
724 register Lisp_Object sym
, newval
;
726 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
728 #ifndef RTPC_REGISTER_BUG
729 register Lisp_Object valcontents
, tem1
, current_alist_element
;
730 #else /* RTPC_REGISTER_BUG */
731 register Lisp_Object tem1
;
732 Lisp_Object valcontents
, current_alist_element
;
733 #endif /* RTPC_REGISTER_BUG */
735 CHECK_SYMBOL (sym
, 0);
736 if (NILP (sym
) || EQ (sym
, Qt
))
737 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
738 valcontents
= XSYMBOL (sym
)->value
;
740 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
742 register int idx
= XUINT (valcontents
);
743 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
745 current_buffer
->local_var_flags
|= mask
;
748 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
749 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
751 /* valcontents is actually a pointer to a cons heading something like:
752 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
754 BUFFER is the last buffer for which this symbol's value was
757 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
758 local_var_alist, that being the element whose car is this
759 variable. Or it can be a pointer to the
760 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
761 have an element in its alist for this variable (that is, if
762 BUFFER sees the default value of this variable).
764 If we want to examine or set the value and BUFFER is current,
765 we just examine or set REALVALUE. If BUFFER is not current, we
766 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
767 then find the appropriate alist element for the buffer now
768 current and set up CURRENT-ALIST-ELEMENT. Then we set
769 REALVALUE out of that element, and store into BUFFER.
771 If we are setting the variable and the current buffer does
772 not have an alist entry for this variable, an alist entry is
775 Note that REALVALUE can be a forwarding pointer. Each time
776 it is examined or set, forwarding must be done. */
778 /* What value are we caching right now? */
779 current_alist_element
=
780 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
782 /* If the current buffer is not the buffer whose binding is
783 currently cached, or if it's a Lisp_Buffer_Local_Value and
784 we're looking at the default value, the cache is invalid; we
785 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
787 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
788 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
789 && XCONS (current_alist_element
)->car
== current_alist_element
))
791 /* Write out the cached value for the old buffer; copy it
792 back to its alist element. This works if the current
793 buffer only sees the default value, too. */
794 Fsetcdr (current_alist_element
,
795 do_symval_forwarding (XCONS (valcontents
)->car
));
797 /* Find the new value for CURRENT-ALIST-ELEMENT. */
798 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
801 /* This buffer still sees the default value. */
803 /* If the variable is a Lisp_Some_Buffer_Local_Value,
804 make CURRENT-ALIST-ELEMENT point to itself,
805 indicating that we're seeing the default value. */
806 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
807 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
809 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
810 new assoc for a local value and set
811 CURRENT-ALIST-ELEMENT to point to that. */
814 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
815 current_buffer
->local_var_alist
=
816 Fcons (tem1
, current_buffer
->local_var_alist
);
819 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
820 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
822 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
823 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
824 Lisp_Buffer
, current_buffer
);
826 valcontents
= XCONS (valcontents
)->car
;
829 /* If storing void (making the symbol void), forward only through
830 buffer-local indicator, not through Lisp_Objfwd, etc. */
832 store_symval_forwarding (sym
, Qnil
, newval
);
834 store_symval_forwarding (sym
, valcontents
, newval
);
839 /* Access or set a buffer-local symbol's default value. */
841 /* Return the default value of SYM, but don't check for voidness.
842 Return Qunbound or a Lisp_Void object if it is void. */
848 register Lisp_Object valcontents
;
850 CHECK_SYMBOL (sym
, 0);
851 valcontents
= XSYMBOL (sym
)->value
;
853 /* For a built-in buffer-local variable, get the default value
854 rather than letting do_symval_forwarding get the current value. */
855 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
857 register int idx
= XUINT (valcontents
);
859 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
860 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
863 /* Handle user-created local variables. */
864 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
865 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
867 /* If var is set up for a buffer that lacks a local value for it,
868 the current value is nominally the default value.
869 But the current value slot may be more up to date, since
870 ordinary setq stores just that slot. So use that. */
871 Lisp_Object current_alist_element
, alist_element_car
;
872 current_alist_element
873 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
874 alist_element_car
= XCONS (current_alist_element
)->car
;
875 if (EQ (alist_element_car
, current_alist_element
))
876 return do_symval_forwarding (XCONS (valcontents
)->car
);
878 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
880 /* For other variables, get the current value. */
881 return do_symval_forwarding (valcontents
);
884 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
885 "Return T if SYMBOL has a non-void default value.\n\
886 This is the value that is seen in buffers that do not have their own values\n\
891 register Lisp_Object value
;
893 value
= default_value (sym
);
894 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
898 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
899 "Return SYMBOL's default value.\n\
900 This is the value that is seen in buffers that do not have their own values\n\
901 for this variable. The default value is meaningful for variables with\n\
902 local bindings in certain buffers.")
906 register Lisp_Object value
;
908 value
= default_value (sym
);
909 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
910 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
914 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
915 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
916 The default value is seen in buffers that do not have their own values\n\
919 Lisp_Object sym
, value
;
921 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
923 CHECK_SYMBOL (sym
, 0);
924 valcontents
= XSYMBOL (sym
)->value
;
926 /* Handle variables like case-fold-search that have special slots
927 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
929 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
931 register int idx
= XUINT (valcontents
);
932 #ifndef RTPC_REGISTER_BUG
933 register struct buffer
*b
;
937 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
941 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
942 for (b
= all_buffers
; b
; b
= b
->next
)
943 if (!(b
->local_var_flags
& mask
))
944 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
949 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
950 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
951 return Fset (sym
, value
);
953 /* Store new value into the DEFAULT-VALUE slot */
954 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
956 /* If that slot is current, we must set the REALVALUE slot too */
957 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
958 alist_element_buffer
= Fcar (current_alist_element
);
959 if (EQ (alist_element_buffer
, current_alist_element
))
960 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
965 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
967 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
968 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
969 not have their own values for this variable.")
973 register Lisp_Object args_left
;
974 register Lisp_Object val
, sym
;
985 val
= Feval (Fcar (Fcdr (args_left
)));
986 sym
= Fcar (args_left
);
987 Fset_default (sym
, val
);
988 args_left
= Fcdr (Fcdr (args_left
));
990 while (!NILP (args_left
));
996 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
997 1, 1, "vMake Variable Buffer Local: ",
998 "Make VARIABLE have a separate value for each buffer.\n\
999 At any time, the value for the current buffer is in effect.\n\
1000 There is also a default value which is seen in any buffer which has not yet\n\
1001 set its own value.\n\
1002 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1003 for the current buffer if it was previously using the default value.\n\
1004 The function `default-value' gets the default value and `set-default' sets it.")
1006 register Lisp_Object sym
;
1008 register Lisp_Object tem
, valcontents
;
1010 CHECK_SYMBOL (sym
, 0);
1012 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1013 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1015 valcontents
= XSYMBOL (sym
)->value
;
1016 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1017 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1019 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1021 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1024 if (EQ (valcontents
, Qunbound
))
1025 XSYMBOL (sym
)->value
= Qnil
;
1026 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1027 XCONS (tem
)->car
= tem
;
1028 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1029 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1033 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1034 1, 1, "vMake Local Variable: ",
1035 "Make VARIABLE have a separate value in the current buffer.\n\
1036 Other buffers will continue to share a common default value.\n\
1037 See also `make-variable-buffer-local'.\n\n\
1038 If the variable is already arranged to become local when set,\n\
1039 this function causes a local value to exist for this buffer,\n\
1040 just as if the variable were set.")
1042 register Lisp_Object sym
;
1044 register Lisp_Object tem
, valcontents
;
1046 CHECK_SYMBOL (sym
, 0);
1048 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1049 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1051 valcontents
= XSYMBOL (sym
)->value
;
1052 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1053 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1055 tem
= Fboundp (sym
);
1057 /* Make sure the symbol has a local value in this particular buffer,
1058 by setting it to the same value it already has. */
1059 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1062 /* Make sure sym is set up to hold per-buffer values */
1063 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1065 if (EQ (valcontents
, Qunbound
))
1066 XSYMBOL (sym
)->value
= Qnil
;
1067 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1068 XCONS (tem
)->car
= tem
;
1069 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1070 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1072 /* Make sure this buffer has its own value of sym */
1073 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1076 current_buffer
->local_var_alist
1077 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1078 current_buffer
->local_var_alist
);
1080 /* Make sure symbol does not think it is set up for this buffer;
1081 force it to look once again for this buffer's value */
1083 /* This local variable avoids "expression too complex" on IBM RT. */
1086 xs
= XSYMBOL (sym
)->value
;
1087 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1088 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1095 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1096 1, 1, "vKill Local Variable: ",
1097 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1098 From now on the default value will apply in this buffer.")
1100 register Lisp_Object sym
;
1102 register Lisp_Object tem
, valcontents
;
1104 CHECK_SYMBOL (sym
, 0);
1106 valcontents
= XSYMBOL (sym
)->value
;
1108 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1110 register int idx
= XUINT (valcontents
);
1111 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1115 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1116 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1117 current_buffer
->local_var_flags
&= ~mask
;
1122 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1123 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1126 /* Get rid of this buffer's alist element, if any */
1128 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1130 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1132 /* Make sure symbol does not think it is set up for this buffer;
1133 force it to look once again for this buffer's value */
1136 sv
= XSYMBOL (sym
)->value
;
1137 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1138 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1144 /* Find the function at the end of a chain of symbol function indirections. */
1146 /* If OBJECT is a symbol, find the end of its function chain and
1147 return the value found there. If OBJECT is not a symbol, just
1148 return it. If there is a cycle in the function chain, signal a
1149 cyclic-function-indirection error.
1151 This is like Findirect_function, except that it doesn't signal an
1152 error if the chain ends up unbound. */
1154 indirect_function (object
, error
)
1155 register Lisp_Object object
;
1157 Lisp_Object tortise
, hare
;
1159 hare
= tortise
= object
;
1163 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1165 hare
= XSYMBOL (hare
)->function
;
1166 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1168 hare
= XSYMBOL (hare
)->function
;
1170 tortise
= XSYMBOL (tortise
)->function
;
1172 if (EQ (hare
, tortise
))
1173 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1179 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1180 "Return the function at the end of OBJECT's function chain.\n\
1181 If OBJECT is a symbol, follow all function indirections and return the final\n\
1182 function binding.\n\
1183 If OBJECT is not a symbol, just return it.\n\
1184 Signal a void-function error if the final symbol is unbound.\n\
1185 Signal a cyclic-function-indirection error if there is a loop in the\n\
1186 function chain of symbols.")
1188 register Lisp_Object object
;
1192 result
= indirect_function (object
);
1194 if (EQ (result
, Qunbound
))
1195 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1199 /* Extract and set vector and string elements */
1201 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1202 "Return the element of ARRAY at index INDEX.\n\
1203 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1205 register Lisp_Object array
;
1208 register int idxval
;
1210 CHECK_NUMBER (idx
, 1);
1211 idxval
= XINT (idx
);
1212 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1213 && XTYPE (array
) != Lisp_Compiled
)
1214 array
= wrong_type_argument (Qarrayp
, array
);
1215 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1216 args_out_of_range (array
, idx
);
1217 if (XTYPE (array
) == Lisp_String
)
1220 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1224 return XVECTOR (array
)->contents
[idxval
];
1227 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1228 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1229 ARRAY may be a vector or a string. INDEX starts at 0.")
1230 (array
, idx
, newelt
)
1231 register Lisp_Object array
;
1232 Lisp_Object idx
, newelt
;
1234 register int idxval
;
1236 CHECK_NUMBER (idx
, 1);
1237 idxval
= XINT (idx
);
1238 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1239 array
= wrong_type_argument (Qarrayp
, array
);
1240 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1241 args_out_of_range (array
, idx
);
1242 CHECK_IMPURE (array
);
1244 if (XTYPE (array
) == Lisp_Vector
)
1245 XVECTOR (array
)->contents
[idxval
] = newelt
;
1248 CHECK_NUMBER (newelt
, 2);
1249 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1256 Farray_length (array
)
1257 register Lisp_Object array
;
1259 register Lisp_Object size
;
1260 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1261 && XTYPE (array
) != Lisp_Compiled
)
1262 array
= wrong_type_argument (Qarrayp
, array
);
1263 XFASTINT (size
) = XVECTOR (array
)->size
;
1267 /* Arithmetic functions */
1269 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1272 arithcompare (num1
, num2
, comparison
)
1273 Lisp_Object num1
, num2
;
1274 enum comparison comparison
;
1279 #ifdef LISP_FLOAT_TYPE
1280 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1281 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1283 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1286 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1287 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1290 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1291 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1292 #endif /* LISP_FLOAT_TYPE */
1297 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1302 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1307 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1312 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1317 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1322 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1328 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1329 "T if two args, both numbers or markers, are equal.")
1331 register Lisp_Object num1
, num2
;
1333 return arithcompare (num1
, num2
, equal
);
1336 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1337 "T if first arg is less than second arg. Both must be numbers or markers.")
1339 register Lisp_Object num1
, num2
;
1341 return arithcompare (num1
, num2
, less
);
1344 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1345 "T if first arg is greater than second arg. Both must be numbers or markers.")
1347 register Lisp_Object num1
, num2
;
1349 return arithcompare (num1
, num2
, grtr
);
1352 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1353 "T if first arg is less than or equal to second arg.\n\
1354 Both must be numbers or markers.")
1356 register Lisp_Object num1
, num2
;
1358 return arithcompare (num1
, num2
, less_or_equal
);
1361 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1362 "T if first arg is greater than or equal to second arg.\n\
1363 Both must be numbers or markers.")
1365 register Lisp_Object num1
, num2
;
1367 return arithcompare (num1
, num2
, grtr_or_equal
);
1370 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1371 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1373 register Lisp_Object num1
, num2
;
1375 return arithcompare (num1
, num2
, notequal
);
1378 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1380 register Lisp_Object num
;
1382 #ifdef LISP_FLOAT_TYPE
1383 CHECK_NUMBER_OR_FLOAT (num
, 0);
1385 if (XTYPE(num
) == Lisp_Float
)
1387 if (XFLOAT(num
)->data
== 0.0)
1392 CHECK_NUMBER (num
, 0);
1393 #endif /* LISP_FLOAT_TYPE */
1400 DEFUN ("int-to-string", Fint_to_string
, Sint_to_string
, 1, 1, 0,
1401 "Convert INT to a string by printing it in decimal.\n\
1402 Uses a minus sign if negative.")
1408 #ifndef LISP_FLOAT_TYPE
1409 CHECK_NUMBER (num
, 0);
1411 CHECK_NUMBER_OR_FLOAT (num
, 0);
1413 if (XTYPE(num
) == Lisp_Float
)
1415 char pigbuf
[350]; /* see comments in float_to_string */
1417 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1418 return build_string (pigbuf
);
1420 #endif /* LISP_FLOAT_TYPE */
1422 sprintf (buffer
, "%d", XINT (num
));
1423 return build_string (buffer
);
1426 DEFUN ("string-to-int", Fstring_to_int
, Sstring_to_int
, 1, 1, 0,
1427 "Convert STRING to an integer by parsing it as a decimal number.")
1429 register Lisp_Object str
;
1431 CHECK_STRING (str
, 0);
1433 #ifdef LISP_FLOAT_TYPE
1434 if (isfloat_string (XSTRING (str
)->data
))
1435 return make_float (atof (XSTRING (str
)->data
));
1436 #endif /* LISP_FLOAT_TYPE */
1438 return make_number (atoi (XSTRING (str
)->data
));
1442 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1449 register Lisp_Object
*args
;
1451 register Lisp_Object val
;
1452 register int argnum
;
1456 #ifdef SWITCH_ENUM_BUG
1473 for (argnum
= 0; argnum
< nargs
; argnum
++)
1475 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1476 #ifdef LISP_FLOAT_TYPE
1477 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1479 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1480 return (float_arith_driver ((double) accum
, argnum
, code
,
1483 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1484 #endif /* LISP_FLOAT_TYPE */
1485 args
[argnum
] = val
; /* runs into a compiler bug. */
1486 next
= XINT (args
[argnum
]);
1487 #ifdef SWITCH_ENUM_BUG
1493 case Aadd
: accum
+= next
; break;
1495 if (!argnum
&& nargs
!= 1)
1499 case Amult
: accum
*= next
; break;
1501 if (!argnum
) accum
= next
;
1504 case Alogand
: accum
&= next
; break;
1505 case Alogior
: accum
|= next
; break;
1506 case Alogxor
: accum
^= next
; break;
1507 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1508 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1512 XSET (val
, Lisp_Int
, accum
);
1516 #ifdef LISP_FLOAT_TYPE
1518 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1520 register int argnum
;
1523 register Lisp_Object
*args
;
1525 register Lisp_Object val
;
1528 for (; argnum
< nargs
; argnum
++)
1530 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1531 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1533 if (XTYPE (val
) == Lisp_Float
)
1535 next
= XFLOAT (val
)->data
;
1539 args
[argnum
] = val
; /* runs into a compiler bug. */
1540 next
= XINT (args
[argnum
]);
1542 #ifdef SWITCH_ENUM_BUG
1552 if (!argnum
&& nargs
!= 1)
1568 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1570 if (!argnum
|| next
> accum
)
1574 if (!argnum
|| next
< accum
)
1580 return make_float (accum
);
1582 #endif /* LISP_FLOAT_TYPE */
1584 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1585 "Return sum of any number of arguments, which are numbers or markers.")
1590 return arith_driver (Aadd
, nargs
, args
);
1593 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1594 "Negate number or subtract numbers or markers.\n\
1595 With one arg, negates it. With more than one arg,\n\
1596 subtracts all but the first from the first.")
1601 return arith_driver (Asub
, nargs
, args
);
1604 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1605 "Returns product of any number of arguments, which are numbers or markers.")
1610 return arith_driver (Amult
, nargs
, args
);
1613 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1614 "Returns first argument divided by all the remaining arguments.\n\
1615 The arguments must be numbers or markers.")
1620 return arith_driver (Adiv
, nargs
, args
);
1623 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1624 "Returns remainder of first arg divided by second.\n\
1625 Both must be numbers or markers.")
1627 register Lisp_Object num1
, num2
;
1631 #ifdef LISP_FLOAT_TYPE
1632 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1633 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1635 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1639 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1640 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1644 return (make_float (f1
));
1646 #else /* not LISP_FLOAT_TYPE */
1647 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1648 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1649 #endif /* not LISP_FLOAT_TYPE */
1651 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1655 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1656 "Return largest of all the arguments (which must be numbers or markers).\n\
1657 The value is always a number; markers are converted to numbers.")
1662 return arith_driver (Amax
, nargs
, args
);
1665 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1666 "Return smallest of all the arguments (which must be numbers or markers).\n\
1667 The value is always a number; markers are converted to numbers.")
1672 return arith_driver (Amin
, nargs
, args
);
1675 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1676 "Return bitwise-and of all the arguments.\n\
1677 Arguments may be integers, or markers converted to integers.")
1682 return arith_driver (Alogand
, nargs
, args
);
1685 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1686 "Return bitwise-or of all the arguments.\n\
1687 Arguments may be integers, or markers converted to integers.")
1692 return arith_driver (Alogior
, nargs
, args
);
1695 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1696 "Return bitwise-exclusive-or of all the arguments.\n\
1697 Arguments may be integers, or markers converted to integers.")
1702 return arith_driver (Alogxor
, nargs
, args
);
1705 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1706 "Return VALUE with its bits shifted left by COUNT.\n\
1707 If COUNT is negative, shifting is actually to the right.\n\
1708 In this case, the sign bit is duplicated.")
1710 register Lisp_Object num1
, num2
;
1712 register Lisp_Object val
;
1714 CHECK_NUMBER (num1
, 0);
1715 CHECK_NUMBER (num2
, 1);
1717 if (XINT (num2
) > 0)
1718 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1720 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1724 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1725 "Return VALUE with its bits shifted left by COUNT.\n\
1726 If COUNT is negative, shifting is actually to the right.\n\
1727 In this case, zeros are shifted in on the left.")
1729 register Lisp_Object num1
, num2
;
1731 register Lisp_Object val
;
1733 CHECK_NUMBER (num1
, 0);
1734 CHECK_NUMBER (num2
, 1);
1736 if (XINT (num2
) > 0)
1737 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1739 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1743 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1744 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1745 Markers are converted to integers.")
1747 register Lisp_Object num
;
1749 #ifdef LISP_FLOAT_TYPE
1750 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1752 if (XTYPE (num
) == Lisp_Float
)
1753 return (make_float (1.0 + XFLOAT (num
)->data
));
1755 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1756 #endif /* LISP_FLOAT_TYPE */
1758 XSETINT (num
, XFASTINT (num
) + 1);
1762 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1763 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1764 Markers are converted to integers.")
1766 register Lisp_Object num
;
1768 #ifdef LISP_FLOAT_TYPE
1769 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1771 if (XTYPE (num
) == Lisp_Float
)
1772 return (make_float (-1.0 + XFLOAT (num
)->data
));
1774 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1775 #endif /* LISP_FLOAT_TYPE */
1777 XSETINT (num
, XFASTINT (num
) - 1);
1781 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1782 "Return the bitwise complement of ARG. ARG must be an integer.")
1784 register Lisp_Object num
;
1786 CHECK_NUMBER (num
, 0);
1787 XSETINT (num
, ~XFASTINT (num
));
1794 Qquote
= intern ("quote");
1795 Qlambda
= intern ("lambda");
1796 Qsubr
= intern ("subr");
1797 Qerror_conditions
= intern ("error-conditions");
1798 Qerror_message
= intern ("error-message");
1799 Qtop_level
= intern ("top-level");
1801 Qerror
= intern ("error");
1802 Qquit
= intern ("quit");
1803 Qwrong_type_argument
= intern ("wrong-type-argument");
1804 Qargs_out_of_range
= intern ("args-out-of-range");
1805 Qvoid_function
= intern ("void-function");
1806 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
1807 Qvoid_variable
= intern ("void-variable");
1808 Qsetting_constant
= intern ("setting-constant");
1809 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1811 Qinvalid_function
= intern ("invalid-function");
1812 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1813 Qno_catch
= intern ("no-catch");
1814 Qend_of_file
= intern ("end-of-file");
1815 Qarith_error
= intern ("arith-error");
1816 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1817 Qend_of_buffer
= intern ("end-of-buffer");
1818 Qbuffer_read_only
= intern ("buffer-read-only");
1820 Qlistp
= intern ("listp");
1821 Qconsp
= intern ("consp");
1822 Qsymbolp
= intern ("symbolp");
1823 Qintegerp
= intern ("integerp");
1824 Qnatnump
= intern ("natnump");
1825 Qstringp
= intern ("stringp");
1826 Qarrayp
= intern ("arrayp");
1827 Qsequencep
= intern ("sequencep");
1828 Qbufferp
= intern ("bufferp");
1829 Qvectorp
= intern ("vectorp");
1830 Qchar_or_string_p
= intern ("char-or-string-p");
1831 Qmarkerp
= intern ("markerp");
1832 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1833 Qboundp
= intern ("boundp");
1834 Qfboundp
= intern ("fboundp");
1836 #ifdef LISP_FLOAT_TYPE
1837 Qfloatp
= intern ("floatp");
1838 Qnumberp
= intern ("numberp");
1839 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1840 #endif /* LISP_FLOAT_TYPE */
1842 Qcdr
= intern ("cdr");
1844 /* ERROR is used as a signaler for random errors for which nothing else is right */
1846 Fput (Qerror
, Qerror_conditions
,
1847 Fcons (Qerror
, Qnil
));
1848 Fput (Qerror
, Qerror_message
,
1849 build_string ("error"));
1851 Fput (Qquit
, Qerror_conditions
,
1852 Fcons (Qquit
, Qnil
));
1853 Fput (Qquit
, Qerror_message
,
1854 build_string ("Quit"));
1856 Fput (Qwrong_type_argument
, Qerror_conditions
,
1857 Fcons (Qwrong_type_argument
, Fcons (Qerror
, Qnil
)));
1858 Fput (Qwrong_type_argument
, Qerror_message
,
1859 build_string ("Wrong type argument"));
1861 Fput (Qargs_out_of_range
, Qerror_conditions
,
1862 Fcons (Qargs_out_of_range
, Fcons (Qerror
, Qnil
)));
1863 Fput (Qargs_out_of_range
, Qerror_message
,
1864 build_string ("Args out of range"));
1866 Fput (Qvoid_function
, Qerror_conditions
,
1867 Fcons (Qvoid_function
, Fcons (Qerror
, Qnil
)));
1868 Fput (Qvoid_function
, Qerror_message
,
1869 build_string ("Symbol's function definition is void"));
1871 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
1872 Fcons (Qcyclic_function_indirection
, Fcons (Qerror
, Qnil
)));
1873 Fput (Qcyclic_function_indirection
, Qerror_message
,
1874 build_string ("Symbol's chain of function indirections contains a loop"));
1876 Fput (Qvoid_variable
, Qerror_conditions
,
1877 Fcons (Qvoid_variable
, Fcons (Qerror
, Qnil
)));
1878 Fput (Qvoid_variable
, Qerror_message
,
1879 build_string ("Symbol's value as variable is void"));
1881 Fput (Qsetting_constant
, Qerror_conditions
,
1882 Fcons (Qsetting_constant
, Fcons (Qerror
, Qnil
)));
1883 Fput (Qsetting_constant
, Qerror_message
,
1884 build_string ("Attempt to set a constant symbol"));
1886 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
1887 Fcons (Qinvalid_read_syntax
, Fcons (Qerror
, Qnil
)));
1888 Fput (Qinvalid_read_syntax
, Qerror_message
,
1889 build_string ("Invalid read syntax"));
1891 Fput (Qinvalid_function
, Qerror_conditions
,
1892 Fcons (Qinvalid_function
, Fcons (Qerror
, Qnil
)));
1893 Fput (Qinvalid_function
, Qerror_message
,
1894 build_string ("Invalid function"));
1896 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
1897 Fcons (Qwrong_number_of_arguments
, Fcons (Qerror
, Qnil
)));
1898 Fput (Qwrong_number_of_arguments
, Qerror_message
,
1899 build_string ("Wrong number of arguments"));
1901 Fput (Qno_catch
, Qerror_conditions
,
1902 Fcons (Qno_catch
, Fcons (Qerror
, Qnil
)));
1903 Fput (Qno_catch
, Qerror_message
,
1904 build_string ("No catch for tag"));
1906 Fput (Qend_of_file
, Qerror_conditions
,
1907 Fcons (Qend_of_file
, Fcons (Qerror
, Qnil
)));
1908 Fput (Qend_of_file
, Qerror_message
,
1909 build_string ("End of file during parsing"));
1911 Fput (Qarith_error
, Qerror_conditions
,
1912 Fcons (Qarith_error
, Fcons (Qerror
, Qnil
)));
1913 Fput (Qarith_error
, Qerror_message
,
1914 build_string ("Arithmetic error"));
1916 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
1917 Fcons (Qbeginning_of_buffer
, Fcons (Qerror
, Qnil
)));
1918 Fput (Qbeginning_of_buffer
, Qerror_message
,
1919 build_string ("Beginning of buffer"));
1921 Fput (Qend_of_buffer
, Qerror_conditions
,
1922 Fcons (Qend_of_buffer
, Fcons (Qerror
, Qnil
)));
1923 Fput (Qend_of_buffer
, Qerror_message
,
1924 build_string ("End of buffer"));
1926 Fput (Qbuffer_read_only
, Qerror_conditions
,
1927 Fcons (Qbuffer_read_only
, Fcons (Qerror
, Qnil
)));
1928 Fput (Qbuffer_read_only
, Qerror_message
,
1929 build_string ("Buffer is read-only"));
1933 staticpro (&Qquote
);
1934 staticpro (&Qlambda
);
1936 staticpro (&Qunbound
);
1937 staticpro (&Qerror_conditions
);
1938 staticpro (&Qerror_message
);
1939 staticpro (&Qtop_level
);
1941 staticpro (&Qerror
);
1943 staticpro (&Qwrong_type_argument
);
1944 staticpro (&Qargs_out_of_range
);
1945 staticpro (&Qvoid_function
);
1946 staticpro (&Qcyclic_function_indirection
);
1947 staticpro (&Qvoid_variable
);
1948 staticpro (&Qsetting_constant
);
1949 staticpro (&Qinvalid_read_syntax
);
1950 staticpro (&Qwrong_number_of_arguments
);
1951 staticpro (&Qinvalid_function
);
1952 staticpro (&Qno_catch
);
1953 staticpro (&Qend_of_file
);
1954 staticpro (&Qarith_error
);
1955 staticpro (&Qbeginning_of_buffer
);
1956 staticpro (&Qend_of_buffer
);
1957 staticpro (&Qbuffer_read_only
);
1959 staticpro (&Qlistp
);
1960 staticpro (&Qconsp
);
1961 staticpro (&Qsymbolp
);
1962 staticpro (&Qintegerp
);
1963 staticpro (&Qnatnump
);
1964 staticpro (&Qstringp
);
1965 staticpro (&Qarrayp
);
1966 staticpro (&Qsequencep
);
1967 staticpro (&Qbufferp
);
1968 staticpro (&Qvectorp
);
1969 staticpro (&Qchar_or_string_p
);
1970 staticpro (&Qmarkerp
);
1971 staticpro (&Qinteger_or_marker_p
);
1972 #ifdef LISP_FLOAT_TYPE
1973 staticpro (&Qfloatp
);
1974 staticpro (&Qnumberp
);
1975 staticpro (&Qnumber_or_marker_p
);
1976 #endif /* LISP_FLOAT_TYPE */
1978 staticpro (&Qboundp
);
1979 staticpro (&Qfboundp
);
1988 defsubr (&Sintegerp
);
1989 defsubr (&Sinteger_or_marker_p
);
1990 defsubr (&Snumberp
);
1991 defsubr (&Snumber_or_marker_p
);
1992 #ifdef LISP_FLOAT_TYPE
1994 #endif /* LISP_FLOAT_TYPE */
1995 defsubr (&Snatnump
);
1996 defsubr (&Ssymbolp
);
1997 defsubr (&Sstringp
);
1998 defsubr (&Svectorp
);
2000 defsubr (&Ssequencep
);
2001 defsubr (&Sbufferp
);
2002 defsubr (&Smarkerp
);
2004 defsubr (&Scompiled_function_p
);
2005 defsubr (&Schar_or_string_p
);
2008 defsubr (&Scar_safe
);
2009 defsubr (&Scdr_safe
);
2012 defsubr (&Ssymbol_function
);
2013 defsubr (&Sindirect_function
);
2014 defsubr (&Ssymbol_plist
);
2015 defsubr (&Ssymbol_name
);
2016 defsubr (&Smakunbound
);
2017 defsubr (&Sfmakunbound
);
2019 defsubr (&Sfboundp
);
2021 defsubr (&Ssetplist
);
2022 defsubr (&Ssymbol_value
);
2024 defsubr (&Sdefault_boundp
);
2025 defsubr (&Sdefault_value
);
2026 defsubr (&Sset_default
);
2027 defsubr (&Ssetq_default
);
2028 defsubr (&Smake_variable_buffer_local
);
2029 defsubr (&Smake_local_variable
);
2030 defsubr (&Skill_local_variable
);
2033 defsubr (&Sint_to_string
);
2034 defsubr (&Sstring_to_int
);
2035 defsubr (&Seqlsign
);
2064 /* USG systems forget handlers when they are used;
2065 must reestablish each time */
2066 signal (signo
, arith_error
);
2069 /* VMS systems are like USG. */
2070 signal (signo
, arith_error
);
2074 #else /* not BSD4_1 */
2075 sigsetmask (SIGEMPTYMASK
);
2076 #endif /* not BSD4_1 */
2078 Fsignal (Qarith_error
, Qnil
);
2083 /* Don't do this if just dumping out.
2084 We don't want to call `signal' in this case
2085 so that we don't have trouble with dumping
2086 signal-delivering routines in an inconsistent state. */
2090 #endif /* CANNOT_DUMP */
2091 signal (SIGFPE
, arith_error
);
2094 signal (SIGEMT
, arith_error
);