1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
31 #include "syssignal.h"
33 #ifdef LISP_FLOAT_TYPE
38 #endif /* LISP_FLOAT_TYPE */
40 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
41 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
42 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
43 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
44 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
45 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
46 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
47 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
48 Lisp_Object Qintegerp
, Qnatnump
, Qsymbolp
, Qlistp
, Qconsp
;
49 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
50 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
51 Lisp_Object Qbuffer_or_string_p
;
52 Lisp_Object Qboundp
, Qfboundp
;
55 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
56 Lisp_Object Qoverflow_error
, Qunderflow_error
;
58 #ifdef LISP_FLOAT_TYPE
60 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
63 static Lisp_Object
swap_in_symval_forwarding ();
66 wrong_type_argument (predicate
, value
)
67 register Lisp_Object predicate
, value
;
69 register Lisp_Object tem
;
72 if (!EQ (Vmocklisp_arguments
, Qt
))
74 if (XTYPE (value
) == Lisp_String
&&
75 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
76 return Fstring_to_number (value
);
77 if (XTYPE (value
) == Lisp_Int
&& EQ (predicate
, Qstringp
))
78 return Fnumber_to_string (value
);
80 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
81 tem
= call1 (predicate
, value
);
89 error ("Attempt to modify read-only object");
93 args_out_of_range (a1
, a2
)
97 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
101 args_out_of_range_3 (a1
, a2
, a3
)
102 Lisp_Object a1
, a2
, a3
;
105 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
112 register Lisp_Object val
;
113 XSET (val
, Lisp_Int
, num
);
117 /* On some machines, XINT needs a temporary location.
118 Here it is, in case it is needed. */
120 int sign_extend_temp
;
122 /* On a few machines, XINT can only be done by calling this. */
125 sign_extend_lisp_int (num
)
128 if (num
& (1 << (VALBITS
- 1)))
129 return num
| ((-1) << VALBITS
);
131 return num
& ((1 << VALBITS
) - 1);
134 /* Data type predicates */
136 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
137 "T if the two args are the same Lisp object.")
139 Lisp_Object obj1
, obj2
;
146 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
155 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
159 if (XTYPE (obj
) == Lisp_Cons
)
164 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
168 if (XTYPE (obj
) == Lisp_Cons
)
173 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
177 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
182 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
186 if (XTYPE (obj
) == Lisp_Cons
|| NILP (obj
))
191 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
195 if (XTYPE (obj
) == Lisp_Symbol
)
200 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
204 if (XTYPE (obj
) == Lisp_Vector
)
209 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
213 if (XTYPE (obj
) == Lisp_String
)
218 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
222 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
227 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
228 "T if OBJECT is a sequence (list or array).")
230 register Lisp_Object obj
;
232 if (CONSP (obj
) || NILP (obj
) ||
233 XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
)
238 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
242 if (XTYPE (obj
) == Lisp_Buffer
)
247 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
251 if (XTYPE (obj
) == Lisp_Marker
)
256 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
260 if (XTYPE (obj
) == Lisp_Subr
)
265 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
266 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
270 if (XTYPE (obj
) == Lisp_Compiled
)
275 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.")
277 register Lisp_Object obj
;
279 if (XTYPE (obj
) == Lisp_Int
|| XTYPE (obj
) == Lisp_String
)
284 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is a number.")
288 if (XTYPE (obj
) == Lisp_Int
)
293 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
294 "T if OBJECT is an integer or a marker (editor pointer).")
296 register Lisp_Object obj
;
298 if (XTYPE (obj
) == Lisp_Marker
|| XTYPE (obj
) == Lisp_Int
)
303 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0, "T if OBJECT is a nonnegative number.")
307 if (XTYPE (obj
) == Lisp_Int
&& XINT (obj
) >= 0)
312 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
313 "T if OBJECT is a number (floating point or integer).")
323 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
324 Snumber_or_marker_p
, 1, 1, 0,
325 "T if OBJECT is a number or a marker.")
330 || XTYPE (obj
) == Lisp_Marker
)
335 #ifdef LISP_FLOAT_TYPE
336 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
337 "T if OBJECT is a floating point number.")
341 if (XTYPE (obj
) == Lisp_Float
)
345 #endif /* LISP_FLOAT_TYPE */
347 /* Extract and set components of lists */
349 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
350 "Return the car of CONSCELL. If arg is nil, return nil.\n\
351 Error if arg is not nil and not a cons cell. See also `car-safe'.")
353 register Lisp_Object list
;
357 if (XTYPE (list
) == Lisp_Cons
)
358 return XCONS (list
)->car
;
359 else if (EQ (list
, Qnil
))
362 list
= wrong_type_argument (Qlistp
, list
);
366 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
367 "Return the car of OBJECT if it is a cons cell, or else nil.")
371 if (XTYPE (object
) == Lisp_Cons
)
372 return XCONS (object
)->car
;
377 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
378 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
379 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
382 register Lisp_Object list
;
386 if (XTYPE (list
) == Lisp_Cons
)
387 return XCONS (list
)->cdr
;
388 else if (EQ (list
, Qnil
))
391 list
= wrong_type_argument (Qlistp
, list
);
395 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
396 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
400 if (XTYPE (object
) == Lisp_Cons
)
401 return XCONS (object
)->cdr
;
406 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
407 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
409 register Lisp_Object cell
, newcar
;
411 if (XTYPE (cell
) != Lisp_Cons
)
412 cell
= wrong_type_argument (Qconsp
, cell
);
415 XCONS (cell
)->car
= newcar
;
419 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
420 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
422 register Lisp_Object cell
, newcdr
;
424 if (XTYPE (cell
) != Lisp_Cons
)
425 cell
= wrong_type_argument (Qconsp
, cell
);
428 XCONS (cell
)->cdr
= newcdr
;
432 /* Extract and set components of symbols */
434 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
436 register Lisp_Object sym
;
438 Lisp_Object valcontents
;
439 CHECK_SYMBOL (sym
, 0);
441 valcontents
= XSYMBOL (sym
)->value
;
443 #ifdef SWITCH_ENUM_BUG
444 switch ((int) XTYPE (valcontents
))
446 switch (XTYPE (valcontents
))
449 case Lisp_Buffer_Local_Value
:
450 case Lisp_Some_Buffer_Local_Value
:
451 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
454 return (XTYPE (valcontents
) == Lisp_Void
|| EQ (valcontents
, Qunbound
)
458 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
460 register Lisp_Object sym
;
462 CHECK_SYMBOL (sym
, 0);
463 return (XTYPE (XSYMBOL (sym
)->function
) == Lisp_Void
464 || EQ (XSYMBOL (sym
)->function
, Qunbound
))
468 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
470 register Lisp_Object sym
;
472 CHECK_SYMBOL (sym
, 0);
473 if (NILP (sym
) || EQ (sym
, Qt
))
474 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
475 Fset (sym
, Qunbound
);
479 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
481 register Lisp_Object sym
;
483 CHECK_SYMBOL (sym
, 0);
484 XSYMBOL (sym
)->function
= Qunbound
;
488 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
489 "Return SYMBOL's function definition. Error if that is void.")
491 register Lisp_Object symbol
;
493 CHECK_SYMBOL (symbol
, 0);
494 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
495 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
496 return XSYMBOL (symbol
)->function
;
499 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
501 register Lisp_Object sym
;
503 CHECK_SYMBOL (sym
, 0);
504 return XSYMBOL (sym
)->plist
;
507 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
509 register Lisp_Object sym
;
511 register Lisp_Object name
;
513 CHECK_SYMBOL (sym
, 0);
514 XSET (name
, Lisp_String
, XSYMBOL (sym
)->name
);
518 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
519 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
521 register Lisp_Object sym
, newdef
;
523 CHECK_SYMBOL (sym
, 0);
525 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
526 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
528 XSYMBOL (sym
)->function
= newdef
;
532 /* This name should be removed once it is eliminated from elsewhere. */
534 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
535 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
536 Associates the function with the current load file, if any.")
538 register Lisp_Object sym
, newdef
;
540 CHECK_SYMBOL (sym
, 0);
541 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
542 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
544 XSYMBOL (sym
)->function
= newdef
;
545 LOADHIST_ATTACH (sym
);
549 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
550 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
551 Associates the function with the current load file, if any.")
553 register Lisp_Object sym
, newdef
;
555 CHECK_SYMBOL (sym
, 0);
556 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
557 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
559 XSYMBOL (sym
)->function
= newdef
;
560 LOADHIST_ATTACH (sym
);
564 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
565 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
567 register Lisp_Object sym
, newplist
;
569 CHECK_SYMBOL (sym
, 0);
570 XSYMBOL (sym
)->plist
= newplist
;
575 /* Getting and setting values of symbols */
577 /* Given the raw contents of a symbol value cell,
578 return the Lisp value of the symbol.
579 This does not handle buffer-local variables; use
580 swap_in_symval_forwarding for that. */
583 do_symval_forwarding (valcontents
)
584 register Lisp_Object valcontents
;
586 register Lisp_Object val
;
587 #ifdef SWITCH_ENUM_BUG
588 switch ((int) XTYPE (valcontents
))
590 switch (XTYPE (valcontents
))
594 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
598 if (*XINTPTR (valcontents
))
603 return *XOBJFWD (valcontents
);
605 case Lisp_Buffer_Objfwd
:
606 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
611 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
612 of SYM. If SYM is buffer-local, VALCONTENTS should be the
613 buffer-independent contents of the value cell: forwarded just one
614 step past the buffer-localness. */
617 store_symval_forwarding (sym
, valcontents
, newval
)
619 register Lisp_Object valcontents
, newval
;
621 #ifdef SWITCH_ENUM_BUG
622 switch ((int) XTYPE (valcontents
))
624 switch (XTYPE (valcontents
))
628 CHECK_NUMBER (newval
, 1);
629 *XINTPTR (valcontents
) = XINT (newval
);
633 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
637 *XOBJFWD (valcontents
) = newval
;
640 case Lisp_Buffer_Objfwd
:
642 unsigned int offset
= XUINT (valcontents
);
644 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
646 if (! NILP (type
) && ! NILP (newval
)
647 && XTYPE (newval
) != XINT (type
))
648 buffer_slot_type_mismatch (valcontents
, newval
);
650 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
656 valcontents
= XSYMBOL (sym
)->value
;
657 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
658 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
659 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
661 XSYMBOL (sym
)->value
= newval
;
665 /* Set up the buffer-local symbol SYM for validity in the current
666 buffer. VALCONTENTS is the contents of its value cell.
667 Return the value forwarded one step past the buffer-local indicator. */
670 swap_in_symval_forwarding (sym
, valcontents
)
671 Lisp_Object sym
, valcontents
;
673 /* valcontents is a list
674 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
676 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
677 local_var_alist, that being the element whose car is this
678 variable. Or it can be a pointer to the
679 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
680 an element in its alist for this variable.
682 If the current buffer is not BUFFER, we store the current
683 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
684 appropriate alist element for the buffer now current and set up
685 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
686 element, and store into BUFFER.
688 Note that REALVALUE can be a forwarding pointer. */
690 register Lisp_Object tem1
;
691 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
693 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
695 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
696 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
697 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
699 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
700 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
701 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
702 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
704 return XCONS (valcontents
)->car
;
707 /* Find the value of a symbol, returning Qunbound if it's not bound.
708 This is helpful for code which just wants to get a variable's value
709 if it has one, without signalling an error.
710 Note that it must not be possible to quit
711 within this function. Great care is required for this. */
714 find_symbol_value (sym
)
717 register Lisp_Object valcontents
, tem1
;
718 register Lisp_Object val
;
719 CHECK_SYMBOL (sym
, 0);
720 valcontents
= XSYMBOL (sym
)->value
;
723 #ifdef SWITCH_ENUM_BUG
724 switch ((int) XTYPE (valcontents
))
726 switch (XTYPE (valcontents
))
729 case Lisp_Buffer_Local_Value
:
730 case Lisp_Some_Buffer_Local_Value
:
731 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
735 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
739 if (*XINTPTR (valcontents
))
744 return *XOBJFWD (valcontents
);
746 case Lisp_Buffer_Objfwd
:
747 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
756 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
757 "Return SYMBOL's value. Error if that is void.")
761 Lisp_Object val
= find_symbol_value (sym
);
763 if (EQ (val
, Qunbound
))
764 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
769 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
770 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
772 register Lisp_Object sym
, newval
;
774 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
776 #ifndef RTPC_REGISTER_BUG
777 register Lisp_Object valcontents
, tem1
, current_alist_element
;
778 #else /* RTPC_REGISTER_BUG */
779 register Lisp_Object tem1
;
780 Lisp_Object valcontents
, current_alist_element
;
781 #endif /* RTPC_REGISTER_BUG */
783 CHECK_SYMBOL (sym
, 0);
784 if (NILP (sym
) || EQ (sym
, Qt
))
785 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
786 valcontents
= XSYMBOL (sym
)->value
;
788 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
790 register int idx
= XUINT (valcontents
);
791 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
793 current_buffer
->local_var_flags
|= mask
;
796 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
797 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
799 /* valcontents is actually a pointer to a cons heading something like:
800 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
802 BUFFER is the last buffer for which this symbol's value was
805 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
806 local_var_alist, that being the element whose car is this
807 variable. Or it can be a pointer to the
808 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
809 have an element in its alist for this variable (that is, if
810 BUFFER sees the default value of this variable).
812 If we want to examine or set the value and BUFFER is current,
813 we just examine or set REALVALUE. If BUFFER is not current, we
814 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
815 then find the appropriate alist element for the buffer now
816 current and set up CURRENT-ALIST-ELEMENT. Then we set
817 REALVALUE out of that element, and store into BUFFER.
819 If we are setting the variable and the current buffer does
820 not have an alist entry for this variable, an alist entry is
823 Note that REALVALUE can be a forwarding pointer. Each time
824 it is examined or set, forwarding must be done. */
826 /* What value are we caching right now? */
827 current_alist_element
=
828 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
830 /* If the current buffer is not the buffer whose binding is
831 currently cached, or if it's a Lisp_Buffer_Local_Value and
832 we're looking at the default value, the cache is invalid; we
833 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
835 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
836 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
837 && EQ (XCONS (current_alist_element
)->car
,
838 current_alist_element
)))
840 /* Write out the cached value for the old buffer; copy it
841 back to its alist element. This works if the current
842 buffer only sees the default value, too. */
843 Fsetcdr (current_alist_element
,
844 do_symval_forwarding (XCONS (valcontents
)->car
));
846 /* Find the new value for CURRENT-ALIST-ELEMENT. */
847 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
850 /* This buffer still sees the default value. */
852 /* If the variable is a Lisp_Some_Buffer_Local_Value,
853 make CURRENT-ALIST-ELEMENT point to itself,
854 indicating that we're seeing the default value. */
855 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
856 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
858 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
859 new assoc for a local value and set
860 CURRENT-ALIST-ELEMENT to point to that. */
863 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
864 current_buffer
->local_var_alist
=
865 Fcons (tem1
, current_buffer
->local_var_alist
);
868 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
869 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
871 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
872 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
873 Lisp_Buffer
, current_buffer
);
875 valcontents
= XCONS (valcontents
)->car
;
878 /* If storing void (making the symbol void), forward only through
879 buffer-local indicator, not through Lisp_Objfwd, etc. */
881 store_symval_forwarding (sym
, Qnil
, newval
);
883 store_symval_forwarding (sym
, valcontents
, newval
);
888 /* Access or set a buffer-local symbol's default value. */
890 /* Return the default value of SYM, but don't check for voidness.
891 Return Qunbound or a Lisp_Void object if it is void. */
897 register Lisp_Object valcontents
;
899 CHECK_SYMBOL (sym
, 0);
900 valcontents
= XSYMBOL (sym
)->value
;
902 /* For a built-in buffer-local variable, get the default value
903 rather than letting do_symval_forwarding get the current value. */
904 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
906 register int idx
= XUINT (valcontents
);
908 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
909 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
912 /* Handle user-created local variables. */
913 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
914 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
916 /* If var is set up for a buffer that lacks a local value for it,
917 the current value is nominally the default value.
918 But the current value slot may be more up to date, since
919 ordinary setq stores just that slot. So use that. */
920 Lisp_Object current_alist_element
, alist_element_car
;
921 current_alist_element
922 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
923 alist_element_car
= XCONS (current_alist_element
)->car
;
924 if (EQ (alist_element_car
, current_alist_element
))
925 return do_symval_forwarding (XCONS (valcontents
)->car
);
927 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
929 /* For other variables, get the current value. */
930 return do_symval_forwarding (valcontents
);
933 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
934 "Return T if SYMBOL has a non-void default value.\n\
935 This is the value that is seen in buffers that do not have their own values\n\
940 register Lisp_Object value
;
942 value
= default_value (sym
);
943 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
947 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
948 "Return SYMBOL's default value.\n\
949 This is the value that is seen in buffers that do not have their own values\n\
950 for this variable. The default value is meaningful for variables with\n\
951 local bindings in certain buffers.")
955 register Lisp_Object value
;
957 value
= default_value (sym
);
958 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
959 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
963 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
964 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
965 The default value is seen in buffers that do not have their own values\n\
968 Lisp_Object sym
, value
;
970 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
972 CHECK_SYMBOL (sym
, 0);
973 valcontents
= XSYMBOL (sym
)->value
;
975 /* Handle variables like case-fold-search that have special slots
976 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
978 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
980 register int idx
= XUINT (valcontents
);
981 #ifndef RTPC_REGISTER_BUG
982 register struct buffer
*b
;
986 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
990 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
991 for (b
= all_buffers
; b
; b
= b
->next
)
992 if (!(b
->local_var_flags
& mask
))
993 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
998 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
999 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1000 return Fset (sym
, value
);
1002 /* Store new value into the DEFAULT-VALUE slot */
1003 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1005 /* If that slot is current, we must set the REALVALUE slot too */
1006 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
1007 alist_element_buffer
= Fcar (current_alist_element
);
1008 if (EQ (alist_element_buffer
, current_alist_element
))
1009 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
1014 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1016 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
1017 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
1018 not have their own values for this variable.")
1022 register Lisp_Object args_left
;
1023 register Lisp_Object val
, sym
;
1024 struct gcpro gcpro1
;
1034 val
= Feval (Fcar (Fcdr (args_left
)));
1035 sym
= Fcar (args_left
);
1036 Fset_default (sym
, val
);
1037 args_left
= Fcdr (Fcdr (args_left
));
1039 while (!NILP (args_left
));
1045 /* Lisp functions for creating and removing buffer-local variables. */
1047 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1048 1, 1, "vMake Variable Buffer Local: ",
1049 "Make VARIABLE have a separate value for each buffer.\n\
1050 At any time, the value for the current buffer is in effect.\n\
1051 There is also a default value which is seen in any buffer which has not yet\n\
1052 set its own value.\n\
1053 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1054 for the current buffer if it was previously using the default value.\n\
1055 The function `default-value' gets the default value and `set-default' sets it.")
1057 register Lisp_Object sym
;
1059 register Lisp_Object tem
, valcontents
;
1061 CHECK_SYMBOL (sym
, 0);
1063 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1064 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1066 valcontents
= XSYMBOL (sym
)->value
;
1067 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1068 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1070 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1072 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1075 if (EQ (valcontents
, Qunbound
))
1076 XSYMBOL (sym
)->value
= Qnil
;
1077 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1078 XCONS (tem
)->car
= tem
;
1079 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1080 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1084 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1085 1, 1, "vMake Local Variable: ",
1086 "Make VARIABLE have a separate value in the current buffer.\n\
1087 Other buffers will continue to share a common default value.\n\
1088 See also `make-variable-buffer-local'.\n\n\
1089 If the variable is already arranged to become local when set,\n\
1090 this function causes a local value to exist for this buffer,\n\
1091 just as if the variable were set.")
1093 register Lisp_Object sym
;
1095 register Lisp_Object tem
, valcontents
;
1097 CHECK_SYMBOL (sym
, 0);
1099 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1100 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1102 valcontents
= XSYMBOL (sym
)->value
;
1103 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1104 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1106 tem
= Fboundp (sym
);
1108 /* Make sure the symbol has a local value in this particular buffer,
1109 by setting it to the same value it already has. */
1110 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1113 /* Make sure sym is set up to hold per-buffer values */
1114 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1116 if (EQ (valcontents
, Qunbound
))
1117 XSYMBOL (sym
)->value
= Qnil
;
1118 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1119 XCONS (tem
)->car
= tem
;
1120 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1121 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1123 /* Make sure this buffer has its own value of sym */
1124 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1127 current_buffer
->local_var_alist
1128 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1129 current_buffer
->local_var_alist
);
1131 /* Make sure symbol does not think it is set up for this buffer;
1132 force it to look once again for this buffer's value */
1134 /* This local variable avoids "expression too complex" on IBM RT. */
1137 xs
= XSYMBOL (sym
)->value
;
1138 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1139 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1143 /* If the symbol forwards into a C variable, then swap in the
1144 variable for this buffer immediately. If C code modifies the
1145 variable before we swap in, then that new value will clobber the
1146 default value the next time we swap. */
1147 valcontents
= XCONS (XSYMBOL (sym
)->value
)->car
;
1148 if (XTYPE (valcontents
) == Lisp_Intfwd
1149 || XTYPE (valcontents
) == Lisp_Boolfwd
1150 || XTYPE (valcontents
) == Lisp_Objfwd
)
1151 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1156 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1157 1, 1, "vKill Local Variable: ",
1158 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1159 From now on the default value will apply in this buffer.")
1161 register Lisp_Object sym
;
1163 register Lisp_Object tem
, valcontents
;
1165 CHECK_SYMBOL (sym
, 0);
1167 valcontents
= XSYMBOL (sym
)->value
;
1169 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1171 register int idx
= XUINT (valcontents
);
1172 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1176 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1177 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1178 current_buffer
->local_var_flags
&= ~mask
;
1183 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1184 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1187 /* Get rid of this buffer's alist element, if any */
1189 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1191 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1193 /* Make sure symbol does not think it is set up for this buffer;
1194 force it to look once again for this buffer's value */
1197 sv
= XSYMBOL (sym
)->value
;
1198 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1199 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1205 /* Find the function at the end of a chain of symbol function indirections. */
1207 /* If OBJECT is a symbol, find the end of its function chain and
1208 return the value found there. If OBJECT is not a symbol, just
1209 return it. If there is a cycle in the function chain, signal a
1210 cyclic-function-indirection error.
1212 This is like Findirect_function, except that it doesn't signal an
1213 error if the chain ends up unbound. */
1215 indirect_function (object
)
1216 register Lisp_Object object
;
1218 Lisp_Object tortoise
, hare
;
1220 hare
= tortoise
= object
;
1224 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1226 hare
= XSYMBOL (hare
)->function
;
1227 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1229 hare
= XSYMBOL (hare
)->function
;
1231 tortoise
= XSYMBOL (tortoise
)->function
;
1233 if (EQ (hare
, tortoise
))
1234 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1240 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1241 "Return the function at the end of OBJECT's function chain.\n\
1242 If OBJECT is a symbol, follow all function indirections and return the final\n\
1243 function binding.\n\
1244 If OBJECT is not a symbol, just return it.\n\
1245 Signal a void-function error if the final symbol is unbound.\n\
1246 Signal a cyclic-function-indirection error if there is a loop in the\n\
1247 function chain of symbols.")
1249 register Lisp_Object object
;
1253 result
= indirect_function (object
);
1255 if (EQ (result
, Qunbound
))
1256 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1260 /* Extract and set vector and string elements */
1262 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1263 "Return the element of ARRAY at index INDEX.\n\
1264 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1266 register Lisp_Object array
;
1269 register int idxval
;
1271 CHECK_NUMBER (idx
, 1);
1272 idxval
= XINT (idx
);
1273 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1274 && XTYPE (array
) != Lisp_Compiled
)
1275 array
= wrong_type_argument (Qarrayp
, array
);
1276 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1277 args_out_of_range (array
, idx
);
1278 if (XTYPE (array
) == Lisp_String
)
1281 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1285 return XVECTOR (array
)->contents
[idxval
];
1288 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1289 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1290 ARRAY may be a vector or a string. INDEX starts at 0.")
1291 (array
, idx
, newelt
)
1292 register Lisp_Object array
;
1293 Lisp_Object idx
, newelt
;
1295 register int idxval
;
1297 CHECK_NUMBER (idx
, 1);
1298 idxval
= XINT (idx
);
1299 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1300 array
= wrong_type_argument (Qarrayp
, array
);
1301 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1302 args_out_of_range (array
, idx
);
1303 CHECK_IMPURE (array
);
1305 if (XTYPE (array
) == Lisp_Vector
)
1306 XVECTOR (array
)->contents
[idxval
] = newelt
;
1309 CHECK_NUMBER (newelt
, 2);
1310 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1317 Farray_length (array
)
1318 register Lisp_Object array
;
1320 register Lisp_Object size
;
1321 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1322 && XTYPE (array
) != Lisp_Compiled
)
1323 array
= wrong_type_argument (Qarrayp
, array
);
1324 XFASTINT (size
) = XVECTOR (array
)->size
;
1328 /* Arithmetic functions */
1330 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1333 arithcompare (num1
, num2
, comparison
)
1334 Lisp_Object num1
, num2
;
1335 enum comparison comparison
;
1340 #ifdef LISP_FLOAT_TYPE
1341 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1342 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1344 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1347 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1348 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1351 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1352 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1353 #endif /* LISP_FLOAT_TYPE */
1358 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1363 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1368 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1373 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1378 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1383 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1392 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1393 "T if two args, both numbers or markers, are equal.")
1395 register Lisp_Object num1
, num2
;
1397 return arithcompare (num1
, num2
, equal
);
1400 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1401 "T if first arg is less than second arg. Both must be numbers or markers.")
1403 register Lisp_Object num1
, num2
;
1405 return arithcompare (num1
, num2
, less
);
1408 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1409 "T if first arg is greater than second arg. Both must be numbers or markers.")
1411 register Lisp_Object num1
, num2
;
1413 return arithcompare (num1
, num2
, grtr
);
1416 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1417 "T if first arg is less than or equal to second arg.\n\
1418 Both must be numbers or markers.")
1420 register Lisp_Object num1
, num2
;
1422 return arithcompare (num1
, num2
, less_or_equal
);
1425 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1426 "T if first arg is greater than or equal to second arg.\n\
1427 Both must be numbers or markers.")
1429 register Lisp_Object num1
, num2
;
1431 return arithcompare (num1
, num2
, grtr_or_equal
);
1434 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1435 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1437 register Lisp_Object num1
, num2
;
1439 return arithcompare (num1
, num2
, notequal
);
1442 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1444 register Lisp_Object num
;
1446 #ifdef LISP_FLOAT_TYPE
1447 CHECK_NUMBER_OR_FLOAT (num
, 0);
1449 if (XTYPE(num
) == Lisp_Float
)
1451 if (XFLOAT(num
)->data
== 0.0)
1456 CHECK_NUMBER (num
, 0);
1457 #endif /* LISP_FLOAT_TYPE */
1464 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1470 unsigned int top
= i
>> 16;
1471 unsigned int bot
= i
& 0xFFFF;
1473 return make_number (bot
);
1475 return Fcons (make_number (-1), make_number (bot
));
1476 return Fcons (make_number (top
), make_number (bot
));
1483 Lisp_Object top
, bot
;
1486 top
= XCONS (c
)->car
;
1487 bot
= XCONS (c
)->cdr
;
1489 bot
= XCONS (bot
)->car
;
1490 return ((XINT (top
) << 16) | XINT (bot
));
1493 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1494 "Convert NUM to a string by printing it in decimal.\n\
1495 Uses a minus sign if negative.\n\
1496 NUM may be an integer or a floating point number.")
1502 #ifndef LISP_FLOAT_TYPE
1503 CHECK_NUMBER (num
, 0);
1505 CHECK_NUMBER_OR_FLOAT (num
, 0);
1507 if (XTYPE(num
) == Lisp_Float
)
1509 char pigbuf
[350]; /* see comments in float_to_string */
1511 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1512 return build_string (pigbuf
);
1514 #endif /* LISP_FLOAT_TYPE */
1516 sprintf (buffer
, "%d", XINT (num
));
1517 return build_string (buffer
);
1520 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1521 "Convert STRING to a number by parsing it as a decimal number.\n\
1522 This parses both integers and floating point numbers.")
1524 register Lisp_Object str
;
1528 CHECK_STRING (str
, 0);
1530 p
= XSTRING (str
)->data
;
1532 /* Skip any whitespace at the front of the number. Some versions of
1533 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1534 while (*p
== ' ' || *p
== '\t')
1537 #ifdef LISP_FLOAT_TYPE
1538 if (isfloat_string (p
))
1539 return make_float (atof (p
));
1540 #endif /* LISP_FLOAT_TYPE */
1542 return make_number (atoi (p
));
1546 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1548 extern Lisp_Object
float_arith_driver ();
1551 arith_driver (code
, nargs
, args
)
1554 register Lisp_Object
*args
;
1556 register Lisp_Object val
;
1557 register int argnum
;
1561 #ifdef SWITCH_ENUM_BUG
1578 for (argnum
= 0; argnum
< nargs
; argnum
++)
1580 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1581 #ifdef LISP_FLOAT_TYPE
1582 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1584 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1585 return (float_arith_driver ((double) accum
, argnum
, code
,
1588 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1589 #endif /* LISP_FLOAT_TYPE */
1590 args
[argnum
] = val
; /* runs into a compiler bug. */
1591 next
= XINT (args
[argnum
]);
1592 #ifdef SWITCH_ENUM_BUG
1598 case Aadd
: accum
+= next
; break;
1600 if (!argnum
&& nargs
!= 1)
1604 case Amult
: accum
*= next
; break;
1606 if (!argnum
) accum
= next
;
1610 Fsignal (Qarith_error
, Qnil
);
1614 case Alogand
: accum
&= next
; break;
1615 case Alogior
: accum
|= next
; break;
1616 case Alogxor
: accum
^= next
; break;
1617 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1618 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1622 XSET (val
, Lisp_Int
, accum
);
1626 #ifdef LISP_FLOAT_TYPE
1628 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1630 register int argnum
;
1633 register Lisp_Object
*args
;
1635 register Lisp_Object val
;
1638 for (; argnum
< nargs
; argnum
++)
1640 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1641 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1643 if (XTYPE (val
) == Lisp_Float
)
1645 next
= XFLOAT (val
)->data
;
1649 args
[argnum
] = val
; /* runs into a compiler bug. */
1650 next
= XINT (args
[argnum
]);
1652 #ifdef SWITCH_ENUM_BUG
1662 if (!argnum
&& nargs
!= 1)
1675 Fsignal (Qarith_error
, Qnil
);
1682 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1684 if (!argnum
|| next
> accum
)
1688 if (!argnum
|| next
< accum
)
1694 return make_float (accum
);
1696 #endif /* LISP_FLOAT_TYPE */
1698 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1699 "Return sum of any number of arguments, which are numbers or markers.")
1704 return arith_driver (Aadd
, nargs
, args
);
1707 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1708 "Negate number or subtract numbers or markers.\n\
1709 With one arg, negates it. With more than one arg,\n\
1710 subtracts all but the first from the first.")
1715 return arith_driver (Asub
, nargs
, args
);
1718 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1719 "Returns product of any number of arguments, which are numbers or markers.")
1724 return arith_driver (Amult
, nargs
, args
);
1727 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1728 "Returns first argument divided by all the remaining arguments.\n\
1729 The arguments must be numbers or markers.")
1734 return arith_driver (Adiv
, nargs
, args
);
1737 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1738 "Returns remainder of first arg divided by second.\n\
1739 Both must be numbers or markers.")
1741 register Lisp_Object num1
, num2
;
1745 #ifdef LISP_FLOAT_TYPE
1746 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1747 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1749 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1753 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1754 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1756 Fsignal (Qarith_error
, Qnil
);
1758 #if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux)
1763 /* If the "remainder" comes out with the wrong sign, fix it. */
1764 if ((f1
< 0) != (f2
< 0))
1766 return (make_float (f1
));
1768 #else /* not LISP_FLOAT_TYPE */
1769 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1770 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1771 #endif /* not LISP_FLOAT_TYPE */
1773 if (XFASTINT (num2
) == 0)
1774 Fsignal (Qarith_error
, Qnil
);
1776 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1780 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1781 "Return largest of all the arguments (which must be numbers or markers).\n\
1782 The value is always a number; markers are converted to numbers.")
1787 return arith_driver (Amax
, nargs
, args
);
1790 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1791 "Return smallest of all the arguments (which must be numbers or markers).\n\
1792 The value is always a number; markers are converted to numbers.")
1797 return arith_driver (Amin
, nargs
, args
);
1800 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1801 "Return bitwise-and of all the arguments.\n\
1802 Arguments may be integers, or markers converted to integers.")
1807 return arith_driver (Alogand
, nargs
, args
);
1810 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1811 "Return bitwise-or of all the arguments.\n\
1812 Arguments may be integers, or markers converted to integers.")
1817 return arith_driver (Alogior
, nargs
, args
);
1820 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1821 "Return bitwise-exclusive-or of all the arguments.\n\
1822 Arguments may be integers, or markers converted to integers.")
1827 return arith_driver (Alogxor
, nargs
, args
);
1830 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1831 "Return VALUE with its bits shifted left by COUNT.\n\
1832 If COUNT is negative, shifting is actually to the right.\n\
1833 In this case, the sign bit is duplicated.")
1835 register Lisp_Object num1
, num2
;
1837 register Lisp_Object val
;
1839 CHECK_NUMBER (num1
, 0);
1840 CHECK_NUMBER (num2
, 1);
1842 if (XINT (num2
) > 0)
1843 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1845 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1849 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1850 "Return VALUE with its bits shifted left by COUNT.\n\
1851 If COUNT is negative, shifting is actually to the right.\n\
1852 In this case, zeros are shifted in on the left.")
1854 register Lisp_Object num1
, num2
;
1856 register Lisp_Object val
;
1858 CHECK_NUMBER (num1
, 0);
1859 CHECK_NUMBER (num2
, 1);
1861 if (XINT (num2
) > 0)
1862 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1864 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1868 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1869 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1870 Markers are converted to integers.")
1872 register Lisp_Object num
;
1874 #ifdef LISP_FLOAT_TYPE
1875 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1877 if (XTYPE (num
) == Lisp_Float
)
1878 return (make_float (1.0 + XFLOAT (num
)->data
));
1880 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1881 #endif /* LISP_FLOAT_TYPE */
1883 XSETINT (num
, XFASTINT (num
) + 1);
1887 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1888 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1889 Markers are converted to integers.")
1891 register Lisp_Object num
;
1893 #ifdef LISP_FLOAT_TYPE
1894 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1896 if (XTYPE (num
) == Lisp_Float
)
1897 return (make_float (-1.0 + XFLOAT (num
)->data
));
1899 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1900 #endif /* LISP_FLOAT_TYPE */
1902 XSETINT (num
, XFASTINT (num
) - 1);
1906 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1907 "Return the bitwise complement of ARG. ARG must be an integer.")
1909 register Lisp_Object num
;
1911 CHECK_NUMBER (num
, 0);
1912 XSETINT (num
, ~XFASTINT (num
));
1919 Lisp_Object error_tail
, arith_tail
;
1921 Qquote
= intern ("quote");
1922 Qlambda
= intern ("lambda");
1923 Qsubr
= intern ("subr");
1924 Qerror_conditions
= intern ("error-conditions");
1925 Qerror_message
= intern ("error-message");
1926 Qtop_level
= intern ("top-level");
1928 Qerror
= intern ("error");
1929 Qquit
= intern ("quit");
1930 Qwrong_type_argument
= intern ("wrong-type-argument");
1931 Qargs_out_of_range
= intern ("args-out-of-range");
1932 Qvoid_function
= intern ("void-function");
1933 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
1934 Qvoid_variable
= intern ("void-variable");
1935 Qsetting_constant
= intern ("setting-constant");
1936 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1938 Qinvalid_function
= intern ("invalid-function");
1939 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1940 Qno_catch
= intern ("no-catch");
1941 Qend_of_file
= intern ("end-of-file");
1942 Qarith_error
= intern ("arith-error");
1943 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1944 Qend_of_buffer
= intern ("end-of-buffer");
1945 Qbuffer_read_only
= intern ("buffer-read-only");
1946 Qmark_inactive
= intern ("mark-inactive");
1948 Qlistp
= intern ("listp");
1949 Qconsp
= intern ("consp");
1950 Qsymbolp
= intern ("symbolp");
1951 Qintegerp
= intern ("integerp");
1952 Qnatnump
= intern ("natnump");
1953 Qstringp
= intern ("stringp");
1954 Qarrayp
= intern ("arrayp");
1955 Qsequencep
= intern ("sequencep");
1956 Qbufferp
= intern ("bufferp");
1957 Qvectorp
= intern ("vectorp");
1958 Qchar_or_string_p
= intern ("char-or-string-p");
1959 Qmarkerp
= intern ("markerp");
1960 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
1961 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1962 Qboundp
= intern ("boundp");
1963 Qfboundp
= intern ("fboundp");
1965 #ifdef LISP_FLOAT_TYPE
1966 Qfloatp
= intern ("floatp");
1967 Qnumberp
= intern ("numberp");
1968 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1969 #endif /* LISP_FLOAT_TYPE */
1971 Qcdr
= intern ("cdr");
1973 error_tail
= Fcons (Qerror
, Qnil
);
1975 /* ERROR is used as a signaler for random errors for which nothing else is right */
1977 Fput (Qerror
, Qerror_conditions
,
1979 Fput (Qerror
, Qerror_message
,
1980 build_string ("error"));
1982 Fput (Qquit
, Qerror_conditions
,
1983 Fcons (Qquit
, Qnil
));
1984 Fput (Qquit
, Qerror_message
,
1985 build_string ("Quit"));
1987 Fput (Qwrong_type_argument
, Qerror_conditions
,
1988 Fcons (Qwrong_type_argument
, error_tail
));
1989 Fput (Qwrong_type_argument
, Qerror_message
,
1990 build_string ("Wrong type argument"));
1992 Fput (Qargs_out_of_range
, Qerror_conditions
,
1993 Fcons (Qargs_out_of_range
, error_tail
));
1994 Fput (Qargs_out_of_range
, Qerror_message
,
1995 build_string ("Args out of range"));
1997 Fput (Qvoid_function
, Qerror_conditions
,
1998 Fcons (Qvoid_function
, error_tail
));
1999 Fput (Qvoid_function
, Qerror_message
,
2000 build_string ("Symbol's function definition is void"));
2002 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2003 Fcons (Qcyclic_function_indirection
, error_tail
));
2004 Fput (Qcyclic_function_indirection
, Qerror_message
,
2005 build_string ("Symbol's chain of function indirections contains a loop"));
2007 Fput (Qvoid_variable
, Qerror_conditions
,
2008 Fcons (Qvoid_variable
, error_tail
));
2009 Fput (Qvoid_variable
, Qerror_message
,
2010 build_string ("Symbol's value as variable is void"));
2012 Fput (Qsetting_constant
, Qerror_conditions
,
2013 Fcons (Qsetting_constant
, error_tail
));
2014 Fput (Qsetting_constant
, Qerror_message
,
2015 build_string ("Attempt to set a constant symbol"));
2017 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2018 Fcons (Qinvalid_read_syntax
, error_tail
));
2019 Fput (Qinvalid_read_syntax
, Qerror_message
,
2020 build_string ("Invalid read syntax"));
2022 Fput (Qinvalid_function
, Qerror_conditions
,
2023 Fcons (Qinvalid_function
, error_tail
));
2024 Fput (Qinvalid_function
, Qerror_message
,
2025 build_string ("Invalid function"));
2027 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2028 Fcons (Qwrong_number_of_arguments
, error_tail
));
2029 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2030 build_string ("Wrong number of arguments"));
2032 Fput (Qno_catch
, Qerror_conditions
,
2033 Fcons (Qno_catch
, error_tail
));
2034 Fput (Qno_catch
, Qerror_message
,
2035 build_string ("No catch for tag"));
2037 Fput (Qend_of_file
, Qerror_conditions
,
2038 Fcons (Qend_of_file
, error_tail
));
2039 Fput (Qend_of_file
, Qerror_message
,
2040 build_string ("End of file during parsing"));
2042 arith_tail
= Fcons (Qarith_error
, error_tail
);
2043 Fput (Qarith_error
, Qerror_conditions
,
2045 Fput (Qarith_error
, Qerror_message
,
2046 build_string ("Arithmetic error"));
2048 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2049 Fcons (Qbeginning_of_buffer
, error_tail
));
2050 Fput (Qbeginning_of_buffer
, Qerror_message
,
2051 build_string ("Beginning of buffer"));
2053 Fput (Qend_of_buffer
, Qerror_conditions
,
2054 Fcons (Qend_of_buffer
, error_tail
));
2055 Fput (Qend_of_buffer
, Qerror_message
,
2056 build_string ("End of buffer"));
2058 Fput (Qbuffer_read_only
, Qerror_conditions
,
2059 Fcons (Qbuffer_read_only
, error_tail
));
2060 Fput (Qbuffer_read_only
, Qerror_message
,
2061 build_string ("Buffer is read-only"));
2063 #ifdef LISP_FLOAT_TYPE
2064 Qrange_error
= intern ("range-error");
2065 Qdomain_error
= intern ("domain-error");
2066 Qsingularity_error
= intern ("singularity-error");
2067 Qoverflow_error
= intern ("overflow-error");
2068 Qunderflow_error
= intern ("underflow-error");
2070 Fput (Qdomain_error
, Qerror_conditions
,
2071 Fcons (Qdomain_error
, arith_tail
));
2072 Fput (Qdomain_error
, Qerror_message
,
2073 build_string ("Arithmetic domain error"));
2075 Fput (Qrange_error
, Qerror_conditions
,
2076 Fcons (Qrange_error
, arith_tail
));
2077 Fput (Qrange_error
, Qerror_message
,
2078 build_string ("Arithmetic range error"));
2080 Fput (Qsingularity_error
, Qerror_conditions
,
2081 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2082 Fput (Qsingularity_error
, Qerror_message
,
2083 build_string ("Arithmetic singularity error"));
2085 Fput (Qoverflow_error
, Qerror_conditions
,
2086 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2087 Fput (Qoverflow_error
, Qerror_message
,
2088 build_string ("Arithmetic overflow error"));
2090 Fput (Qunderflow_error
, Qerror_conditions
,
2091 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2092 Fput (Qunderflow_error
, Qerror_message
,
2093 build_string ("Arithmetic underflow error"));
2095 staticpro (&Qrange_error
);
2096 staticpro (&Qdomain_error
);
2097 staticpro (&Qsingularity_error
);
2098 staticpro (&Qoverflow_error
);
2099 staticpro (&Qunderflow_error
);
2100 #endif /* LISP_FLOAT_TYPE */
2104 staticpro (&Qquote
);
2105 staticpro (&Qlambda
);
2107 staticpro (&Qunbound
);
2108 staticpro (&Qerror_conditions
);
2109 staticpro (&Qerror_message
);
2110 staticpro (&Qtop_level
);
2112 staticpro (&Qerror
);
2114 staticpro (&Qwrong_type_argument
);
2115 staticpro (&Qargs_out_of_range
);
2116 staticpro (&Qvoid_function
);
2117 staticpro (&Qcyclic_function_indirection
);
2118 staticpro (&Qvoid_variable
);
2119 staticpro (&Qsetting_constant
);
2120 staticpro (&Qinvalid_read_syntax
);
2121 staticpro (&Qwrong_number_of_arguments
);
2122 staticpro (&Qinvalid_function
);
2123 staticpro (&Qno_catch
);
2124 staticpro (&Qend_of_file
);
2125 staticpro (&Qarith_error
);
2126 staticpro (&Qbeginning_of_buffer
);
2127 staticpro (&Qend_of_buffer
);
2128 staticpro (&Qbuffer_read_only
);
2129 staticpro (&Qmark_inactive
);
2131 staticpro (&Qlistp
);
2132 staticpro (&Qconsp
);
2133 staticpro (&Qsymbolp
);
2134 staticpro (&Qintegerp
);
2135 staticpro (&Qnatnump
);
2136 staticpro (&Qstringp
);
2137 staticpro (&Qarrayp
);
2138 staticpro (&Qsequencep
);
2139 staticpro (&Qbufferp
);
2140 staticpro (&Qvectorp
);
2141 staticpro (&Qchar_or_string_p
);
2142 staticpro (&Qmarkerp
);
2143 staticpro (&Qbuffer_or_string_p
);
2144 staticpro (&Qinteger_or_marker_p
);
2145 #ifdef LISP_FLOAT_TYPE
2146 staticpro (&Qfloatp
);
2147 staticpro (&Qnumberp
);
2148 staticpro (&Qnumber_or_marker_p
);
2149 #endif /* LISP_FLOAT_TYPE */
2151 staticpro (&Qboundp
);
2152 staticpro (&Qfboundp
);
2161 defsubr (&Sintegerp
);
2162 defsubr (&Sinteger_or_marker_p
);
2163 defsubr (&Snumberp
);
2164 defsubr (&Snumber_or_marker_p
);
2165 #ifdef LISP_FLOAT_TYPE
2167 #endif /* LISP_FLOAT_TYPE */
2168 defsubr (&Snatnump
);
2169 defsubr (&Ssymbolp
);
2170 defsubr (&Sstringp
);
2171 defsubr (&Svectorp
);
2173 defsubr (&Ssequencep
);
2174 defsubr (&Sbufferp
);
2175 defsubr (&Smarkerp
);
2177 defsubr (&Sbyte_code_function_p
);
2178 defsubr (&Schar_or_string_p
);
2181 defsubr (&Scar_safe
);
2182 defsubr (&Scdr_safe
);
2185 defsubr (&Ssymbol_function
);
2186 defsubr (&Sindirect_function
);
2187 defsubr (&Ssymbol_plist
);
2188 defsubr (&Ssymbol_name
);
2189 defsubr (&Smakunbound
);
2190 defsubr (&Sfmakunbound
);
2192 defsubr (&Sfboundp
);
2194 defsubr (&Sdefalias
);
2195 defsubr (&Sdefine_function
);
2196 defsubr (&Ssetplist
);
2197 defsubr (&Ssymbol_value
);
2199 defsubr (&Sdefault_boundp
);
2200 defsubr (&Sdefault_value
);
2201 defsubr (&Sset_default
);
2202 defsubr (&Ssetq_default
);
2203 defsubr (&Smake_variable_buffer_local
);
2204 defsubr (&Smake_local_variable
);
2205 defsubr (&Skill_local_variable
);
2208 defsubr (&Snumber_to_string
);
2209 defsubr (&Sstring_to_number
);
2210 defsubr (&Seqlsign
);
2239 /* USG systems forget handlers when they are used;
2240 must reestablish each time */
2241 signal (signo
, arith_error
);
2244 /* VMS systems are like USG. */
2245 signal (signo
, arith_error
);
2249 #else /* not BSD4_1 */
2250 sigsetmask (SIGEMPTYMASK
);
2251 #endif /* not BSD4_1 */
2253 Fsignal (Qarith_error
, Qnil
);
2258 /* Don't do this if just dumping out.
2259 We don't want to call `signal' in this case
2260 so that we don't have trouble with dumping
2261 signal-delivering routines in an inconsistent state. */
2265 #endif /* CANNOT_DUMP */
2266 signal (SIGFPE
, arith_error
);
2269 signal (SIGEMT
, arith_error
);