1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988 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 "emacssignal.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
;
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
52 Lisp_Object Qfloatp
, Qinteger_or_floatp
, Qinteger_or_float_or_marker_p
;
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
|| NULL (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
|| NULL (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
) || NULL (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 ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
250 "T if OBJECT is an integer or a marker (editor pointer).")
252 register Lisp_Object obj
;
254 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
259 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
263 if (XTYPE (obj
) == Lisp_Subr
)
268 DEFUN ("compiled-function-p", Fcompiled_function_p
, Scompiled_function_p
,
269 1, 1, 0, "T if OBJECT is a compiled function object.")
273 if (XTYPE (obj
) == Lisp_Compiled
)
278 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.")
280 register Lisp_Object obj
;
282 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
287 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is a number.")
291 if (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 #ifdef LISP_FLOAT_TYPE
306 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
307 "T if OBJECT is a floating point number.")
311 if (XTYPE (obj
) == Lisp_Float
)
316 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
317 "T if OBJECT is a number (floating point or integer).")
321 if (XTYPE (obj
) == Lisp_Float
|| XTYPE (obj
) == Lisp_Int
)
326 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
327 Snumber_or_marker_p
, 1, 1, 0,
328 "T if OBJECT is a number or a marker.")
332 if (XTYPE (obj
) == Lisp_Float
333 || XTYPE (obj
) == Lisp_Int
334 || XTYPE (obj
) == Lisp_Marker
)
338 #endif /* LISP_FLOAT_TYPE */
340 /* Extract and set components of lists */
342 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
343 "Return the car of CONSCELL. If arg is nil, return nil.\n\
344 Error if arg is not nil and not a cons cell. See also `car-safe'.")
346 register Lisp_Object list
;
350 if (XTYPE (list
) == Lisp_Cons
)
351 return XCONS (list
)->car
;
352 else if (EQ (list
, Qnil
))
355 list
= wrong_type_argument (Qlistp
, list
);
359 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
360 "Return the car of OBJECT if it is a cons cell, or else nil.")
364 if (XTYPE (object
) == Lisp_Cons
)
365 return XCONS (object
)->car
;
370 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
371 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
372 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
375 register Lisp_Object list
;
379 if (XTYPE (list
) == Lisp_Cons
)
380 return XCONS (list
)->cdr
;
381 else if (EQ (list
, Qnil
))
384 list
= wrong_type_argument (Qlistp
, list
);
388 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
389 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
393 if (XTYPE (object
) == Lisp_Cons
)
394 return XCONS (object
)->cdr
;
399 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
400 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
402 register Lisp_Object cell
, newcar
;
404 if (XTYPE (cell
) != Lisp_Cons
)
405 cell
= wrong_type_argument (Qconsp
, cell
);
408 XCONS (cell
)->car
= newcar
;
412 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
413 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
415 register Lisp_Object cell
, newcdr
;
417 if (XTYPE (cell
) != Lisp_Cons
)
418 cell
= wrong_type_argument (Qconsp
, cell
);
421 XCONS (cell
)->cdr
= newcdr
;
425 /* Extract and set components of symbols */
427 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
429 register Lisp_Object sym
;
431 Lisp_Object valcontents
;
432 CHECK_SYMBOL (sym
, 0);
434 valcontents
= XSYMBOL (sym
)->value
;
436 #ifdef SWITCH_ENUM_BUG
437 switch ((int) XTYPE (valcontents
))
439 switch (XTYPE (valcontents
))
442 case Lisp_Buffer_Local_Value
:
443 case Lisp_Some_Buffer_Local_Value
:
444 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
447 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
451 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
453 register Lisp_Object sym
;
455 CHECK_SYMBOL (sym
, 0);
456 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
457 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
461 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
463 register Lisp_Object sym
;
465 CHECK_SYMBOL (sym
, 0);
466 if (NULL (sym
) || EQ (sym
, Qt
))
467 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
468 Fset (sym
, Qunbound
);
472 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
474 register Lisp_Object sym
;
476 CHECK_SYMBOL (sym
, 0);
477 XSYMBOL (sym
)->function
= Qunbound
;
481 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
482 "Return SYMBOL's function definition. Error if that is void.")
484 register Lisp_Object sym
;
486 CHECK_SYMBOL (sym
, 0);
487 if (EQ (XSYMBOL (sym
)->function
, Qunbound
))
488 return Fsignal (Qvoid_function
, Fcons (sym
, Qnil
));
489 return XSYMBOL (sym
)->function
;
492 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
494 register Lisp_Object sym
;
496 CHECK_SYMBOL (sym
, 0);
497 return XSYMBOL (sym
)->plist
;
500 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
502 register Lisp_Object sym
;
504 register Lisp_Object name
;
506 CHECK_SYMBOL (sym
, 0);
507 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
511 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
512 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
514 register Lisp_Object sym
, newdef
;
516 CHECK_SYMBOL (sym
, 0);
517 if (!NULL (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
518 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
520 XSYMBOL (sym
)->function
= newdef
;
524 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
525 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
527 register Lisp_Object sym
, newplist
;
529 CHECK_SYMBOL (sym
, 0);
530 XSYMBOL (sym
)->plist
= newplist
;
534 /* Getting and setting values of symbols */
536 /* Given the raw contents of a symbol value cell,
537 return the Lisp value of the symbol.
538 This does not handle buffer-local variables; use
539 swap_in_symval_forwarding for that. */
542 do_symval_forwarding (valcontents
)
543 register Lisp_Object valcontents
;
545 register Lisp_Object val
;
546 #ifdef SWITCH_ENUM_BUG
547 switch ((int) XTYPE (valcontents
))
549 switch (XTYPE (valcontents
))
553 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
557 if (*XINTPTR (valcontents
))
562 return *XOBJFWD (valcontents
);
564 case Lisp_Buffer_Objfwd
:
565 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
570 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
571 of SYM. If SYM is buffer-local, VALCONTENTS should be the
572 buffer-independent contents of the value cell: forwarded just one
573 step past the buffer-localness. */
576 store_symval_forwarding (sym
, valcontents
, newval
)
578 register Lisp_Object valcontents
, newval
;
580 #ifdef SWITCH_ENUM_BUG
581 switch ((int) XTYPE (valcontents
))
583 switch (XTYPE (valcontents
))
587 CHECK_NUMBER (newval
, 1);
588 *XINTPTR (valcontents
) = XINT (newval
);
592 *XINTPTR (valcontents
) = NULL(newval
) ? 0 : 1;
596 *XOBJFWD (valcontents
) = newval
;
599 case Lisp_Buffer_Objfwd
:
600 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
) = newval
;
604 valcontents
= XSYMBOL (sym
)->value
;
605 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
606 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
607 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
609 XSYMBOL (sym
)->value
= newval
;
613 /* Set up the buffer-local symbol SYM for validity in the current
614 buffer. VALCONTENTS is the contents of its value cell.
615 Return the value forwarded one step past the buffer-local indicator. */
618 swap_in_symval_forwarding (sym
, valcontents
)
619 Lisp_Object sym
, valcontents
;
621 /* valcontents is a list
622 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
624 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
625 local_var_alist, that being the element whose car is this variable.
626 Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
627 does not have an element in its alist for this variable.
629 If the current buffer is not BUFFER, we store the current REALVALUE value into
630 CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
631 the buffer now current and set up CURRENT-ALIST-ELEMENT.
632 Then we set REALVALUE out of that element, and store into BUFFER.
633 Note that REALVALUE can be a forwarding pointer. */
635 register Lisp_Object tem1
;
636 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
638 if (NULL (tem1
) || current_buffer
!= XBUFFER (tem1
))
640 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
641 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
642 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
644 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
645 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
646 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
647 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
649 return XCONS (valcontents
)->car
;
652 /* Note that it must not be possible to quit within this function.
653 Great care is required for this. */
655 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
656 "Return SYMBOL's value. Error if that is void.")
660 register Lisp_Object valcontents
, tem1
;
661 register Lisp_Object val
;
662 CHECK_SYMBOL (sym
, 0);
663 valcontents
= XSYMBOL (sym
)->value
;
666 #ifdef SWITCH_ENUM_BUG
667 switch ((int) XTYPE (valcontents
))
669 switch (XTYPE (valcontents
))
672 case Lisp_Buffer_Local_Value
:
673 case Lisp_Some_Buffer_Local_Value
:
674 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
678 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
682 if (*XINTPTR (valcontents
))
687 return *XOBJFWD (valcontents
);
689 case Lisp_Buffer_Objfwd
:
690 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
693 /* For a symbol, check whether it is 'unbound. */
694 if (!EQ (valcontents
, Qunbound
))
698 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
704 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
705 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
707 register Lisp_Object sym
, newval
;
709 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
711 #ifndef RTPC_REGISTER_BUG
712 register Lisp_Object valcontents
, tem1
, current_alist_element
;
713 #else /* RTPC_REGISTER_BUG */
714 register Lisp_Object tem1
;
715 Lisp_Object valcontents
, current_alist_element
;
716 #endif /* RTPC_REGISTER_BUG */
718 CHECK_SYMBOL (sym
, 0);
719 if (NULL (sym
) || EQ (sym
, Qt
))
720 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
721 valcontents
= XSYMBOL (sym
)->value
;
723 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
725 register int idx
= XUINT (valcontents
);
726 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
728 current_buffer
->local_var_flags
|= mask
;
731 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
732 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
734 /* valcontents is a list
735 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
737 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
738 local_var_alist, that being the element whose car is this variable.
739 Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
740 does not have an element in its alist for this variable.
742 If the current buffer is not BUFFER, we store the current REALVALUE value into
743 CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
744 the buffer now current and set up CURRENT-ALIST-ELEMENT.
745 Then we set REALVALUE out of that element, and store into BUFFER.
746 Note that REALVALUE can be a forwarding pointer. */
748 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
749 if (current_buffer
!= ((XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
750 ? XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
)
751 : XBUFFER (XCONS (current_alist_element
)->car
)))
753 Fsetcdr (current_alist_element
, do_symval_forwarding (XCONS (valcontents
)->car
));
755 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
757 /* This buffer sees the default value still.
758 If type is Lisp_Some_Buffer_Local_Value, set the default value.
759 If type is Lisp_Buffer_Local_Value, give this buffer a local value
761 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
762 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
765 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
766 current_buffer
->local_var_alist
= Fcons (tem1
, current_buffer
->local_var_alist
);
768 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
769 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
771 valcontents
= XCONS (valcontents
)->car
;
773 /* If storing void (making the symbol void), forward only through
774 buffer-local indicator, not through Lisp_Objfwd, etc. */
776 store_symval_forwarding (sym
, Qnil
, newval
);
778 store_symval_forwarding (sym
, valcontents
, newval
);
782 /* Access or set a buffer-local symbol's default value. */
784 /* Return the default value of SYM, but don't check for voidness.
785 Return Qunbound or a Lisp_Void object if it is void. */
791 register Lisp_Object valcontents
;
793 CHECK_SYMBOL (sym
, 0);
794 valcontents
= XSYMBOL (sym
)->value
;
796 /* For a built-in buffer-local variable, get the default value
797 rather than letting do_symval_forwarding get the current value. */
798 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
800 register int idx
= XUINT (valcontents
);
802 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
803 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
806 /* Handle user-created local variables. */
807 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
808 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
810 /* If var is set up for a buffer that lacks a local value for it,
811 the current value is nominally the default value.
812 But the current value slot may be more up to date, since
813 ordinary setq stores just that slot. So use that. */
814 Lisp_Object current_alist_element
, alist_element_car
;
815 current_alist_element
816 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
817 alist_element_car
= XCONS (current_alist_element
)->car
;
818 if (EQ (alist_element_car
, current_alist_element
))
819 return do_symval_forwarding (XCONS (valcontents
)->car
);
821 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
823 /* For other variables, get the current value. */
824 return do_symval_forwarding (valcontents
);
827 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
828 "Return T if SYMBOL has a non-void default value.\n\
829 This is the value that is seen in buffers that do not have their own values\n\
834 register Lisp_Object value
;
836 value
= default_value (sym
);
837 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
841 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
842 "Return SYMBOL's default value.\n\
843 This is the value that is seen in buffers that do not have their own values\n\
844 for this variable. The default value is meaningful for variables with\n\
845 local bindings in certain buffers.")
849 register Lisp_Object value
;
851 value
= default_value (sym
);
852 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
853 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
857 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
858 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
859 The default value is seen in buffers that do not have their own values\n\
862 Lisp_Object sym
, value
;
864 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
866 CHECK_SYMBOL (sym
, 0);
867 valcontents
= XSYMBOL (sym
)->value
;
869 /* Handle variables like case-fold-search that have special slots
870 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
872 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
874 register int idx
= XUINT (valcontents
);
875 #ifndef RTPC_REGISTER_BUG
876 register struct buffer
*b
;
880 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
884 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
885 for (b
= all_buffers
; b
; b
= b
->next
)
886 if (!(b
->local_var_flags
& mask
))
887 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
892 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
893 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
894 return Fset (sym
, value
);
896 /* Store new value into the DEFAULT-VALUE slot */
897 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
899 /* If that slot is current, we must set the REALVALUE slot too */
900 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
901 alist_element_buffer
= Fcar (current_alist_element
);
902 if (EQ (alist_element_buffer
, current_alist_element
))
903 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
908 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
910 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
911 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
912 not have their own values for this variable.")
916 register Lisp_Object args_left
;
917 register Lisp_Object val
, sym
;
928 val
= Feval (Fcar (Fcdr (args_left
)));
929 sym
= Fcar (args_left
);
930 Fset_default (sym
, val
);
931 args_left
= Fcdr (Fcdr (args_left
));
933 while (!NULL (args_left
));
939 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
940 1, 1, "vMake Variable Buffer Local: ",
941 "Make VARIABLE have a separate value for each buffer.\n\
942 At any time, the value for the current buffer is in effect.\n\
943 There is also a default value which is seen in any buffer which has not yet\n\
944 set its own value.\n\
945 Using `set' or `setq' to set the variable causes it to have a separate value\n\
946 for the current buffer if it was previously using the default value.\n\
947 The function `default-value' gets the default value and `set-default' sets it.")
949 register Lisp_Object sym
;
951 register Lisp_Object tem
, valcontents
;
953 CHECK_SYMBOL (sym
, 0);
955 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
956 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
958 valcontents
= XSYMBOL (sym
)->value
;
959 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
960 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
962 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
964 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
967 if (EQ (valcontents
, Qunbound
))
968 XSYMBOL (sym
)->value
= Qnil
;
969 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
970 XCONS (tem
)->car
= tem
;
971 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
972 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
976 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
977 1, 1, "vMake Local Variable: ",
978 "Make VARIABLE have a separate value in the current buffer.\n\
979 Other buffers will continue to share a common default value.\n\
980 See also `make-variable-buffer-local'.\n\n\
981 If the variable is already arranged to become local when set,\n\
982 this function causes a local value to exist for this buffer,\n\
983 just as if the variable were set.")
985 register Lisp_Object sym
;
987 register Lisp_Object tem
, valcontents
;
989 CHECK_SYMBOL (sym
, 0);
991 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
992 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
994 valcontents
= XSYMBOL (sym
)->value
;
995 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
996 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1000 /* Make sure the symbol has a local value in this particular buffer,
1001 by setting it to the same value it already has. */
1002 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1005 /* Make sure sym is set up to hold per-buffer values */
1006 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1008 if (EQ (valcontents
, Qunbound
))
1009 XSYMBOL (sym
)->value
= Qnil
;
1010 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1011 XCONS (tem
)->car
= tem
;
1012 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1013 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1015 /* Make sure this buffer has its own value of sym */
1016 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1019 current_buffer
->local_var_alist
1020 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1021 current_buffer
->local_var_alist
);
1023 /* Make sure symbol does not think it is set up for this buffer;
1024 force it to look once again for this buffer's value */
1026 /* This local variable avoids "expression too complex" on IBM RT. */
1029 xs
= XSYMBOL (sym
)->value
;
1030 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1031 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1038 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1039 1, 1, "vKill Local Variable: ",
1040 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1041 From now on the default value will apply in this buffer.")
1043 register Lisp_Object sym
;
1045 register Lisp_Object tem
, valcontents
;
1047 CHECK_SYMBOL (sym
, 0);
1049 valcontents
= XSYMBOL (sym
)->value
;
1051 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1053 register int idx
= XUINT (valcontents
);
1054 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1058 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1059 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1060 current_buffer
->local_var_flags
&= ~mask
;
1065 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1066 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1069 /* Get rid of this buffer's alist element, if any */
1071 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1073 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1075 /* Make sure symbol does not think it is set up for this buffer;
1076 force it to look once again for this buffer's value */
1079 sv
= XSYMBOL (sym
)->value
;
1080 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1081 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1087 /* Extract and set vector and string elements */
1089 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1090 "Return the element of ARRAY at index INDEX.\n\
1091 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1093 register Lisp_Object array
;
1096 register int idxval
;
1098 CHECK_NUMBER (idx
, 1);
1099 idxval
= XINT (idx
);
1100 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1101 && XTYPE (array
) != Lisp_Compiled
)
1102 array
= wrong_type_argument (Qarrayp
, array
);
1103 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1104 args_out_of_range (array
, idx
);
1105 if (XTYPE (array
) == Lisp_String
)
1108 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1112 return XVECTOR (array
)->contents
[idxval
];
1115 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1116 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1117 ARRAY may be a vector or a string. INDEX starts at 0.")
1118 (array
, idx
, newelt
)
1119 register Lisp_Object array
;
1120 Lisp_Object idx
, newelt
;
1122 register int idxval
;
1124 CHECK_NUMBER (idx
, 1);
1125 idxval
= XINT (idx
);
1126 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1127 array
= wrong_type_argument (Qarrayp
, array
);
1128 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1129 args_out_of_range (array
, idx
);
1130 CHECK_IMPURE (array
);
1132 if (XTYPE (array
) == Lisp_Vector
)
1133 XVECTOR (array
)->contents
[idxval
] = newelt
;
1136 CHECK_NUMBER (newelt
, 2);
1137 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1144 Farray_length (array
)
1145 register Lisp_Object array
;
1147 register Lisp_Object size
;
1148 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1149 && XTYPE (array
) != Lisp_Compiled
)
1150 array
= wrong_type_argument (Qarrayp
, array
);
1151 XFASTINT (size
) = XVECTOR (array
)->size
;
1155 /* Arithmetic functions */
1157 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1160 arithcompare (num1
, num2
, comparison
)
1161 Lisp_Object num1
, num2
;
1162 enum comparison comparison
;
1167 #ifdef LISP_FLOAT_TYPE
1168 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1169 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1171 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1174 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1175 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1178 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1179 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1180 #endif /* LISP_FLOAT_TYPE */
1185 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1190 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1195 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1200 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1205 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1210 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1216 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1217 "T if two args, both numbers or markers, are equal.")
1219 register Lisp_Object num1
, num2
;
1221 return arithcompare (num1
, num2
, equal
);
1224 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1225 "T if first arg is less than second arg. Both must be numbers or markers.")
1227 register Lisp_Object num1
, num2
;
1229 return arithcompare (num1
, num2
, less
);
1232 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1233 "T if first arg is greater than second arg. Both must be numbers or markers.")
1235 register Lisp_Object num1
, num2
;
1237 return arithcompare (num1
, num2
, grtr
);
1240 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1241 "T if first arg is less than or equal to second arg.\n\
1242 Both must be numbers or markers.")
1244 register Lisp_Object num1
, num2
;
1246 return arithcompare (num1
, num2
, less_or_equal
);
1249 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1250 "T if first arg is greater than or equal to second arg.\n\
1251 Both must be numbers or markers.")
1253 register Lisp_Object num1
, num2
;
1255 return arithcompare (num1
, num2
, grtr_or_equal
);
1258 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1259 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1261 register Lisp_Object num1
, num2
;
1263 return arithcompare (num1
, num2
, notequal
);
1266 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1268 register Lisp_Object num
;
1270 #ifdef LISP_FLOAT_TYPE
1271 CHECK_NUMBER_OR_FLOAT (num
, 0);
1273 if (XTYPE(num
) == Lisp_Float
)
1275 if (XFLOAT(num
)->data
== 0.0)
1280 CHECK_NUMBER (num
, 0);
1281 #endif /* LISP_FLOAT_TYPE */
1288 DEFUN ("int-to-string", Fint_to_string
, Sint_to_string
, 1, 1, 0,
1289 "Convert INT to a string by printing it in decimal.\n\
1290 Uses a minus sign if negative.")
1296 #ifndef LISP_FLOAT_TYPE
1297 CHECK_NUMBER (num
, 0);
1299 CHECK_NUMBER_OR_FLOAT (num
, 0);
1301 if (XTYPE(num
) == Lisp_Float
)
1303 char pigbuf
[350]; /* see comments in float_to_string */
1305 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1306 return build_string (pigbuf
);
1308 #endif /* LISP_FLOAT_TYPE */
1310 sprintf (buffer
, "%d", XINT (num
));
1311 return build_string (buffer
);
1314 DEFUN ("string-to-int", Fstring_to_int
, Sstring_to_int
, 1, 1, 0,
1315 "Convert STRING to an integer by parsing it as a decimal number.")
1317 register Lisp_Object str
;
1319 CHECK_STRING (str
, 0);
1321 #ifdef LISP_FLOAT_TYPE
1322 if (isfloat_string (XSTRING (str
)->data
))
1323 return make_float (atof (XSTRING (str
)->data
));
1324 #endif /* LISP_FLOAT_TYPE */
1326 return make_number (atoi (XSTRING (str
)->data
));
1330 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1337 register Lisp_Object
*args
;
1339 register Lisp_Object val
;
1340 register int argnum
;
1344 #ifdef SWITCH_ENUM_BUG
1361 for (argnum
= 0; argnum
< nargs
; argnum
++)
1363 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1364 #ifdef LISP_FLOAT_TYPE
1365 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1367 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1368 return (float_arith_driver ((double) accum
, argnum
, code
,
1371 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1372 #endif /* LISP_FLOAT_TYPE */
1373 args
[argnum
] = val
; /* runs into a compiler bug. */
1374 next
= XINT (args
[argnum
]);
1375 #ifdef SWITCH_ENUM_BUG
1381 case Aadd
: accum
+= next
; break;
1383 if (!argnum
&& nargs
!= 1)
1387 case Amult
: accum
*= next
; break;
1389 if (!argnum
) accum
= next
;
1392 case Alogand
: accum
&= next
; break;
1393 case Alogior
: accum
|= next
; break;
1394 case Alogxor
: accum
^= next
; break;
1395 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1396 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1400 XSET (val
, Lisp_Int
, accum
);
1404 #ifdef LISP_FLOAT_TYPE
1406 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1408 register int argnum
;
1411 register Lisp_Object
*args
;
1413 register Lisp_Object val
;
1416 for (; argnum
< nargs
; argnum
++)
1418 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1419 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1421 if (XTYPE (val
) == Lisp_Float
)
1423 next
= XFLOAT (val
)->data
;
1427 args
[argnum
] = val
; /* runs into a compiler bug. */
1428 next
= XINT (args
[argnum
]);
1430 #ifdef SWITCH_ENUM_BUG
1440 if (!argnum
&& nargs
!= 1)
1456 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1458 if (!argnum
|| next
> accum
)
1462 if (!argnum
|| next
< accum
)
1468 return make_float (accum
);
1470 #endif /* LISP_FLOAT_TYPE */
1472 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1473 "Return sum of any number of arguments, which are numbers or markers.")
1478 return arith_driver (Aadd
, nargs
, args
);
1481 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1482 "Negate number or subtract numbers or markers.\n\
1483 With one arg, negates it. With more than one arg,\n\
1484 subtracts all but the first from the first.")
1489 return arith_driver (Asub
, nargs
, args
);
1492 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1493 "Returns product of any number of arguments, which are numbers or markers.")
1498 return arith_driver (Amult
, nargs
, args
);
1501 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1502 "Returns first argument divided by all the remaining arguments.\n\
1503 The arguments must be numbers or markers.")
1508 return arith_driver (Adiv
, nargs
, args
);
1511 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1512 "Returns remainder of first arg divided by second.\n\
1513 Both must be numbers or markers.")
1515 register Lisp_Object num1
, num2
;
1519 #ifdef LISP_FLOAT_TYPE
1520 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1521 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1523 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1527 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1528 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1529 return (make_float (drem (f1
,f2
)));
1531 #else /* not LISP_FLOAT_TYPE */
1532 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1533 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1534 #endif /* not LISP_FLOAT_TYPE */
1536 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1540 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1541 "Return largest of all the arguments (which must be numbers or markers).\n\
1542 The value is always a number; markers are converted to numbers.")
1547 return arith_driver (Amax
, nargs
, args
);
1550 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1551 "Return smallest of all the arguments (which must be numbers or markers).\n\
1552 The value is always a number; markers are converted to numbers.")
1557 return arith_driver (Amin
, nargs
, args
);
1560 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1561 "Return bitwise-and of all the arguments.\n\
1562 Arguments may be integers, or markers converted to integers.")
1567 return arith_driver (Alogand
, nargs
, args
);
1570 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1571 "Return bitwise-or of all the arguments.\n\
1572 Arguments may be integers, or markers converted to integers.")
1577 return arith_driver (Alogior
, nargs
, args
);
1580 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1581 "Return bitwise-exclusive-or of all the arguments.\n\
1582 Arguments may be integers, or markers converted to integers.")
1587 return arith_driver (Alogxor
, nargs
, args
);
1590 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1591 "Return VALUE with its bits shifted left by COUNT.\n\
1592 If COUNT is negative, shifting is actually to the right.\n\
1593 In this case, the sign bit is duplicated.")
1595 register Lisp_Object num1
, num2
;
1597 register Lisp_Object val
;
1599 CHECK_NUMBER (num1
, 0);
1600 CHECK_NUMBER (num2
, 1);
1602 if (XINT (num2
) > 0)
1603 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1605 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1609 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1610 "Return VALUE with its bits shifted left by COUNT.\n\
1611 If COUNT is negative, shifting is actually to the right.\n\
1612 In this case, zeros are shifted in on the left.")
1614 register Lisp_Object num1
, num2
;
1616 register Lisp_Object val
;
1618 CHECK_NUMBER (num1
, 0);
1619 CHECK_NUMBER (num2
, 1);
1621 if (XINT (num2
) > 0)
1622 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1624 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1628 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1629 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1630 Markers are converted to integers.")
1632 register Lisp_Object num
;
1634 #ifdef LISP_FLOAT_TYPE
1635 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1637 if (XTYPE (num
) == Lisp_Float
)
1638 return (make_float (1.0 + XFLOAT (num
)->data
));
1640 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1641 #endif /* LISP_FLOAT_TYPE */
1643 XSETINT (num
, XFASTINT (num
) + 1);
1647 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1648 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1649 Markers are converted to integers.")
1651 register Lisp_Object num
;
1653 #ifdef LISP_FLOAT_TYPE
1654 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1656 if (XTYPE (num
) == Lisp_Float
)
1657 return (make_float (-1.0 + XFLOAT (num
)->data
));
1659 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1660 #endif /* LISP_FLOAT_TYPE */
1662 XSETINT (num
, XFASTINT (num
) - 1);
1666 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1667 "Return the bitwise complement of ARG. ARG must be an integer.")
1669 register Lisp_Object num
;
1671 CHECK_NUMBER (num
, 0);
1672 XSETINT (num
, ~XFASTINT (num
));
1679 Qquote
= intern ("quote");
1680 Qlambda
= intern ("lambda");
1681 Qsubr
= intern ("subr");
1682 Qerror_conditions
= intern ("error-conditions");
1683 Qerror_message
= intern ("error-message");
1684 Qtop_level
= intern ("top-level");
1686 Qerror
= intern ("error");
1687 Qquit
= intern ("quit");
1688 Qwrong_type_argument
= intern ("wrong-type-argument");
1689 Qargs_out_of_range
= intern ("args-out-of-range");
1690 Qvoid_function
= intern ("void-function");
1691 Qvoid_variable
= intern ("void-variable");
1692 Qsetting_constant
= intern ("setting-constant");
1693 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1695 Qinvalid_function
= intern ("invalid-function");
1696 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1697 Qno_catch
= intern ("no-catch");
1698 Qend_of_file
= intern ("end-of-file");
1699 Qarith_error
= intern ("arith-error");
1700 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1701 Qend_of_buffer
= intern ("end-of-buffer");
1702 Qbuffer_read_only
= intern ("buffer-read-only");
1704 Qlistp
= intern ("listp");
1705 Qconsp
= intern ("consp");
1706 Qsymbolp
= intern ("symbolp");
1707 Qintegerp
= intern ("integerp");
1708 Qnatnump
= intern ("natnump");
1709 Qstringp
= intern ("stringp");
1710 Qarrayp
= intern ("arrayp");
1711 Qsequencep
= intern ("sequencep");
1712 Qbufferp
= intern ("bufferp");
1713 Qvectorp
= intern ("vectorp");
1714 Qchar_or_string_p
= intern ("char-or-string-p");
1715 Qmarkerp
= intern ("markerp");
1716 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1717 Qboundp
= intern ("boundp");
1718 Qfboundp
= intern ("fboundp");
1720 #ifdef LISP_FLOAT_TYPE
1721 Qfloatp
= intern ("floatp");
1722 Qnumberp
= intern ("numberp");
1723 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1724 #endif /* LISP_FLOAT_TYPE */
1726 Qcdr
= intern ("cdr");
1728 /* ERROR is used as a signaler for random errors for which nothing else is right */
1730 Fput (Qerror
, Qerror_conditions
,
1731 Fcons (Qerror
, Qnil
));
1732 Fput (Qerror
, Qerror_message
,
1733 build_string ("error"));
1735 Fput (Qquit
, Qerror_conditions
,
1736 Fcons (Qquit
, Qnil
));
1737 Fput (Qquit
, Qerror_message
,
1738 build_string ("Quit"));
1740 Fput (Qwrong_type_argument
, Qerror_conditions
,
1741 Fcons (Qwrong_type_argument
, Fcons (Qerror
, Qnil
)));
1742 Fput (Qwrong_type_argument
, Qerror_message
,
1743 build_string ("Wrong type argument"));
1745 Fput (Qargs_out_of_range
, Qerror_conditions
,
1746 Fcons (Qargs_out_of_range
, Fcons (Qerror
, Qnil
)));
1747 Fput (Qargs_out_of_range
, Qerror_message
,
1748 build_string ("Args out of range"));
1750 Fput (Qvoid_function
, Qerror_conditions
,
1751 Fcons (Qvoid_function
, Fcons (Qerror
, Qnil
)));
1752 Fput (Qvoid_function
, Qerror_message
,
1753 build_string ("Symbol's function definition is void"));
1755 Fput (Qvoid_variable
, Qerror_conditions
,
1756 Fcons (Qvoid_variable
, Fcons (Qerror
, Qnil
)));
1757 Fput (Qvoid_variable
, Qerror_message
,
1758 build_string ("Symbol's value as variable is void"));
1760 Fput (Qsetting_constant
, Qerror_conditions
,
1761 Fcons (Qsetting_constant
, Fcons (Qerror
, Qnil
)));
1762 Fput (Qsetting_constant
, Qerror_message
,
1763 build_string ("Attempt to set a constant symbol"));
1765 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
1766 Fcons (Qinvalid_read_syntax
, Fcons (Qerror
, Qnil
)));
1767 Fput (Qinvalid_read_syntax
, Qerror_message
,
1768 build_string ("Invalid read syntax"));
1770 Fput (Qinvalid_function
, Qerror_conditions
,
1771 Fcons (Qinvalid_function
, Fcons (Qerror
, Qnil
)));
1772 Fput (Qinvalid_function
, Qerror_message
,
1773 build_string ("Invalid function"));
1775 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
1776 Fcons (Qwrong_number_of_arguments
, Fcons (Qerror
, Qnil
)));
1777 Fput (Qwrong_number_of_arguments
, Qerror_message
,
1778 build_string ("Wrong number of arguments"));
1780 Fput (Qno_catch
, Qerror_conditions
,
1781 Fcons (Qno_catch
, Fcons (Qerror
, Qnil
)));
1782 Fput (Qno_catch
, Qerror_message
,
1783 build_string ("No catch for tag"));
1785 Fput (Qend_of_file
, Qerror_conditions
,
1786 Fcons (Qend_of_file
, Fcons (Qerror
, Qnil
)));
1787 Fput (Qend_of_file
, Qerror_message
,
1788 build_string ("End of file during parsing"));
1790 Fput (Qarith_error
, Qerror_conditions
,
1791 Fcons (Qarith_error
, Fcons (Qerror
, Qnil
)));
1792 Fput (Qarith_error
, Qerror_message
,
1793 build_string ("Arithmetic error"));
1795 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
1796 Fcons (Qbeginning_of_buffer
, Fcons (Qerror
, Qnil
)));
1797 Fput (Qbeginning_of_buffer
, Qerror_message
,
1798 build_string ("Beginning of buffer"));
1800 Fput (Qend_of_buffer
, Qerror_conditions
,
1801 Fcons (Qend_of_buffer
, Fcons (Qerror
, Qnil
)));
1802 Fput (Qend_of_buffer
, Qerror_message
,
1803 build_string ("End of buffer"));
1805 Fput (Qbuffer_read_only
, Qerror_conditions
,
1806 Fcons (Qbuffer_read_only
, Fcons (Qerror
, Qnil
)));
1807 Fput (Qbuffer_read_only
, Qerror_message
,
1808 build_string ("Buffer is read-only"));
1812 staticpro (&Qquote
);
1813 staticpro (&Qlambda
);
1815 staticpro (&Qunbound
);
1816 staticpro (&Qerror_conditions
);
1817 staticpro (&Qerror_message
);
1818 staticpro (&Qtop_level
);
1820 staticpro (&Qerror
);
1822 staticpro (&Qwrong_type_argument
);
1823 staticpro (&Qargs_out_of_range
);
1824 staticpro (&Qvoid_function
);
1825 staticpro (&Qvoid_variable
);
1826 staticpro (&Qsetting_constant
);
1827 staticpro (&Qinvalid_read_syntax
);
1828 staticpro (&Qwrong_number_of_arguments
);
1829 staticpro (&Qinvalid_function
);
1830 staticpro (&Qno_catch
);
1831 staticpro (&Qend_of_file
);
1832 staticpro (&Qarith_error
);
1833 staticpro (&Qbeginning_of_buffer
);
1834 staticpro (&Qend_of_buffer
);
1835 staticpro (&Qbuffer_read_only
);
1837 staticpro (&Qlistp
);
1838 staticpro (&Qconsp
);
1839 staticpro (&Qsymbolp
);
1840 staticpro (&Qintegerp
);
1841 staticpro (&Qnatnump
);
1842 staticpro (&Qstringp
);
1843 staticpro (&Qarrayp
);
1844 staticpro (&Qsequencep
);
1845 staticpro (&Qbufferp
);
1846 staticpro (&Qvectorp
);
1847 staticpro (&Qchar_or_string_p
);
1848 staticpro (&Qmarkerp
);
1849 staticpro (&Qinteger_or_marker_p
);
1850 #ifdef LISP_FLOAT_TYPE
1851 staticpro (&Qfloatp
);
1852 staticpro (&Qinteger_or_floatp
);
1853 staticpro (&Qinteger_or_float_or_marker_p
);
1854 #endif /* LISP_FLOAT_TYPE */
1856 staticpro (&Qboundp
);
1857 staticpro (&Qfboundp
);
1866 defsubr (&Sintegerp
);
1867 #ifdef LISP_FLOAT_TYPE
1869 defsubr (&Snumberp
);
1870 defsubr (&Snumber_or_marker_p
);
1871 #endif /* LISP_FLOAT_TYPE */
1872 defsubr (&Snatnump
);
1873 defsubr (&Ssymbolp
);
1874 defsubr (&Sstringp
);
1875 defsubr (&Svectorp
);
1877 defsubr (&Ssequencep
);
1878 defsubr (&Sbufferp
);
1879 defsubr (&Smarkerp
);
1880 defsubr (&Sinteger_or_marker_p
);
1882 defsubr (&Scompiled_function_p
);
1883 defsubr (&Schar_or_string_p
);
1886 defsubr (&Scar_safe
);
1887 defsubr (&Scdr_safe
);
1890 defsubr (&Ssymbol_function
);
1891 defsubr (&Ssymbol_plist
);
1892 defsubr (&Ssymbol_name
);
1893 defsubr (&Smakunbound
);
1894 defsubr (&Sfmakunbound
);
1896 defsubr (&Sfboundp
);
1898 defsubr (&Ssetplist
);
1899 defsubr (&Ssymbol_value
);
1901 defsubr (&Sdefault_boundp
);
1902 defsubr (&Sdefault_value
);
1903 defsubr (&Sset_default
);
1904 defsubr (&Ssetq_default
);
1905 defsubr (&Smake_variable_buffer_local
);
1906 defsubr (&Smake_local_variable
);
1907 defsubr (&Skill_local_variable
);
1910 defsubr (&Sint_to_string
);
1911 defsubr (&Sstring_to_int
);
1912 defsubr (&Seqlsign
);
1940 /* USG systems forget handlers when they are used;
1941 must reestablish each time */
1942 signal (signo
, arith_error
);
1945 /* VMS systems are like USG. */
1946 signal (signo
, arith_error
);
1950 #else /* not BSD4_1 */
1951 sigsetmask (SIGEMPTYMASK
);
1952 #endif /* not BSD4_1 */
1954 Fsignal (Qarith_error
, Qnil
);
1959 /* Don't do this if just dumping out.
1960 We don't want to call `signal' in this case
1961 so that we don't have trouble with dumping
1962 signal-delivering routines in an inconsistent state. */
1966 #endif /* CANNOT_DUMP */
1967 signal (SIGFPE
, arith_error
);
1969 signal (SIGEMT
, arith_error
);