1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
31 #include "syssignal.h"
33 #ifdef LISP_FLOAT_TYPE
35 #endif /* LISP_FLOAT_TYPE */
37 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
38 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
39 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
40 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
41 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
42 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
43 Lisp_Object Qend_of_file
, Qarith_error
;
44 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
45 Lisp_Object Qintegerp
, Qnatnump
, Qsymbolp
, Qlistp
, Qconsp
;
46 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
47 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
48 Lisp_Object Qbuffer_or_string_p
;
49 Lisp_Object Qboundp
, Qfboundp
;
52 #ifdef LISP_FLOAT_TYPE
54 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
57 static Lisp_Object
swap_in_symval_forwarding ();
60 wrong_type_argument (predicate
, value
)
61 register Lisp_Object predicate
, value
;
63 register Lisp_Object tem
;
66 if (!EQ (Vmocklisp_arguments
, Qt
))
68 if (XTYPE (value
) == Lisp_String
&&
69 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
70 return Fstring_to_int (value
, Qt
);
71 if (XTYPE (value
) == Lisp_Int
&& EQ (predicate
, Qstringp
))
72 return Fint_to_string (value
);
74 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
75 tem
= call1 (predicate
, value
);
83 error ("Attempt to modify read-only object");
87 args_out_of_range (a1
, a2
)
91 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
95 args_out_of_range_3 (a1
, a2
, a3
)
96 Lisp_Object a1
, a2
, a3
;
99 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
106 register Lisp_Object val
;
107 XSET (val
, Lisp_Int
, num
);
111 /* On some machines, XINT needs a temporary location.
112 Here it is, in case it is needed. */
114 int sign_extend_temp
;
116 /* On a few machines, XINT can only be done by calling this. */
119 sign_extend_lisp_int (num
)
122 if (num
& (1 << (VALBITS
- 1)))
123 return num
| ((-1) << VALBITS
);
125 return num
& ((1 << VALBITS
) - 1);
128 /* Data type predicates */
130 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
131 "T if the two args are the same Lisp object.")
133 Lisp_Object obj1
, obj2
;
140 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
149 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
153 if (XTYPE (obj
) == Lisp_Cons
)
158 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
162 if (XTYPE (obj
) == Lisp_Cons
)
167 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
171 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
176 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
180 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
185 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
189 if (XTYPE (obj
) == Lisp_Symbol
)
194 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
198 if (XTYPE (obj
) == Lisp_Vector
)
203 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
207 if (XTYPE (obj
) == Lisp_String
)
212 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
216 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
221 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
222 "T if OBJECT is a sequence (list or array).")
224 register Lisp_Object obj
;
226 if (CONSP (obj
) || NILP (obj
) ||
227 XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
232 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
236 if (XTYPE (obj
) == Lisp_Buffer
)
241 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
245 if (XTYPE (obj
) == Lisp_Marker
)
250 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
254 if (XTYPE (obj
) == Lisp_Subr
)
259 DEFUN ("compiled-function-p", Fcompiled_function_p
, Scompiled_function_p
,
260 1, 1, 0, "T if OBJECT is a compiled function object.")
264 if (XTYPE (obj
) == Lisp_Compiled
)
269 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.")
271 register Lisp_Object obj
;
273 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
278 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is a number.")
282 if (XTYPE (obj
) == Lisp_Int
)
287 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
288 "T if OBJECT is an integer or a marker (editor pointer).")
290 register Lisp_Object obj
;
292 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
297 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0, "T if OBJECT is a nonnegative number.")
301 if (XTYPE (obj
) == Lisp_Int
&& XINT (obj
) >= 0)
306 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
307 "T if OBJECT is a number (floating point or integer).")
312 #ifdef LISP_FLOAT_TYPE
313 || XTYPE (obj
) == Lisp_Float
315 || XTYPE (obj
) == Lisp_Int
)
320 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
321 Snumber_or_marker_p
, 1, 1, 0,
322 "T if OBJECT is a number or a marker.")
326 if (XTYPE (obj
) == Lisp_Int
327 #ifdef LISP_FLOAT_TYPE
328 || XTYPE (obj
) == Lisp_Float
330 || XTYPE (obj
) == Lisp_Marker
)
335 #ifdef LISP_FLOAT_TYPE
336 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
337 "T if OBJECT is a floating point number.")
341 if (XTYPE (obj
) == Lisp_Float
)
345 #endif /* LISP_FLOAT_TYPE */
347 /* Extract and set components of lists */
349 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
350 "Return the car of CONSCELL. If arg is nil, return nil.\n\
351 Error if arg is not nil and not a cons cell. See also `car-safe'.")
353 register Lisp_Object list
;
357 if (XTYPE (list
) == Lisp_Cons
)
358 return XCONS (list
)->car
;
359 else if (EQ (list
, Qnil
))
362 list
= wrong_type_argument (Qlistp
, list
);
366 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
367 "Return the car of OBJECT if it is a cons cell, or else nil.")
371 if (XTYPE (object
) == Lisp_Cons
)
372 return XCONS (object
)->car
;
377 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
378 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
379 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
382 register Lisp_Object list
;
386 if (XTYPE (list
) == Lisp_Cons
)
387 return XCONS (list
)->cdr
;
388 else if (EQ (list
, Qnil
))
391 list
= wrong_type_argument (Qlistp
, list
);
395 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
396 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
400 if (XTYPE (object
) == Lisp_Cons
)
401 return XCONS (object
)->cdr
;
406 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
407 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
409 register Lisp_Object cell
, newcar
;
411 if (XTYPE (cell
) != Lisp_Cons
)
412 cell
= wrong_type_argument (Qconsp
, cell
);
415 XCONS (cell
)->car
= newcar
;
419 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
420 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
422 register Lisp_Object cell
, newcdr
;
424 if (XTYPE (cell
) != Lisp_Cons
)
425 cell
= wrong_type_argument (Qconsp
, cell
);
428 XCONS (cell
)->cdr
= newcdr
;
432 /* Extract and set components of symbols */
434 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
436 register Lisp_Object sym
;
438 Lisp_Object valcontents
;
439 CHECK_SYMBOL (sym
, 0);
441 valcontents
= XSYMBOL (sym
)->value
;
443 #ifdef SWITCH_ENUM_BUG
444 switch ((int) XTYPE (valcontents
))
446 switch (XTYPE (valcontents
))
449 case Lisp_Buffer_Local_Value
:
450 case Lisp_Some_Buffer_Local_Value
:
451 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
454 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
458 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
460 register Lisp_Object sym
;
462 CHECK_SYMBOL (sym
, 0);
463 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
464 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
468 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
470 register Lisp_Object sym
;
472 CHECK_SYMBOL (sym
, 0);
473 if (NILP (sym
) || EQ (sym
, Qt
))
474 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
475 Fset (sym
, Qunbound
);
479 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
481 register Lisp_Object sym
;
483 CHECK_SYMBOL (sym
, 0);
484 XSYMBOL (sym
)->function
= Qunbound
;
488 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
489 "Return SYMBOL's function definition. Error if that is void.")
491 register Lisp_Object symbol
;
493 CHECK_SYMBOL (symbol
, 0);
494 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
495 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
496 return XSYMBOL (symbol
)->function
;
499 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
501 register Lisp_Object sym
;
503 CHECK_SYMBOL (sym
, 0);
504 return XSYMBOL (sym
)->plist
;
507 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
509 register Lisp_Object sym
;
511 register Lisp_Object name
;
513 CHECK_SYMBOL (sym
, 0);
514 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
518 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
519 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
521 register Lisp_Object sym
, newdef
;
523 CHECK_SYMBOL (sym
, 0);
524 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
525 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
527 XSYMBOL (sym
)->function
= newdef
;
531 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
532 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
534 register Lisp_Object sym
, newplist
;
536 CHECK_SYMBOL (sym
, 0);
537 XSYMBOL (sym
)->plist
= newplist
;
542 /* Getting and setting values of symbols */
544 /* Given the raw contents of a symbol value cell,
545 return the Lisp value of the symbol.
546 This does not handle buffer-local variables; use
547 swap_in_symval_forwarding for that. */
550 do_symval_forwarding (valcontents
)
551 register Lisp_Object valcontents
;
553 register Lisp_Object val
;
554 #ifdef SWITCH_ENUM_BUG
555 switch ((int) XTYPE (valcontents
))
557 switch (XTYPE (valcontents
))
561 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
565 if (*XINTPTR (valcontents
))
570 return *XOBJFWD (valcontents
);
572 case Lisp_Buffer_Objfwd
:
573 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
578 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
579 of SYM. If SYM is buffer-local, VALCONTENTS should be the
580 buffer-independent contents of the value cell: forwarded just one
581 step past the buffer-localness. */
584 store_symval_forwarding (sym
, valcontents
, newval
)
586 register Lisp_Object valcontents
, newval
;
588 #ifdef SWITCH_ENUM_BUG
589 switch ((int) XTYPE (valcontents
))
591 switch (XTYPE (valcontents
))
595 CHECK_NUMBER (newval
, 1);
596 *XINTPTR (valcontents
) = XINT (newval
);
600 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
604 *XOBJFWD (valcontents
) = newval
;
607 case Lisp_Buffer_Objfwd
:
609 unsigned int offset
= XUINT (valcontents
);
611 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
613 if (! NILP (type
) && ! NILP (newval
)
614 && XTYPE (newval
) != XINT (type
))
615 buffer_slot_type_mismatch (valcontents
, newval
);
617 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
623 valcontents
= XSYMBOL (sym
)->value
;
624 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
625 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
626 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
628 XSYMBOL (sym
)->value
= newval
;
632 /* Set up the buffer-local symbol SYM for validity in the current
633 buffer. VALCONTENTS is the contents of its value cell.
634 Return the value forwarded one step past the buffer-local indicator. */
637 swap_in_symval_forwarding (sym
, valcontents
)
638 Lisp_Object sym
, valcontents
;
640 /* valcontents is a list
641 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
643 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
644 local_var_alist, that being the element whose car is this
645 variable. Or it can be a pointer to the
646 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
647 an element in its alist for this variable.
649 If the current buffer is not BUFFER, we store the current
650 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
651 appropriate alist element for the buffer now current and set up
652 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
653 element, and store into BUFFER.
655 Note that REALVALUE can be a forwarding pointer. */
657 register Lisp_Object tem1
;
658 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
660 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
662 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
663 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
664 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
666 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
667 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
668 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
669 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
671 return XCONS (valcontents
)->car
;
674 /* Find the value of a symbol, returning Qunbound if it's not bound.
675 This is helpful for code which just wants to get a variable's value
676 if it has one, without signalling an error.
677 Note that it must not be possible to quit
678 within this function. Great care is required for this. */
681 find_symbol_value (sym
)
684 register Lisp_Object valcontents
, tem1
;
685 register Lisp_Object val
;
686 CHECK_SYMBOL (sym
, 0);
687 valcontents
= XSYMBOL (sym
)->value
;
690 #ifdef SWITCH_ENUM_BUG
691 switch ((int) XTYPE (valcontents
))
693 switch (XTYPE (valcontents
))
696 case Lisp_Buffer_Local_Value
:
697 case Lisp_Some_Buffer_Local_Value
:
698 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
702 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
706 if (*XINTPTR (valcontents
))
711 return *XOBJFWD (valcontents
);
713 case Lisp_Buffer_Objfwd
:
714 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
723 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
724 "Return SYMBOL's value. Error if that is void.")
728 Lisp_Object val
= find_symbol_value (sym
);
730 if (EQ (val
, Qunbound
))
731 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
736 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
737 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
739 register Lisp_Object sym
, newval
;
741 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
743 #ifndef RTPC_REGISTER_BUG
744 register Lisp_Object valcontents
, tem1
, current_alist_element
;
745 #else /* RTPC_REGISTER_BUG */
746 register Lisp_Object tem1
;
747 Lisp_Object valcontents
, current_alist_element
;
748 #endif /* RTPC_REGISTER_BUG */
750 CHECK_SYMBOL (sym
, 0);
751 if (NILP (sym
) || EQ (sym
, Qt
))
752 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
753 valcontents
= XSYMBOL (sym
)->value
;
755 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
757 register int idx
= XUINT (valcontents
);
758 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
760 current_buffer
->local_var_flags
|= mask
;
763 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
764 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
766 /* valcontents is actually a pointer to a cons heading something like:
767 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
769 BUFFER is the last buffer for which this symbol's value was
772 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
773 local_var_alist, that being the element whose car is this
774 variable. Or it can be a pointer to the
775 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
776 have an element in its alist for this variable (that is, if
777 BUFFER sees the default value of this variable).
779 If we want to examine or set the value and BUFFER is current,
780 we just examine or set REALVALUE. If BUFFER is not current, we
781 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
782 then find the appropriate alist element for the buffer now
783 current and set up CURRENT-ALIST-ELEMENT. Then we set
784 REALVALUE out of that element, and store into BUFFER.
786 If we are setting the variable and the current buffer does
787 not have an alist entry for this variable, an alist entry is
790 Note that REALVALUE can be a forwarding pointer. Each time
791 it is examined or set, forwarding must be done. */
793 /* What value are we caching right now? */
794 current_alist_element
=
795 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
797 /* If the current buffer is not the buffer whose binding is
798 currently cached, or if it's a Lisp_Buffer_Local_Value and
799 we're looking at the default value, the cache is invalid; we
800 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
802 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
803 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
804 && EQ (XCONS (current_alist_element
)->car
,
805 current_alist_element
)))
807 /* Write out the cached value for the old buffer; copy it
808 back to its alist element. This works if the current
809 buffer only sees the default value, too. */
810 Fsetcdr (current_alist_element
,
811 do_symval_forwarding (XCONS (valcontents
)->car
));
813 /* Find the new value for CURRENT-ALIST-ELEMENT. */
814 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
817 /* This buffer still sees the default value. */
819 /* If the variable is a Lisp_Some_Buffer_Local_Value,
820 make CURRENT-ALIST-ELEMENT point to itself,
821 indicating that we're seeing the default value. */
822 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
823 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
825 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
826 new assoc for a local value and set
827 CURRENT-ALIST-ELEMENT to point to that. */
830 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
831 current_buffer
->local_var_alist
=
832 Fcons (tem1
, current_buffer
->local_var_alist
);
835 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
836 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
838 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
839 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
840 Lisp_Buffer
, current_buffer
);
842 valcontents
= XCONS (valcontents
)->car
;
845 /* If storing void (making the symbol void), forward only through
846 buffer-local indicator, not through Lisp_Objfwd, etc. */
848 store_symval_forwarding (sym
, Qnil
, newval
);
850 store_symval_forwarding (sym
, valcontents
, newval
);
855 /* Access or set a buffer-local symbol's default value. */
857 /* Return the default value of SYM, but don't check for voidness.
858 Return Qunbound or a Lisp_Void object if it is void. */
864 register Lisp_Object valcontents
;
866 CHECK_SYMBOL (sym
, 0);
867 valcontents
= XSYMBOL (sym
)->value
;
869 /* For a built-in buffer-local variable, get the default value
870 rather than letting do_symval_forwarding get the current value. */
871 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
873 register int idx
= XUINT (valcontents
);
875 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
876 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
879 /* Handle user-created local variables. */
880 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
881 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
883 /* If var is set up for a buffer that lacks a local value for it,
884 the current value is nominally the default value.
885 But the current value slot may be more up to date, since
886 ordinary setq stores just that slot. So use that. */
887 Lisp_Object current_alist_element
, alist_element_car
;
888 current_alist_element
889 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
890 alist_element_car
= XCONS (current_alist_element
)->car
;
891 if (EQ (alist_element_car
, current_alist_element
))
892 return do_symval_forwarding (XCONS (valcontents
)->car
);
894 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
896 /* For other variables, get the current value. */
897 return do_symval_forwarding (valcontents
);
900 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
901 "Return T if SYMBOL has a non-void default value.\n\
902 This is the value that is seen in buffers that do not have their own values\n\
907 register Lisp_Object value
;
909 value
= default_value (sym
);
910 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
914 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
915 "Return SYMBOL's default value.\n\
916 This is the value that is seen in buffers that do not have their own values\n\
917 for this variable. The default value is meaningful for variables with\n\
918 local bindings in certain buffers.")
922 register Lisp_Object value
;
924 value
= default_value (sym
);
925 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
926 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
930 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
931 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
932 The default value is seen in buffers that do not have their own values\n\
935 Lisp_Object sym
, value
;
937 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
939 CHECK_SYMBOL (sym
, 0);
940 valcontents
= XSYMBOL (sym
)->value
;
942 /* Handle variables like case-fold-search that have special slots
943 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
945 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
947 register int idx
= XUINT (valcontents
);
948 #ifndef RTPC_REGISTER_BUG
949 register struct buffer
*b
;
953 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
957 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
958 for (b
= all_buffers
; b
; b
= b
->next
)
959 if (!(b
->local_var_flags
& mask
))
960 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
965 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
966 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
967 return Fset (sym
, value
);
969 /* Store new value into the DEFAULT-VALUE slot */
970 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
972 /* If that slot is current, we must set the REALVALUE slot too */
973 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
974 alist_element_buffer
= Fcar (current_alist_element
);
975 if (EQ (alist_element_buffer
, current_alist_element
))
976 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
981 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
983 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
984 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
985 not have their own values for this variable.")
989 register Lisp_Object args_left
;
990 register Lisp_Object val
, sym
;
1001 val
= Feval (Fcar (Fcdr (args_left
)));
1002 sym
= Fcar (args_left
);
1003 Fset_default (sym
, val
);
1004 args_left
= Fcdr (Fcdr (args_left
));
1006 while (!NILP (args_left
));
1012 /* Lisp functions for creating and removing buffer-local variables. */
1014 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1015 1, 1, "vMake Variable Buffer Local: ",
1016 "Make VARIABLE have a separate value for each buffer.\n\
1017 At any time, the value for the current buffer is in effect.\n\
1018 There is also a default value which is seen in any buffer which has not yet\n\
1019 set its own value.\n\
1020 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1021 for the current buffer if it was previously using the default value.\n\
1022 The function `default-value' gets the default value and `set-default' sets it.")
1024 register Lisp_Object sym
;
1026 register Lisp_Object tem
, valcontents
;
1028 CHECK_SYMBOL (sym
, 0);
1030 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1031 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1033 valcontents
= XSYMBOL (sym
)->value
;
1034 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1035 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1037 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1039 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1042 if (EQ (valcontents
, Qunbound
))
1043 XSYMBOL (sym
)->value
= Qnil
;
1044 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1045 XCONS (tem
)->car
= tem
;
1046 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1047 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1051 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1052 1, 1, "vMake Local Variable: ",
1053 "Make VARIABLE have a separate value in the current buffer.\n\
1054 Other buffers will continue to share a common default value.\n\
1055 See also `make-variable-buffer-local'.\n\n\
1056 If the variable is already arranged to become local when set,\n\
1057 this function causes a local value to exist for this buffer,\n\
1058 just as if the variable were set.")
1060 register Lisp_Object sym
;
1062 register Lisp_Object tem
, valcontents
;
1064 CHECK_SYMBOL (sym
, 0);
1066 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1067 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1069 valcontents
= XSYMBOL (sym
)->value
;
1070 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1071 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1073 tem
= Fboundp (sym
);
1075 /* Make sure the symbol has a local value in this particular buffer,
1076 by setting it to the same value it already has. */
1077 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1080 /* Make sure sym is set up to hold per-buffer values */
1081 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1083 if (EQ (valcontents
, Qunbound
))
1084 XSYMBOL (sym
)->value
= Qnil
;
1085 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1086 XCONS (tem
)->car
= tem
;
1087 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1088 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1090 /* Make sure this buffer has its own value of sym */
1091 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1094 current_buffer
->local_var_alist
1095 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1096 current_buffer
->local_var_alist
);
1098 /* Make sure symbol does not think it is set up for this buffer;
1099 force it to look once again for this buffer's value */
1101 /* This local variable avoids "expression too complex" on IBM RT. */
1104 xs
= XSYMBOL (sym
)->value
;
1105 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1106 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1110 /* If the symbol forwards into a C variable, then swap in the
1111 variable for this buffer immediately. If C code modifies the
1112 variable before we swap in, then that new value will clobber the
1113 default value the next time we swap. */
1114 valcontents
= XCONS (XSYMBOL (sym
)->value
)->car
;
1115 if (XTYPE (valcontents
) == Lisp_Intfwd
1116 || XTYPE (valcontents
) == Lisp_Boolfwd
1117 || XTYPE (valcontents
) == Lisp_Objfwd
)
1118 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1123 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1124 1, 1, "vKill Local Variable: ",
1125 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1126 From now on the default value will apply in this buffer.")
1128 register Lisp_Object sym
;
1130 register Lisp_Object tem
, valcontents
;
1132 CHECK_SYMBOL (sym
, 0);
1134 valcontents
= XSYMBOL (sym
)->value
;
1136 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1138 register int idx
= XUINT (valcontents
);
1139 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1143 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1144 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1145 current_buffer
->local_var_flags
&= ~mask
;
1150 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1151 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1154 /* Get rid of this buffer's alist element, if any */
1156 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1158 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1160 /* Make sure symbol does not think it is set up for this buffer;
1161 force it to look once again for this buffer's value */
1164 sv
= XSYMBOL (sym
)->value
;
1165 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1166 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1172 /* Find the function at the end of a chain of symbol function indirections. */
1174 /* If OBJECT is a symbol, find the end of its function chain and
1175 return the value found there. If OBJECT is not a symbol, just
1176 return it. If there is a cycle in the function chain, signal a
1177 cyclic-function-indirection error.
1179 This is like Findirect_function, except that it doesn't signal an
1180 error if the chain ends up unbound. */
1182 indirect_function (object
)
1183 register Lisp_Object object
;
1185 Lisp_Object tortise
, hare
;
1187 hare
= tortise
= object
;
1191 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1193 hare
= XSYMBOL (hare
)->function
;
1194 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1196 hare
= XSYMBOL (hare
)->function
;
1198 tortise
= XSYMBOL (tortise
)->function
;
1200 if (EQ (hare
, tortise
))
1201 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1207 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1208 "Return the function at the end of OBJECT's function chain.\n\
1209 If OBJECT is a symbol, follow all function indirections and return the final\n\
1210 function binding.\n\
1211 If OBJECT is not a symbol, just return it.\n\
1212 Signal a void-function error if the final symbol is unbound.\n\
1213 Signal a cyclic-function-indirection error if there is a loop in the\n\
1214 function chain of symbols.")
1216 register Lisp_Object object
;
1220 result
= indirect_function (object
);
1222 if (EQ (result
, Qunbound
))
1223 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1227 /* Extract and set vector and string elements */
1229 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1230 "Return the element of ARRAY at index INDEX.\n\
1231 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1233 register Lisp_Object array
;
1236 register int idxval
;
1238 CHECK_NUMBER (idx
, 1);
1239 idxval
= XINT (idx
);
1240 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1241 && XTYPE (array
) != Lisp_Compiled
)
1242 array
= wrong_type_argument (Qarrayp
, array
);
1243 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1244 args_out_of_range (array
, idx
);
1245 if (XTYPE (array
) == Lisp_String
)
1248 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1252 return XVECTOR (array
)->contents
[idxval
];
1255 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1256 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1257 ARRAY may be a vector or a string. INDEX starts at 0.")
1258 (array
, idx
, newelt
)
1259 register Lisp_Object array
;
1260 Lisp_Object idx
, newelt
;
1262 register int idxval
;
1264 CHECK_NUMBER (idx
, 1);
1265 idxval
= XINT (idx
);
1266 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1267 array
= wrong_type_argument (Qarrayp
, array
);
1268 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1269 args_out_of_range (array
, idx
);
1270 CHECK_IMPURE (array
);
1272 if (XTYPE (array
) == Lisp_Vector
)
1273 XVECTOR (array
)->contents
[idxval
] = newelt
;
1276 CHECK_NUMBER (newelt
, 2);
1277 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1284 Farray_length (array
)
1285 register Lisp_Object array
;
1287 register Lisp_Object size
;
1288 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1289 && XTYPE (array
) != Lisp_Compiled
)
1290 array
= wrong_type_argument (Qarrayp
, array
);
1291 XFASTINT (size
) = XVECTOR (array
)->size
;
1295 /* Arithmetic functions */
1297 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1300 arithcompare (num1
, num2
, comparison
)
1301 Lisp_Object num1
, num2
;
1302 enum comparison comparison
;
1307 #ifdef LISP_FLOAT_TYPE
1308 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1309 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1311 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1314 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1315 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1318 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1319 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1320 #endif /* LISP_FLOAT_TYPE */
1325 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1330 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1335 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1340 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1345 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1350 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1356 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1357 "T if two args, both numbers or markers, are equal.")
1359 register Lisp_Object num1
, num2
;
1361 return arithcompare (num1
, num2
, equal
);
1364 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1365 "T if first arg is less than second arg. Both must be numbers or markers.")
1367 register Lisp_Object num1
, num2
;
1369 return arithcompare (num1
, num2
, less
);
1372 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1373 "T if first arg is greater than second arg. Both must be numbers or markers.")
1375 register Lisp_Object num1
, num2
;
1377 return arithcompare (num1
, num2
, grtr
);
1380 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1381 "T if first arg is less than or equal to second arg.\n\
1382 Both must be numbers or markers.")
1384 register Lisp_Object num1
, num2
;
1386 return arithcompare (num1
, num2
, less_or_equal
);
1389 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1390 "T if first arg is greater than or equal to second arg.\n\
1391 Both must be numbers or markers.")
1393 register Lisp_Object num1
, num2
;
1395 return arithcompare (num1
, num2
, grtr_or_equal
);
1398 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1399 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1401 register Lisp_Object num1
, num2
;
1403 return arithcompare (num1
, num2
, notequal
);
1406 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1408 register Lisp_Object num
;
1410 #ifdef LISP_FLOAT_TYPE
1411 CHECK_NUMBER_OR_FLOAT (num
, 0);
1413 if (XTYPE(num
) == Lisp_Float
)
1415 if (XFLOAT(num
)->data
== 0.0)
1420 CHECK_NUMBER (num
, 0);
1421 #endif /* LISP_FLOAT_TYPE */
1428 DEFUN ("int-to-string", Fint_to_string
, Sint_to_string
, 1, 1, 0,
1429 "Convert INT to a string by printing it in decimal.\n\
1430 Uses a minus sign if negative.")
1436 #ifndef LISP_FLOAT_TYPE
1437 CHECK_NUMBER (num
, 0);
1439 CHECK_NUMBER_OR_FLOAT (num
, 0);
1441 if (XTYPE(num
) == Lisp_Float
)
1443 char pigbuf
[350]; /* see comments in float_to_string */
1445 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1446 return build_string (pigbuf
);
1448 #endif /* LISP_FLOAT_TYPE */
1450 sprintf (buffer
, "%d", XINT (num
));
1451 return build_string (buffer
);
1454 DEFUN ("string-to-int", Fstring_to_int
, Sstring_to_int
, 1, 1, 0,
1455 "Convert STRING to an integer by parsing it as a decimal number.")
1457 register Lisp_Object str
;
1459 CHECK_STRING (str
, 0);
1461 #ifdef LISP_FLOAT_TYPE
1462 if (isfloat_string (XSTRING (str
)->data
))
1463 return make_float (atof (XSTRING (str
)->data
));
1464 #endif /* LISP_FLOAT_TYPE */
1466 return make_number (atoi (XSTRING (str
)->data
));
1470 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1472 extern Lisp_Object
float_arith_driver ();
1479 register Lisp_Object
*args
;
1481 register Lisp_Object val
;
1482 register int argnum
;
1486 #ifdef SWITCH_ENUM_BUG
1503 for (argnum
= 0; argnum
< nargs
; argnum
++)
1505 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1506 #ifdef LISP_FLOAT_TYPE
1507 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1509 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1510 return (float_arith_driver ((double) accum
, argnum
, code
,
1513 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1514 #endif /* LISP_FLOAT_TYPE */
1515 args
[argnum
] = val
; /* runs into a compiler bug. */
1516 next
= XINT (args
[argnum
]);
1517 #ifdef SWITCH_ENUM_BUG
1523 case Aadd
: accum
+= next
; break;
1525 if (!argnum
&& nargs
!= 1)
1529 case Amult
: accum
*= next
; break;
1531 if (!argnum
) accum
= next
;
1534 case Alogand
: accum
&= next
; break;
1535 case Alogior
: accum
|= next
; break;
1536 case Alogxor
: accum
^= next
; break;
1537 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1538 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1542 XSET (val
, Lisp_Int
, accum
);
1546 #ifdef LISP_FLOAT_TYPE
1548 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1550 register int argnum
;
1553 register Lisp_Object
*args
;
1555 register Lisp_Object val
;
1558 for (; argnum
< nargs
; argnum
++)
1560 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1561 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1563 if (XTYPE (val
) == Lisp_Float
)
1565 next
= XFLOAT (val
)->data
;
1569 args
[argnum
] = val
; /* runs into a compiler bug. */
1570 next
= XINT (args
[argnum
]);
1572 #ifdef SWITCH_ENUM_BUG
1582 if (!argnum
&& nargs
!= 1)
1598 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1600 if (!argnum
|| next
> accum
)
1604 if (!argnum
|| next
< accum
)
1610 return make_float (accum
);
1612 #endif /* LISP_FLOAT_TYPE */
1614 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1615 "Return sum of any number of arguments, which are numbers or markers.")
1620 return arith_driver (Aadd
, nargs
, args
);
1623 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1624 "Negate number or subtract numbers or markers.\n\
1625 With one arg, negates it. With more than one arg,\n\
1626 subtracts all but the first from the first.")
1631 return arith_driver (Asub
, nargs
, args
);
1634 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1635 "Returns product of any number of arguments, which are numbers or markers.")
1640 return arith_driver (Amult
, nargs
, args
);
1643 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1644 "Returns first argument divided by all the remaining arguments.\n\
1645 The arguments must be numbers or markers.")
1650 return arith_driver (Adiv
, nargs
, args
);
1653 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1654 "Returns remainder of first arg divided by second.\n\
1655 Both must be numbers or markers.")
1657 register Lisp_Object num1
, num2
;
1661 #ifdef LISP_FLOAT_TYPE
1662 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1663 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1665 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1669 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1670 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1671 #if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux)
1678 return (make_float (f1
));
1680 #else /* not LISP_FLOAT_TYPE */
1681 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1682 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1683 #endif /* not LISP_FLOAT_TYPE */
1685 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1689 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1690 "Return largest of all the arguments (which must be numbers or markers).\n\
1691 The value is always a number; markers are converted to numbers.")
1696 return arith_driver (Amax
, nargs
, args
);
1699 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1700 "Return smallest of all the arguments (which must be numbers or markers).\n\
1701 The value is always a number; markers are converted to numbers.")
1706 return arith_driver (Amin
, nargs
, args
);
1709 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1710 "Return bitwise-and of all the arguments.\n\
1711 Arguments may be integers, or markers converted to integers.")
1716 return arith_driver (Alogand
, nargs
, args
);
1719 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1720 "Return bitwise-or of all the arguments.\n\
1721 Arguments may be integers, or markers converted to integers.")
1726 return arith_driver (Alogior
, nargs
, args
);
1729 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1730 "Return bitwise-exclusive-or of all the arguments.\n\
1731 Arguments may be integers, or markers converted to integers.")
1736 return arith_driver (Alogxor
, nargs
, args
);
1739 DEFUN ("ash", Fash
, Sash
, 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, the sign bit is duplicated.")
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
, XINT (num1
) << XFASTINT (num2
));
1754 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1758 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1759 "Return VALUE with its bits shifted left by COUNT.\n\
1760 If COUNT is negative, shifting is actually to the right.\n\
1761 In this case, zeros are shifted in on the left.")
1763 register Lisp_Object num1
, num2
;
1765 register Lisp_Object val
;
1767 CHECK_NUMBER (num1
, 0);
1768 CHECK_NUMBER (num2
, 1);
1770 if (XINT (num2
) > 0)
1771 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1773 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1777 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1778 "Return NUMBER plus 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 ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1797 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1798 Markers are converted to integers.")
1800 register Lisp_Object num
;
1802 #ifdef LISP_FLOAT_TYPE
1803 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1805 if (XTYPE (num
) == Lisp_Float
)
1806 return (make_float (-1.0 + XFLOAT (num
)->data
));
1808 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1809 #endif /* LISP_FLOAT_TYPE */
1811 XSETINT (num
, XFASTINT (num
) - 1);
1815 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1816 "Return the bitwise complement of ARG. ARG must be an integer.")
1818 register Lisp_Object num
;
1820 CHECK_NUMBER (num
, 0);
1821 XSETINT (num
, ~XFASTINT (num
));
1828 Qquote
= intern ("quote");
1829 Qlambda
= intern ("lambda");
1830 Qsubr
= intern ("subr");
1831 Qerror_conditions
= intern ("error-conditions");
1832 Qerror_message
= intern ("error-message");
1833 Qtop_level
= intern ("top-level");
1835 Qerror
= intern ("error");
1836 Qquit
= intern ("quit");
1837 Qwrong_type_argument
= intern ("wrong-type-argument");
1838 Qargs_out_of_range
= intern ("args-out-of-range");
1839 Qvoid_function
= intern ("void-function");
1840 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
1841 Qvoid_variable
= intern ("void-variable");
1842 Qsetting_constant
= intern ("setting-constant");
1843 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1845 Qinvalid_function
= intern ("invalid-function");
1846 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1847 Qno_catch
= intern ("no-catch");
1848 Qend_of_file
= intern ("end-of-file");
1849 Qarith_error
= intern ("arith-error");
1850 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1851 Qend_of_buffer
= intern ("end-of-buffer");
1852 Qbuffer_read_only
= intern ("buffer-read-only");
1854 Qlistp
= intern ("listp");
1855 Qconsp
= intern ("consp");
1856 Qsymbolp
= intern ("symbolp");
1857 Qintegerp
= intern ("integerp");
1858 Qnatnump
= intern ("natnump");
1859 Qstringp
= intern ("stringp");
1860 Qarrayp
= intern ("arrayp");
1861 Qsequencep
= intern ("sequencep");
1862 Qbufferp
= intern ("bufferp");
1863 Qvectorp
= intern ("vectorp");
1864 Qchar_or_string_p
= intern ("char-or-string-p");
1865 Qmarkerp
= intern ("markerp");
1866 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
1867 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1868 Qboundp
= intern ("boundp");
1869 Qfboundp
= intern ("fboundp");
1871 #ifdef LISP_FLOAT_TYPE
1872 Qfloatp
= intern ("floatp");
1873 Qnumberp
= intern ("numberp");
1874 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1875 #endif /* LISP_FLOAT_TYPE */
1877 Qcdr
= intern ("cdr");
1879 /* ERROR is used as a signaler for random errors for which nothing else is right */
1881 Fput (Qerror
, Qerror_conditions
,
1882 Fcons (Qerror
, Qnil
));
1883 Fput (Qerror
, Qerror_message
,
1884 build_string ("error"));
1886 Fput (Qquit
, Qerror_conditions
,
1887 Fcons (Qquit
, Qnil
));
1888 Fput (Qquit
, Qerror_message
,
1889 build_string ("Quit"));
1891 Fput (Qwrong_type_argument
, Qerror_conditions
,
1892 Fcons (Qwrong_type_argument
, Fcons (Qerror
, Qnil
)));
1893 Fput (Qwrong_type_argument
, Qerror_message
,
1894 build_string ("Wrong type argument"));
1896 Fput (Qargs_out_of_range
, Qerror_conditions
,
1897 Fcons (Qargs_out_of_range
, Fcons (Qerror
, Qnil
)));
1898 Fput (Qargs_out_of_range
, Qerror_message
,
1899 build_string ("Args out of range"));
1901 Fput (Qvoid_function
, Qerror_conditions
,
1902 Fcons (Qvoid_function
, Fcons (Qerror
, Qnil
)));
1903 Fput (Qvoid_function
, Qerror_message
,
1904 build_string ("Symbol's function definition is void"));
1906 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
1907 Fcons (Qcyclic_function_indirection
, Fcons (Qerror
, Qnil
)));
1908 Fput (Qcyclic_function_indirection
, Qerror_message
,
1909 build_string ("Symbol's chain of function indirections contains a loop"));
1911 Fput (Qvoid_variable
, Qerror_conditions
,
1912 Fcons (Qvoid_variable
, Fcons (Qerror
, Qnil
)));
1913 Fput (Qvoid_variable
, Qerror_message
,
1914 build_string ("Symbol's value as variable is void"));
1916 Fput (Qsetting_constant
, Qerror_conditions
,
1917 Fcons (Qsetting_constant
, Fcons (Qerror
, Qnil
)));
1918 Fput (Qsetting_constant
, Qerror_message
,
1919 build_string ("Attempt to set a constant symbol"));
1921 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
1922 Fcons (Qinvalid_read_syntax
, Fcons (Qerror
, Qnil
)));
1923 Fput (Qinvalid_read_syntax
, Qerror_message
,
1924 build_string ("Invalid read syntax"));
1926 Fput (Qinvalid_function
, Qerror_conditions
,
1927 Fcons (Qinvalid_function
, Fcons (Qerror
, Qnil
)));
1928 Fput (Qinvalid_function
, Qerror_message
,
1929 build_string ("Invalid function"));
1931 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
1932 Fcons (Qwrong_number_of_arguments
, Fcons (Qerror
, Qnil
)));
1933 Fput (Qwrong_number_of_arguments
, Qerror_message
,
1934 build_string ("Wrong number of arguments"));
1936 Fput (Qno_catch
, Qerror_conditions
,
1937 Fcons (Qno_catch
, Fcons (Qerror
, Qnil
)));
1938 Fput (Qno_catch
, Qerror_message
,
1939 build_string ("No catch for tag"));
1941 Fput (Qend_of_file
, Qerror_conditions
,
1942 Fcons (Qend_of_file
, Fcons (Qerror
, Qnil
)));
1943 Fput (Qend_of_file
, Qerror_message
,
1944 build_string ("End of file during parsing"));
1946 Fput (Qarith_error
, Qerror_conditions
,
1947 Fcons (Qarith_error
, Fcons (Qerror
, Qnil
)));
1948 Fput (Qarith_error
, Qerror_message
,
1949 build_string ("Arithmetic error"));
1951 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
1952 Fcons (Qbeginning_of_buffer
, Fcons (Qerror
, Qnil
)));
1953 Fput (Qbeginning_of_buffer
, Qerror_message
,
1954 build_string ("Beginning of buffer"));
1956 Fput (Qend_of_buffer
, Qerror_conditions
,
1957 Fcons (Qend_of_buffer
, Fcons (Qerror
, Qnil
)));
1958 Fput (Qend_of_buffer
, Qerror_message
,
1959 build_string ("End of buffer"));
1961 Fput (Qbuffer_read_only
, Qerror_conditions
,
1962 Fcons (Qbuffer_read_only
, Fcons (Qerror
, Qnil
)));
1963 Fput (Qbuffer_read_only
, Qerror_message
,
1964 build_string ("Buffer is read-only"));
1968 staticpro (&Qquote
);
1969 staticpro (&Qlambda
);
1971 staticpro (&Qunbound
);
1972 staticpro (&Qerror_conditions
);
1973 staticpro (&Qerror_message
);
1974 staticpro (&Qtop_level
);
1976 staticpro (&Qerror
);
1978 staticpro (&Qwrong_type_argument
);
1979 staticpro (&Qargs_out_of_range
);
1980 staticpro (&Qvoid_function
);
1981 staticpro (&Qcyclic_function_indirection
);
1982 staticpro (&Qvoid_variable
);
1983 staticpro (&Qsetting_constant
);
1984 staticpro (&Qinvalid_read_syntax
);
1985 staticpro (&Qwrong_number_of_arguments
);
1986 staticpro (&Qinvalid_function
);
1987 staticpro (&Qno_catch
);
1988 staticpro (&Qend_of_file
);
1989 staticpro (&Qarith_error
);
1990 staticpro (&Qbeginning_of_buffer
);
1991 staticpro (&Qend_of_buffer
);
1992 staticpro (&Qbuffer_read_only
);
1994 staticpro (&Qlistp
);
1995 staticpro (&Qconsp
);
1996 staticpro (&Qsymbolp
);
1997 staticpro (&Qintegerp
);
1998 staticpro (&Qnatnump
);
1999 staticpro (&Qstringp
);
2000 staticpro (&Qarrayp
);
2001 staticpro (&Qsequencep
);
2002 staticpro (&Qbufferp
);
2003 staticpro (&Qvectorp
);
2004 staticpro (&Qchar_or_string_p
);
2005 staticpro (&Qmarkerp
);
2006 staticpro (&Qbuffer_or_string_p
);
2007 staticpro (&Qinteger_or_marker_p
);
2008 #ifdef LISP_FLOAT_TYPE
2009 staticpro (&Qfloatp
);
2010 staticpro (&Qnumberp
);
2011 staticpro (&Qnumber_or_marker_p
);
2012 #endif /* LISP_FLOAT_TYPE */
2014 staticpro (&Qboundp
);
2015 staticpro (&Qfboundp
);
2024 defsubr (&Sintegerp
);
2025 defsubr (&Sinteger_or_marker_p
);
2026 defsubr (&Snumberp
);
2027 defsubr (&Snumber_or_marker_p
);
2028 #ifdef LISP_FLOAT_TYPE
2030 #endif /* LISP_FLOAT_TYPE */
2031 defsubr (&Snatnump
);
2032 defsubr (&Ssymbolp
);
2033 defsubr (&Sstringp
);
2034 defsubr (&Svectorp
);
2036 defsubr (&Ssequencep
);
2037 defsubr (&Sbufferp
);
2038 defsubr (&Smarkerp
);
2040 defsubr (&Scompiled_function_p
);
2041 defsubr (&Schar_or_string_p
);
2044 defsubr (&Scar_safe
);
2045 defsubr (&Scdr_safe
);
2048 defsubr (&Ssymbol_function
);
2049 defsubr (&Sindirect_function
);
2050 defsubr (&Ssymbol_plist
);
2051 defsubr (&Ssymbol_name
);
2052 defsubr (&Smakunbound
);
2053 defsubr (&Sfmakunbound
);
2055 defsubr (&Sfboundp
);
2057 defsubr (&Ssetplist
);
2058 defsubr (&Ssymbol_value
);
2060 defsubr (&Sdefault_boundp
);
2061 defsubr (&Sdefault_value
);
2062 defsubr (&Sset_default
);
2063 defsubr (&Ssetq_default
);
2064 defsubr (&Smake_variable_buffer_local
);
2065 defsubr (&Smake_local_variable
);
2066 defsubr (&Skill_local_variable
);
2069 defsubr (&Sint_to_string
);
2070 defsubr (&Sstring_to_int
);
2071 defsubr (&Seqlsign
);
2100 /* USG systems forget handlers when they are used;
2101 must reestablish each time */
2102 signal (signo
, arith_error
);
2105 /* VMS systems are like USG. */
2106 signal (signo
, arith_error
);
2110 #else /* not BSD4_1 */
2111 sigsetmask (SIGEMPTYMASK
);
2112 #endif /* not BSD4_1 */
2114 Fsignal (Qarith_error
, Qnil
);
2119 /* Don't do this if just dumping out.
2120 We don't want to call `signal' in this case
2121 so that we don't have trouble with dumping
2122 signal-delivering routines in an inconsistent state. */
2126 #endif /* CANNOT_DUMP */
2127 signal (SIGFPE
, arith_error
);
2130 signal (SIGEMT
, arith_error
);