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 #ifdef LISP_FLOAT_TYPE
33 #endif /* LISP_FLOAT_TYPE */
35 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
36 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
37 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
38 Lisp_Object Qvoid_variable
, Qvoid_function
;
39 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
40 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
41 Lisp_Object Qend_of_file
, Qarith_error
;
42 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
43 Lisp_Object Qintegerp
, Qnatnump
, Qsymbolp
, Qlistp
, Qconsp
;
44 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
45 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
46 Lisp_Object Qboundp
, Qfboundp
;
49 #ifdef LISP_FLOAT_TYPE
50 Lisp_Object Qfloatp
, Qinteger_or_floatp
, Qinteger_or_float_or_marker_p
;
51 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
54 static Lisp_Object
swap_in_symval_forwarding ();
57 wrong_type_argument (predicate
, value
)
58 register Lisp_Object predicate
, value
;
60 register Lisp_Object tem
;
63 if (!EQ (Vmocklisp_arguments
, Qt
))
65 if (XTYPE (value
) == Lisp_String
&&
66 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
67 return Fstring_to_int (value
, Qt
);
68 if (XTYPE (value
) == Lisp_Int
&& EQ (predicate
, Qstringp
))
69 return Fint_to_string (value
);
71 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
72 tem
= call1 (predicate
, value
);
80 error ("Attempt to modify read-only object");
84 args_out_of_range (a1
, a2
)
88 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
92 args_out_of_range_3 (a1
, a2
, a3
)
93 Lisp_Object a1
, a2
, a3
;
96 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
103 register Lisp_Object val
;
104 XSET (val
, Lisp_Int
, num
);
108 /* On some machines, XINT needs a temporary location.
109 Here it is, in case it is needed. */
111 int sign_extend_temp
;
113 /* On a few machines, XINT can only be done by calling this. */
116 sign_extend_lisp_int (num
)
119 if (num
& (1 << (VALBITS
- 1)))
120 return num
| ((-1) << VALBITS
);
122 return num
& ((1 << VALBITS
) - 1);
125 /* Data type predicates */
127 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
128 "T if the two args are the same Lisp object.")
130 Lisp_Object obj1
, obj2
;
137 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
146 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
150 if (XTYPE (obj
) == Lisp_Cons
)
155 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
159 if (XTYPE (obj
) == Lisp_Cons
)
164 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
168 if (XTYPE (obj
) == Lisp_Cons
|| NULL (obj
))
173 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
177 if (XTYPE (obj
) == Lisp_Cons
|| NULL (obj
))
182 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
186 if (XTYPE (obj
) == Lisp_Symbol
)
191 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
195 if (XTYPE (obj
) == Lisp_Vector
)
200 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
204 if (XTYPE (obj
) == Lisp_String
)
209 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
213 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
218 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
219 "T if OBJECT is a sequence (list or array).")
221 register Lisp_Object obj
;
223 if (CONSP (obj
) || NULL (obj
) ||
224 XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
229 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
233 if (XTYPE (obj
) == Lisp_Buffer
)
238 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
242 if (XTYPE (obj
) == Lisp_Marker
)
247 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
248 "T if OBJECT is an integer or a marker (editor pointer).")
250 register Lisp_Object obj
;
252 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
257 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
261 if (XTYPE (obj
) == Lisp_Subr
)
266 DEFUN ("compiled-function-p", Fcompiled_function_p
, Scompiled_function_p
,
267 1, 1, 0, "T if OBJECT is a compiled function object.")
271 if (XTYPE (obj
) == Lisp_Compiled
)
276 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.")
278 register Lisp_Object obj
;
280 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
285 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is a number.")
289 if (XTYPE (obj
) == Lisp_Int
)
294 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0, "T if OBJECT is a nonnegative number.")
298 if (XTYPE (obj
) == Lisp_Int
&& XINT (obj
) >= 0)
303 #ifdef LISP_FLOAT_TYPE
304 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
305 "T if OBJECT is a floating point number.")
309 if (XTYPE (obj
) == Lisp_Float
)
314 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
315 "T if OBJECT is a number (floating point or integer).")
319 if (XTYPE (obj
) == Lisp_Float
|| XTYPE (obj
) == Lisp_Int
)
324 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
325 Snumber_or_marker_p
, 1, 1, 0,
326 "T if OBJECT is a number or a marker.")
330 if (XTYPE (obj
) == Lisp_Float
331 || XTYPE (obj
) == Lisp_Int
332 || XTYPE (obj
) == Lisp_Marker
)
336 #endif /* LISP_FLOAT_TYPE */
338 /* Extract and set components of lists */
340 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
341 "Return the car of CONSCELL. If arg is nil, return nil.\n\
342 Error if arg is not nil and not a cons cell. See also `car-safe'.")
344 register Lisp_Object list
;
348 if (XTYPE (list
) == Lisp_Cons
)
349 return XCONS (list
)->car
;
350 else if (EQ (list
, Qnil
))
353 list
= wrong_type_argument (Qlistp
, list
);
357 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
358 "Return the car of OBJECT if it is a cons cell, or else nil.")
362 if (XTYPE (object
) == Lisp_Cons
)
363 return XCONS (object
)->car
;
368 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
369 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
370 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
373 register Lisp_Object list
;
377 if (XTYPE (list
) == Lisp_Cons
)
378 return XCONS (list
)->cdr
;
379 else if (EQ (list
, Qnil
))
382 list
= wrong_type_argument (Qlistp
, list
);
386 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
387 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
391 if (XTYPE (object
) == Lisp_Cons
)
392 return XCONS (object
)->cdr
;
397 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
398 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
400 register Lisp_Object cell
, newcar
;
402 if (XTYPE (cell
) != Lisp_Cons
)
403 cell
= wrong_type_argument (Qconsp
, cell
);
406 XCONS (cell
)->car
= newcar
;
410 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
411 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
413 register Lisp_Object cell
, newcdr
;
415 if (XTYPE (cell
) != Lisp_Cons
)
416 cell
= wrong_type_argument (Qconsp
, cell
);
419 XCONS (cell
)->cdr
= newcdr
;
423 /* Extract and set components of symbols */
425 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
427 register Lisp_Object sym
;
429 Lisp_Object valcontents
;
430 CHECK_SYMBOL (sym
, 0);
432 valcontents
= XSYMBOL (sym
)->value
;
434 #ifdef SWITCH_ENUM_BUG
435 switch ((int) XTYPE (valcontents
))
437 switch (XTYPE (valcontents
))
440 case Lisp_Buffer_Local_Value
:
441 case Lisp_Some_Buffer_Local_Value
:
442 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
445 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
449 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
451 register Lisp_Object sym
;
453 CHECK_SYMBOL (sym
, 0);
454 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
455 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
459 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
461 register Lisp_Object sym
;
463 CHECK_SYMBOL (sym
, 0);
464 if (NULL (sym
) || EQ (sym
, Qt
))
465 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
466 Fset (sym
, Qunbound
);
470 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
472 register Lisp_Object sym
;
474 CHECK_SYMBOL (sym
, 0);
475 XSYMBOL (sym
)->function
= Qunbound
;
479 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
480 "Return SYMBOL's function definition. Error if that is void.")
482 register Lisp_Object sym
;
484 CHECK_SYMBOL (sym
, 0);
485 if (EQ (XSYMBOL (sym
)->function
, Qunbound
))
486 return Fsignal (Qvoid_function
, Fcons (sym
, Qnil
));
487 return XSYMBOL (sym
)->function
;
490 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
492 register Lisp_Object sym
;
494 CHECK_SYMBOL (sym
, 0);
495 return XSYMBOL (sym
)->plist
;
498 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
500 register Lisp_Object sym
;
502 register Lisp_Object name
;
504 CHECK_SYMBOL (sym
, 0);
505 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
509 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
510 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
512 register Lisp_Object sym
, newdef
;
514 CHECK_SYMBOL (sym
, 0);
515 if (!NULL (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
516 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
518 XSYMBOL (sym
)->function
= newdef
;
522 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
523 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
525 register Lisp_Object sym
, newplist
;
527 CHECK_SYMBOL (sym
, 0);
528 XSYMBOL (sym
)->plist
= newplist
;
532 /* Getting and setting values of symbols */
534 /* Given the raw contents of a symbol value cell,
535 return the Lisp value of the symbol.
536 This does not handle buffer-local variables; use
537 swap_in_symval_forwarding for that. */
540 do_symval_forwarding (valcontents
)
541 register Lisp_Object valcontents
;
543 register Lisp_Object val
;
544 #ifdef SWITCH_ENUM_BUG
545 switch ((int) XTYPE (valcontents
))
547 switch (XTYPE (valcontents
))
551 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
555 if (*XINTPTR (valcontents
))
560 return *XOBJFWD (valcontents
);
562 case Lisp_Buffer_Objfwd
:
563 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
568 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
569 of SYM. If SYM is buffer-local, VALCONTENTS should be the
570 buffer-independent contents of the value cell: forwarded just one
571 step past the buffer-localness. */
574 store_symval_forwarding (sym
, valcontents
, newval
)
576 register Lisp_Object valcontents
, newval
;
578 #ifdef SWITCH_ENUM_BUG
579 switch ((int) XTYPE (valcontents
))
581 switch (XTYPE (valcontents
))
585 CHECK_NUMBER (newval
, 1);
586 *XINTPTR (valcontents
) = XINT (newval
);
590 *XINTPTR (valcontents
) = NULL(newval
) ? 0 : 1;
594 *XOBJFWD (valcontents
) = newval
;
597 case Lisp_Buffer_Objfwd
:
598 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
) = newval
;
602 valcontents
= XSYMBOL (sym
)->value
;
603 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
604 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
605 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
607 XSYMBOL (sym
)->value
= newval
;
611 /* Set up the buffer-local symbol SYM for validity in the current
612 buffer. VALCONTENTS is the contents of its value cell.
613 Return the value forwarded one step past the buffer-local indicator. */
616 swap_in_symval_forwarding (sym
, valcontents
)
617 Lisp_Object sym
, valcontents
;
619 /* valcontents is a list
620 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
622 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
623 local_var_alist, that being the element whose car is this variable.
624 Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
625 does not have an element in its alist for this variable.
627 If the current buffer is not BUFFER, we store the current REALVALUE value into
628 CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
629 the buffer now current and set up CURRENT-ALIST-ELEMENT.
630 Then we set REALVALUE out of that element, and store into BUFFER.
631 Note that REALVALUE can be a forwarding pointer. */
633 register Lisp_Object tem1
;
634 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
636 if (NULL (tem1
) || current_buffer
!= XBUFFER (tem1
))
638 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
639 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
640 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
642 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
643 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
644 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
645 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
647 return XCONS (valcontents
)->car
;
650 /* Note that it must not be possible to quit within this function.
651 Great care is required for this. */
653 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
654 "Return SYMBOL's value. Error if that is void.")
658 register Lisp_Object valcontents
, tem1
;
659 register Lisp_Object val
;
660 CHECK_SYMBOL (sym
, 0);
661 valcontents
= XSYMBOL (sym
)->value
;
664 #ifdef SWITCH_ENUM_BUG
665 switch ((int) XTYPE (valcontents
))
667 switch (XTYPE (valcontents
))
670 case Lisp_Buffer_Local_Value
:
671 case Lisp_Some_Buffer_Local_Value
:
672 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
676 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
680 if (*XINTPTR (valcontents
))
685 return *XOBJFWD (valcontents
);
687 case Lisp_Buffer_Objfwd
:
688 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
691 /* For a symbol, check whether it is 'unbound. */
692 if (!EQ (valcontents
, Qunbound
))
696 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
702 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
703 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
705 register Lisp_Object sym
, newval
;
707 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
709 #ifndef RTPC_REGISTER_BUG
710 register Lisp_Object valcontents
, tem1
, current_alist_element
;
711 #else /* RTPC_REGISTER_BUG */
712 register Lisp_Object tem1
;
713 Lisp_Object valcontents
, current_alist_element
;
714 #endif /* RTPC_REGISTER_BUG */
716 CHECK_SYMBOL (sym
, 0);
717 if (NULL (sym
) || EQ (sym
, Qt
))
718 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
719 valcontents
= XSYMBOL (sym
)->value
;
721 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
723 register int idx
= XUINT (valcontents
);
724 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
726 current_buffer
->local_var_flags
|= mask
;
729 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
730 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
732 /* valcontents is a list
733 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
735 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
736 local_var_alist, that being the element whose car is this variable.
737 Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
738 does not have an element in its alist for this variable.
740 If the current buffer is not BUFFER, we store the current REALVALUE value into
741 CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
742 the buffer now current and set up CURRENT-ALIST-ELEMENT.
743 Then we set REALVALUE out of that element, and store into BUFFER.
744 Note that REALVALUE can be a forwarding pointer. */
746 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
747 if (current_buffer
!= ((XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
748 ? XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
)
749 : XBUFFER (XCONS (current_alist_element
)->car
)))
751 Fsetcdr (current_alist_element
, do_symval_forwarding (XCONS (valcontents
)->car
));
753 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
755 /* This buffer sees the default value still.
756 If type is Lisp_Some_Buffer_Local_Value, set the default value.
757 If type is Lisp_Buffer_Local_Value, give this buffer a local value
759 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
760 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
763 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
764 current_buffer
->local_var_alist
= Fcons (tem1
, current_buffer
->local_var_alist
);
766 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
767 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
769 valcontents
= XCONS (valcontents
)->car
;
771 /* If storing void (making the symbol void), forward only through
772 buffer-local indicator, not through Lisp_Objfwd, etc. */
774 store_symval_forwarding (sym
, Qnil
, newval
);
776 store_symval_forwarding (sym
, valcontents
, newval
);
780 /* Access or set a buffer-local symbol's default value. */
782 /* Return the default value of SYM, but don't check for voidness.
783 Return Qunbound or a Lisp_Void object if it is void. */
789 register Lisp_Object valcontents
;
791 CHECK_SYMBOL (sym
, 0);
792 valcontents
= XSYMBOL (sym
)->value
;
794 /* For a built-in buffer-local variable, get the default value
795 rather than letting do_symval_forwarding get the current value. */
796 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
798 register int idx
= XUINT (valcontents
);
800 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
801 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
804 /* Handle user-created local variables. */
805 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
806 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
808 /* If var is set up for a buffer that lacks a local value for it,
809 the current value is nominally the default value.
810 But the current value slot may be more up to date, since
811 ordinary setq stores just that slot. So use that. */
812 Lisp_Object current_alist_element
, alist_element_car
;
813 current_alist_element
814 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
815 alist_element_car
= XCONS (current_alist_element
)->car
;
816 if (EQ (alist_element_car
, current_alist_element
))
817 return do_symval_forwarding (XCONS (valcontents
)->car
);
819 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
821 /* For other variables, get the current value. */
822 return do_symval_forwarding (valcontents
);
825 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
826 "Return T if SYMBOL has a non-void default value.\n\
827 This is the value that is seen in buffers that do not have their own values\n\
832 register Lisp_Object value
;
834 value
= default_value (sym
);
835 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
839 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
840 "Return SYMBOL's default value.\n\
841 This is the value that is seen in buffers that do not have their own values\n\
842 for this variable. The default value is meaningful for variables with\n\
843 local bindings in certain buffers.")
847 register Lisp_Object value
;
849 value
= default_value (sym
);
850 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
851 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
855 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
856 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
857 The default value is seen in buffers that do not have their own values\n\
860 Lisp_Object sym
, value
;
862 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
864 CHECK_SYMBOL (sym
, 0);
865 valcontents
= XSYMBOL (sym
)->value
;
867 /* Handle variables like case-fold-search that have special slots
868 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
870 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
872 register int idx
= XUINT (valcontents
);
873 #ifndef RTPC_REGISTER_BUG
874 register struct buffer
*b
;
878 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
882 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
883 for (b
= all_buffers
; b
; b
= b
->next
)
884 if (!(b
->local_var_flags
& mask
))
885 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
890 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
891 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
892 return Fset (sym
, value
);
894 /* Store new value into the DEFAULT-VALUE slot */
895 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
897 /* If that slot is current, we must set the REALVALUE slot too */
898 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
899 alist_element_buffer
= Fcar (current_alist_element
);
900 if (EQ (alist_element_buffer
, current_alist_element
))
901 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
906 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
908 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
909 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
910 not have their own values for this variable.")
914 register Lisp_Object args_left
;
915 register Lisp_Object val
, sym
;
926 val
= Feval (Fcar (Fcdr (args_left
)));
927 sym
= Fcar (args_left
);
928 Fset_default (sym
, val
);
929 args_left
= Fcdr (Fcdr (args_left
));
931 while (!NULL (args_left
));
937 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
938 1, 1, "vMake Variable Buffer Local: ",
939 "Make VARIABLE have a separate value for each buffer.\n\
940 At any time, the value for the current buffer is in effect.\n\
941 There is also a default value which is seen in any buffer which has not yet\n\
942 set its own value.\n\
943 Using `set' or `setq' to set the variable causes it to have a separate value\n\
944 for the current buffer if it was previously using the default value.\n\
945 The function `default-value' gets the default value and `set-default' sets it.")
947 register Lisp_Object sym
;
949 register Lisp_Object tem
, valcontents
;
951 CHECK_SYMBOL (sym
, 0);
953 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
954 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
956 valcontents
= XSYMBOL (sym
)->value
;
957 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
958 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
960 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
962 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
965 if (EQ (valcontents
, Qunbound
))
966 XSYMBOL (sym
)->value
= Qnil
;
967 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
968 XCONS (tem
)->car
= tem
;
969 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
970 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
974 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
975 1, 1, "vMake Local Variable: ",
976 "Make VARIABLE have a separate value in the current buffer.\n\
977 Other buffers will continue to share a common default value.\n\
978 See also `make-variable-buffer-local'.\n\n\
979 If the variable is already arranged to become local when set,\n\
980 this function causes a local value to exist for this buffer,\n\
981 just as if the variable were set.")
983 register Lisp_Object sym
;
985 register Lisp_Object tem
, valcontents
;
987 CHECK_SYMBOL (sym
, 0);
989 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
990 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
992 valcontents
= XSYMBOL (sym
)->value
;
993 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
994 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
998 /* Make sure the symbol has a local value in this particular buffer,
999 by setting it to the same value it already has. */
1000 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1003 /* Make sure sym is set up to hold per-buffer values */
1004 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1006 if (EQ (valcontents
, Qunbound
))
1007 XSYMBOL (sym
)->value
= Qnil
;
1008 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1009 XCONS (tem
)->car
= tem
;
1010 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1011 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1013 /* Make sure this buffer has its own value of sym */
1014 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1017 current_buffer
->local_var_alist
1018 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1019 current_buffer
->local_var_alist
);
1021 /* Make sure symbol does not think it is set up for this buffer;
1022 force it to look once again for this buffer's value */
1024 /* This local variable avoids "expression too complex" on IBM RT. */
1027 xs
= XSYMBOL (sym
)->value
;
1028 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1029 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1036 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1037 1, 1, "vKill Local Variable: ",
1038 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1039 From now on the default value will apply in this buffer.")
1041 register Lisp_Object sym
;
1043 register Lisp_Object tem
, valcontents
;
1045 CHECK_SYMBOL (sym
, 0);
1047 valcontents
= XSYMBOL (sym
)->value
;
1049 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1051 register int idx
= XUINT (valcontents
);
1052 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1056 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1057 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1058 current_buffer
->local_var_flags
&= ~mask
;
1063 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1064 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1067 /* Get rid of this buffer's alist element, if any */
1069 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1071 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1073 /* Make sure symbol does not think it is set up for this buffer;
1074 force it to look once again for this buffer's value */
1077 sv
= XSYMBOL (sym
)->value
;
1078 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1079 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1085 /* Extract and set vector and string elements */
1087 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1088 "Return the element of ARRAY at index INDEX.\n\
1089 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1091 register Lisp_Object array
;
1094 register int idxval
;
1096 CHECK_NUMBER (idx
, 1);
1097 idxval
= XINT (idx
);
1098 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1099 && XTYPE (array
) != Lisp_Compiled
)
1100 array
= wrong_type_argument (Qarrayp
, array
);
1101 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1102 args_out_of_range (array
, idx
);
1103 if (XTYPE (array
) == Lisp_String
)
1106 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1110 return XVECTOR (array
)->contents
[idxval
];
1113 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1114 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1115 ARRAY may be a vector or a string. INDEX starts at 0.")
1116 (array
, idx
, newelt
)
1117 register Lisp_Object array
;
1118 Lisp_Object idx
, newelt
;
1120 register int idxval
;
1122 CHECK_NUMBER (idx
, 1);
1123 idxval
= XINT (idx
);
1124 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1125 array
= wrong_type_argument (Qarrayp
, array
);
1126 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1127 args_out_of_range (array
, idx
);
1128 CHECK_IMPURE (array
);
1130 if (XTYPE (array
) == Lisp_Vector
)
1131 XVECTOR (array
)->contents
[idxval
] = newelt
;
1134 CHECK_NUMBER (newelt
, 2);
1135 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1142 Farray_length (array
)
1143 register Lisp_Object array
;
1145 register Lisp_Object size
;
1146 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1147 && XTYPE (array
) != Lisp_Compiled
)
1148 array
= wrong_type_argument (Qarrayp
, array
);
1149 XFASTINT (size
) = XVECTOR (array
)->size
;
1153 /* Arithmetic functions */
1155 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1158 arithcompare (num1
, num2
, comparison
)
1159 Lisp_Object num1
, num2
;
1160 enum comparison comparison
;
1165 #ifdef LISP_FLOAT_TYPE
1166 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1167 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1169 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1172 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1173 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1176 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1177 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1178 #endif /* LISP_FLOAT_TYPE */
1183 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1188 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1193 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1198 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1203 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1208 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1214 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1215 "T if two args, both numbers or markers, are equal.")
1217 register Lisp_Object num1
, num2
;
1219 return arithcompare (num1
, num2
, equal
);
1222 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1223 "T if first arg is less than second arg. Both must be numbers or markers.")
1225 register Lisp_Object num1
, num2
;
1227 return arithcompare (num1
, num2
, less
);
1230 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1231 "T if first arg is greater than second arg. Both must be numbers or markers.")
1233 register Lisp_Object num1
, num2
;
1235 return arithcompare (num1
, num2
, grtr
);
1238 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1239 "T if first arg is less than or equal to second arg.\n\
1240 Both must be numbers or markers.")
1242 register Lisp_Object num1
, num2
;
1244 return arithcompare (num1
, num2
, less_or_equal
);
1247 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1248 "T if first arg is greater than or equal to second arg.\n\
1249 Both must be numbers or markers.")
1251 register Lisp_Object num1
, num2
;
1253 return arithcompare (num1
, num2
, grtr_or_equal
);
1256 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1257 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1259 register Lisp_Object num1
, num2
;
1261 return arithcompare (num1
, num2
, notequal
);
1264 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1266 register Lisp_Object num
;
1268 #ifdef LISP_FLOAT_TYPE
1269 CHECK_NUMBER_OR_FLOAT (num
, 0);
1271 if (XTYPE(num
) == Lisp_Float
)
1273 if (XFLOAT(num
)->data
== 0.0)
1278 CHECK_NUMBER (num
, 0);
1279 #endif /* LISP_FLOAT_TYPE */
1286 DEFUN ("int-to-string", Fint_to_string
, Sint_to_string
, 1, 1, 0,
1287 "Convert INT to a string by printing it in decimal.\n\
1288 Uses a minus sign if negative.")
1294 #ifndef LISP_FLOAT_TYPE
1295 CHECK_NUMBER (num
, 0);
1297 CHECK_NUMBER_OR_FLOAT (num
, 0);
1299 if (XTYPE(num
) == Lisp_Float
)
1301 char pigbuf
[350]; /* see comments in float_to_string */
1303 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1304 return build_string (pigbuf
);
1306 #endif /* LISP_FLOAT_TYPE */
1308 sprintf (buffer
, "%d", XINT (num
));
1309 return build_string (buffer
);
1312 DEFUN ("string-to-int", Fstring_to_int
, Sstring_to_int
, 1, 1, 0,
1313 "Convert STRING to an integer by parsing it as a decimal number.")
1315 register Lisp_Object str
;
1317 CHECK_STRING (str
, 0);
1319 #ifdef LISP_FLOAT_TYPE
1320 if (isfloat_string (XSTRING (str
)->data
))
1321 return make_float (atof (XSTRING (str
)->data
));
1322 #endif /* LISP_FLOAT_TYPE */
1324 return make_number (atoi (XSTRING (str
)->data
));
1328 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1335 register Lisp_Object
*args
;
1337 register Lisp_Object val
;
1338 register int argnum
;
1342 #ifdef SWITCH_ENUM_BUG
1359 for (argnum
= 0; argnum
< nargs
; argnum
++)
1361 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1362 #ifdef LISP_FLOAT_TYPE
1363 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1365 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1366 return (float_arith_driver ((double) accum
, argnum
, code
,
1369 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1370 #endif /* LISP_FLOAT_TYPE */
1371 args
[argnum
] = val
; /* runs into a compiler bug. */
1372 next
= XINT (args
[argnum
]);
1373 #ifdef SWITCH_ENUM_BUG
1379 case Aadd
: accum
+= next
; break;
1381 if (!argnum
&& nargs
!= 1)
1385 case Amult
: accum
*= next
; break;
1387 if (!argnum
) accum
= next
;
1390 case Alogand
: accum
&= next
; break;
1391 case Alogior
: accum
|= next
; break;
1392 case Alogxor
: accum
^= next
; break;
1393 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1394 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1398 XSET (val
, Lisp_Int
, accum
);
1402 #ifdef LISP_FLOAT_TYPE
1404 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1406 register int argnum
;
1409 register Lisp_Object
*args
;
1411 register Lisp_Object val
;
1414 for (; argnum
< nargs
; argnum
++)
1416 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1417 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1419 if (XTYPE (val
) == Lisp_Float
)
1421 next
= XFLOAT (val
)->data
;
1425 args
[argnum
] = val
; /* runs into a compiler bug. */
1426 next
= XINT (args
[argnum
]);
1428 #ifdef SWITCH_ENUM_BUG
1438 if (!argnum
&& nargs
!= 1)
1454 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1456 if (!argnum
|| next
> accum
)
1460 if (!argnum
|| next
< accum
)
1466 return make_float (accum
);
1468 #endif /* LISP_FLOAT_TYPE */
1470 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1471 "Return sum of any number of arguments, which are numbers or markers.")
1476 return arith_driver (Aadd
, nargs
, args
);
1479 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1480 "Negate number or subtract numbers or markers.\n\
1481 With one arg, negates it. With more than one arg,\n\
1482 subtracts all but the first from the first.")
1487 return arith_driver (Asub
, nargs
, args
);
1490 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1491 "Returns product of any number of arguments, which are numbers or markers.")
1496 return arith_driver (Amult
, nargs
, args
);
1499 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1500 "Returns first argument divided by all the remaining arguments.\n\
1501 The arguments must be numbers or markers.")
1506 return arith_driver (Adiv
, nargs
, args
);
1509 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1510 "Returns remainder of first arg divided by second.\n\
1511 Both must be numbers or markers.")
1513 register Lisp_Object num1
, num2
;
1517 #ifdef LISP_FLOAT_TYPE
1518 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1519 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1521 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1525 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1526 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1527 return (make_float (drem (f1
,f2
)));
1529 #else /* not LISP_FLOAT_TYPE */
1530 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1531 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1532 #endif /* not LISP_FLOAT_TYPE */
1534 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1538 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1539 "Return largest of all the arguments (which must be numbers or markers).\n\
1540 The value is always a number; markers are converted to numbers.")
1545 return arith_driver (Amax
, nargs
, args
);
1548 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1549 "Return smallest of all the arguments (which must be numbers or markers).\n\
1550 The value is always a number; markers are converted to numbers.")
1555 return arith_driver (Amin
, nargs
, args
);
1558 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1559 "Return bitwise-and of all the arguments.\n\
1560 Arguments may be integers, or markers converted to integers.")
1565 return arith_driver (Alogand
, nargs
, args
);
1568 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1569 "Return bitwise-or of all the arguments.\n\
1570 Arguments may be integers, or markers converted to integers.")
1575 return arith_driver (Alogior
, nargs
, args
);
1578 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1579 "Return bitwise-exclusive-or of all the arguments.\n\
1580 Arguments may be integers, or markers converted to integers.")
1585 return arith_driver (Alogxor
, nargs
, args
);
1588 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1589 "Return VALUE with its bits shifted left by COUNT.\n\
1590 If COUNT is negative, shifting is actually to the right.\n\
1591 In this case, the sign bit is duplicated.")
1593 register Lisp_Object num1
, num2
;
1595 register Lisp_Object val
;
1597 CHECK_NUMBER (num1
, 0);
1598 CHECK_NUMBER (num2
, 1);
1600 if (XINT (num2
) > 0)
1601 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1603 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1607 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1608 "Return VALUE with its bits shifted left by COUNT.\n\
1609 If COUNT is negative, shifting is actually to the right.\n\
1610 In this case, zeros are shifted in on the left.")
1612 register Lisp_Object num1
, num2
;
1614 register Lisp_Object val
;
1616 CHECK_NUMBER (num1
, 0);
1617 CHECK_NUMBER (num2
, 1);
1619 if (XINT (num2
) > 0)
1620 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1622 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1626 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1627 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1628 Markers are converted to integers.")
1630 register Lisp_Object num
;
1632 #ifdef LISP_FLOAT_TYPE
1633 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1635 if (XTYPE (num
) == Lisp_Float
)
1636 return (make_float (1.0 + XFLOAT (num
)->data
));
1638 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1639 #endif /* LISP_FLOAT_TYPE */
1641 XSETINT (num
, XFASTINT (num
) + 1);
1645 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1646 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1647 Markers are converted to integers.")
1649 register Lisp_Object num
;
1651 #ifdef LISP_FLOAT_TYPE
1652 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1654 if (XTYPE (num
) == Lisp_Float
)
1655 return (make_float (-1.0 + XFLOAT (num
)->data
));
1657 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1658 #endif /* LISP_FLOAT_TYPE */
1660 XSETINT (num
, XFASTINT (num
) - 1);
1664 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1665 "Return the bitwise complement of ARG. ARG must be an integer.")
1667 register Lisp_Object num
;
1669 CHECK_NUMBER (num
, 0);
1670 XSETINT (num
, ~XFASTINT (num
));
1677 Qquote
= intern ("quote");
1678 Qlambda
= intern ("lambda");
1679 Qsubr
= intern ("subr");
1680 Qerror_conditions
= intern ("error-conditions");
1681 Qerror_message
= intern ("error-message");
1682 Qtop_level
= intern ("top-level");
1684 Qerror
= intern ("error");
1685 Qquit
= intern ("quit");
1686 Qwrong_type_argument
= intern ("wrong-type-argument");
1687 Qargs_out_of_range
= intern ("args-out-of-range");
1688 Qvoid_function
= intern ("void-function");
1689 Qvoid_variable
= intern ("void-variable");
1690 Qsetting_constant
= intern ("setting-constant");
1691 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1693 Qinvalid_function
= intern ("invalid-function");
1694 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1695 Qno_catch
= intern ("no-catch");
1696 Qend_of_file
= intern ("end-of-file");
1697 Qarith_error
= intern ("arith-error");
1698 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1699 Qend_of_buffer
= intern ("end-of-buffer");
1700 Qbuffer_read_only
= intern ("buffer-read-only");
1702 Qlistp
= intern ("listp");
1703 Qconsp
= intern ("consp");
1704 Qsymbolp
= intern ("symbolp");
1705 Qintegerp
= intern ("integerp");
1706 Qnatnump
= intern ("natnump");
1707 Qstringp
= intern ("stringp");
1708 Qarrayp
= intern ("arrayp");
1709 Qsequencep
= intern ("sequencep");
1710 Qbufferp
= intern ("bufferp");
1711 Qvectorp
= intern ("vectorp");
1712 Qchar_or_string_p
= intern ("char-or-string-p");
1713 Qmarkerp
= intern ("markerp");
1714 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1715 Qboundp
= intern ("boundp");
1716 Qfboundp
= intern ("fboundp");
1718 #ifdef LISP_FLOAT_TYPE
1719 Qfloatp
= intern ("floatp");
1720 Qnumberp
= intern ("numberp");
1721 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1722 #endif /* LISP_FLOAT_TYPE */
1724 Qcdr
= intern ("cdr");
1726 /* ERROR is used as a signaler for random errors for which nothing else is right */
1728 Fput (Qerror
, Qerror_conditions
,
1729 Fcons (Qerror
, Qnil
));
1730 Fput (Qerror
, Qerror_message
,
1731 build_string ("error"));
1733 Fput (Qquit
, Qerror_conditions
,
1734 Fcons (Qquit
, Qnil
));
1735 Fput (Qquit
, Qerror_message
,
1736 build_string ("Quit"));
1738 Fput (Qwrong_type_argument
, Qerror_conditions
,
1739 Fcons (Qwrong_type_argument
, Fcons (Qerror
, Qnil
)));
1740 Fput (Qwrong_type_argument
, Qerror_message
,
1741 build_string ("Wrong type argument"));
1743 Fput (Qargs_out_of_range
, Qerror_conditions
,
1744 Fcons (Qargs_out_of_range
, Fcons (Qerror
, Qnil
)));
1745 Fput (Qargs_out_of_range
, Qerror_message
,
1746 build_string ("Args out of range"));
1748 Fput (Qvoid_function
, Qerror_conditions
,
1749 Fcons (Qvoid_function
, Fcons (Qerror
, Qnil
)));
1750 Fput (Qvoid_function
, Qerror_message
,
1751 build_string ("Symbol's function definition is void"));
1753 Fput (Qvoid_variable
, Qerror_conditions
,
1754 Fcons (Qvoid_variable
, Fcons (Qerror
, Qnil
)));
1755 Fput (Qvoid_variable
, Qerror_message
,
1756 build_string ("Symbol's value as variable is void"));
1758 Fput (Qsetting_constant
, Qerror_conditions
,
1759 Fcons (Qsetting_constant
, Fcons (Qerror
, Qnil
)));
1760 Fput (Qsetting_constant
, Qerror_message
,
1761 build_string ("Attempt to set a constant symbol"));
1763 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
1764 Fcons (Qinvalid_read_syntax
, Fcons (Qerror
, Qnil
)));
1765 Fput (Qinvalid_read_syntax
, Qerror_message
,
1766 build_string ("Invalid read syntax"));
1768 Fput (Qinvalid_function
, Qerror_conditions
,
1769 Fcons (Qinvalid_function
, Fcons (Qerror
, Qnil
)));
1770 Fput (Qinvalid_function
, Qerror_message
,
1771 build_string ("Invalid function"));
1773 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
1774 Fcons (Qwrong_number_of_arguments
, Fcons (Qerror
, Qnil
)));
1775 Fput (Qwrong_number_of_arguments
, Qerror_message
,
1776 build_string ("Wrong number of arguments"));
1778 Fput (Qno_catch
, Qerror_conditions
,
1779 Fcons (Qno_catch
, Fcons (Qerror
, Qnil
)));
1780 Fput (Qno_catch
, Qerror_message
,
1781 build_string ("No catch for tag"));
1783 Fput (Qend_of_file
, Qerror_conditions
,
1784 Fcons (Qend_of_file
, Fcons (Qerror
, Qnil
)));
1785 Fput (Qend_of_file
, Qerror_message
,
1786 build_string ("End of file during parsing"));
1788 Fput (Qarith_error
, Qerror_conditions
,
1789 Fcons (Qarith_error
, Fcons (Qerror
, Qnil
)));
1790 Fput (Qarith_error
, Qerror_message
,
1791 build_string ("Arithmetic error"));
1793 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
1794 Fcons (Qbeginning_of_buffer
, Fcons (Qerror
, Qnil
)));
1795 Fput (Qbeginning_of_buffer
, Qerror_message
,
1796 build_string ("Beginning of buffer"));
1798 Fput (Qend_of_buffer
, Qerror_conditions
,
1799 Fcons (Qend_of_buffer
, Fcons (Qerror
, Qnil
)));
1800 Fput (Qend_of_buffer
, Qerror_message
,
1801 build_string ("End of buffer"));
1803 Fput (Qbuffer_read_only
, Qerror_conditions
,
1804 Fcons (Qbuffer_read_only
, Fcons (Qerror
, Qnil
)));
1805 Fput (Qbuffer_read_only
, Qerror_message
,
1806 build_string ("Buffer is read-only"));
1810 staticpro (&Qquote
);
1811 staticpro (&Qlambda
);
1813 staticpro (&Qunbound
);
1814 staticpro (&Qerror_conditions
);
1815 staticpro (&Qerror_message
);
1816 staticpro (&Qtop_level
);
1818 staticpro (&Qerror
);
1820 staticpro (&Qwrong_type_argument
);
1821 staticpro (&Qargs_out_of_range
);
1822 staticpro (&Qvoid_function
);
1823 staticpro (&Qvoid_variable
);
1824 staticpro (&Qsetting_constant
);
1825 staticpro (&Qinvalid_read_syntax
);
1826 staticpro (&Qwrong_number_of_arguments
);
1827 staticpro (&Qinvalid_function
);
1828 staticpro (&Qno_catch
);
1829 staticpro (&Qend_of_file
);
1830 staticpro (&Qarith_error
);
1831 staticpro (&Qbeginning_of_buffer
);
1832 staticpro (&Qend_of_buffer
);
1833 staticpro (&Qbuffer_read_only
);
1835 staticpro (&Qlistp
);
1836 staticpro (&Qconsp
);
1837 staticpro (&Qsymbolp
);
1838 staticpro (&Qintegerp
);
1839 staticpro (&Qnatnump
);
1840 staticpro (&Qstringp
);
1841 staticpro (&Qarrayp
);
1842 staticpro (&Qsequencep
);
1843 staticpro (&Qbufferp
);
1844 staticpro (&Qvectorp
);
1845 staticpro (&Qchar_or_string_p
);
1846 staticpro (&Qmarkerp
);
1847 staticpro (&Qinteger_or_marker_p
);
1848 #ifdef LISP_FLOAT_TYPE
1849 staticpro (&Qfloatp
);
1850 staticpro (&Qinteger_or_floatp
);
1851 staticpro (&Qinteger_or_float_or_marker_p
);
1852 #endif /* LISP_FLOAT_TYPE */
1854 staticpro (&Qboundp
);
1855 staticpro (&Qfboundp
);
1864 defsubr (&Sintegerp
);
1865 #ifdef LISP_FLOAT_TYPE
1867 defsubr (&Snumberp
);
1868 defsubr (&Snumber_or_marker_p
);
1869 #endif /* LISP_FLOAT_TYPE */
1870 defsubr (&Snatnump
);
1871 defsubr (&Ssymbolp
);
1872 defsubr (&Sstringp
);
1873 defsubr (&Svectorp
);
1875 defsubr (&Ssequencep
);
1876 defsubr (&Sbufferp
);
1877 defsubr (&Smarkerp
);
1878 defsubr (&Sinteger_or_marker_p
);
1880 defsubr (&Scompiled_function_p
);
1881 defsubr (&Schar_or_string_p
);
1884 defsubr (&Scar_safe
);
1885 defsubr (&Scdr_safe
);
1888 defsubr (&Ssymbol_function
);
1889 defsubr (&Ssymbol_plist
);
1890 defsubr (&Ssymbol_name
);
1891 defsubr (&Smakunbound
);
1892 defsubr (&Sfmakunbound
);
1894 defsubr (&Sfboundp
);
1896 defsubr (&Ssetplist
);
1897 defsubr (&Ssymbol_value
);
1899 defsubr (&Sdefault_boundp
);
1900 defsubr (&Sdefault_value
);
1901 defsubr (&Sset_default
);
1902 defsubr (&Ssetq_default
);
1903 defsubr (&Smake_variable_buffer_local
);
1904 defsubr (&Smake_local_variable
);
1905 defsubr (&Skill_local_variable
);
1908 defsubr (&Sint_to_string
);
1909 defsubr (&Sstring_to_int
);
1910 defsubr (&Seqlsign
);
1938 /* USG systems forget handlers when they are used;
1939 must reestablish each time */
1940 signal (signo
, arith_error
);
1943 /* VMS systems are like USG. */
1944 signal (signo
, arith_error
);
1948 #else /* not BSD4_1 */
1950 #endif /* not BSD4_1 */
1952 Fsignal (Qarith_error
, Qnil
);
1957 /* Don't do this if just dumping out.
1958 We don't want to call `signal' in this case
1959 so that we don't have trouble with dumping
1960 signal-delivering routines in an inconsistent state. */
1964 #endif /* CANNOT_DUMP */
1965 signal (SIGFPE
, arith_error
);
1967 signal (SIGEMT
, arith_error
);