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
;
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);
524 if (NILP (sym
) || EQ (sym
, Qt
))
525 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
527 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
528 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
530 XSYMBOL (sym
)->function
= newdef
;
534 /* This name should be removed once it is eliminated from elsewhere. */
536 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
537 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
538 Associates the function with the current load file, if any.")
540 register Lisp_Object sym
, newdef
;
542 CHECK_SYMBOL (sym
, 0);
543 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
544 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
546 XSYMBOL (sym
)->function
= newdef
;
547 LOADHIST_ATTACH (sym
);
551 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
552 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
553 Associates the function with the current load file, if any.")
555 register Lisp_Object sym
, newdef
;
557 CHECK_SYMBOL (sym
, 0);
558 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
559 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
561 XSYMBOL (sym
)->function
= newdef
;
562 LOADHIST_ATTACH (sym
);
566 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
567 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
569 register Lisp_Object sym
, newplist
;
571 CHECK_SYMBOL (sym
, 0);
572 XSYMBOL (sym
)->plist
= newplist
;
577 /* Getting and setting values of symbols */
579 /* Given the raw contents of a symbol value cell,
580 return the Lisp value of the symbol.
581 This does not handle buffer-local variables; use
582 swap_in_symval_forwarding for that. */
585 do_symval_forwarding (valcontents
)
586 register Lisp_Object valcontents
;
588 register Lisp_Object val
;
589 #ifdef SWITCH_ENUM_BUG
590 switch ((int) XTYPE (valcontents
))
592 switch (XTYPE (valcontents
))
596 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
600 if (*XINTPTR (valcontents
))
605 return *XOBJFWD (valcontents
);
607 case Lisp_Buffer_Objfwd
:
608 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
613 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
614 of SYM. If SYM is buffer-local, VALCONTENTS should be the
615 buffer-independent contents of the value cell: forwarded just one
616 step past the buffer-localness. */
619 store_symval_forwarding (sym
, valcontents
, newval
)
621 register Lisp_Object valcontents
, newval
;
623 #ifdef SWITCH_ENUM_BUG
624 switch ((int) XTYPE (valcontents
))
626 switch (XTYPE (valcontents
))
630 CHECK_NUMBER (newval
, 1);
631 *XINTPTR (valcontents
) = XINT (newval
);
635 *XINTPTR (valcontents
) = NILP(newval
) ? 0 : 1;
639 *XOBJFWD (valcontents
) = newval
;
642 case Lisp_Buffer_Objfwd
:
644 unsigned int offset
= XUINT (valcontents
);
646 *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
648 if (! NILP (type
) && ! NILP (newval
)
649 && XTYPE (newval
) != XINT (type
))
650 buffer_slot_type_mismatch (valcontents
, newval
);
652 *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
)
658 valcontents
= XSYMBOL (sym
)->value
;
659 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
660 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
661 XCONS (XSYMBOL (sym
)->value
)->car
= newval
;
663 XSYMBOL (sym
)->value
= newval
;
667 /* Set up the buffer-local symbol SYM for validity in the current
668 buffer. VALCONTENTS is the contents of its value cell.
669 Return the value forwarded one step past the buffer-local indicator. */
672 swap_in_symval_forwarding (sym
, valcontents
)
673 Lisp_Object sym
, valcontents
;
675 /* valcontents is a list
676 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
678 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
679 local_var_alist, that being the element whose car is this
680 variable. Or it can be a pointer to the
681 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
682 an element in its alist for this variable.
684 If the current buffer is not BUFFER, we store the current
685 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
686 appropriate alist element for the buffer now current and set up
687 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
688 element, and store into BUFFER.
690 Note that REALVALUE can be a forwarding pointer. */
692 register Lisp_Object tem1
;
693 tem1
= XCONS (XCONS (valcontents
)->cdr
)->car
;
695 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
697 tem1
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
698 Fsetcdr (tem1
, do_symval_forwarding (XCONS (valcontents
)->car
));
699 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
701 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
702 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
703 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
, Lisp_Buffer
, current_buffer
);
704 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, Fcdr (tem1
));
706 return XCONS (valcontents
)->car
;
709 /* Find the value of a symbol, returning Qunbound if it's not bound.
710 This is helpful for code which just wants to get a variable's value
711 if it has one, without signalling an error.
712 Note that it must not be possible to quit
713 within this function. Great care is required for this. */
716 find_symbol_value (sym
)
719 register Lisp_Object valcontents
, tem1
;
720 register Lisp_Object val
;
721 CHECK_SYMBOL (sym
, 0);
722 valcontents
= XSYMBOL (sym
)->value
;
725 #ifdef SWITCH_ENUM_BUG
726 switch ((int) XTYPE (valcontents
))
728 switch (XTYPE (valcontents
))
731 case Lisp_Buffer_Local_Value
:
732 case Lisp_Some_Buffer_Local_Value
:
733 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
737 XSET (val
, Lisp_Int
, *XINTPTR (valcontents
));
741 if (*XINTPTR (valcontents
))
746 return *XOBJFWD (valcontents
);
748 case Lisp_Buffer_Objfwd
:
749 return *(Lisp_Object
*)(XUINT (valcontents
) + (char *)current_buffer
);
758 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
759 "Return SYMBOL's value. Error if that is void.")
763 Lisp_Object val
= find_symbol_value (sym
);
765 if (EQ (val
, Qunbound
))
766 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
771 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
772 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
774 register Lisp_Object sym
, newval
;
776 int voide
= (XTYPE (newval
) == Lisp_Void
|| EQ (newval
, Qunbound
));
778 #ifndef RTPC_REGISTER_BUG
779 register Lisp_Object valcontents
, tem1
, current_alist_element
;
780 #else /* RTPC_REGISTER_BUG */
781 register Lisp_Object tem1
;
782 Lisp_Object valcontents
, current_alist_element
;
783 #endif /* RTPC_REGISTER_BUG */
785 CHECK_SYMBOL (sym
, 0);
786 if (NILP (sym
) || EQ (sym
, Qt
))
787 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
788 valcontents
= XSYMBOL (sym
)->value
;
790 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
792 register int idx
= XUINT (valcontents
);
793 register int mask
= *(int *)(idx
+ (char *) &buffer_local_flags
);
795 current_buffer
->local_var_flags
|= mask
;
798 else if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
799 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
801 /* valcontents is actually a pointer to a cons heading something like:
802 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
804 BUFFER is the last buffer for which this symbol's value was
807 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
808 local_var_alist, that being the element whose car is this
809 variable. Or it can be a pointer to the
810 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
811 have an element in its alist for this variable (that is, if
812 BUFFER sees the default value of this variable).
814 If we want to examine or set the value and BUFFER is current,
815 we just examine or set REALVALUE. If BUFFER is not current, we
816 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
817 then find the appropriate alist element for the buffer now
818 current and set up CURRENT-ALIST-ELEMENT. Then we set
819 REALVALUE out of that element, and store into BUFFER.
821 If we are setting the variable and the current buffer does
822 not have an alist entry for this variable, an alist entry is
825 Note that REALVALUE can be a forwarding pointer. Each time
826 it is examined or set, forwarding must be done. */
828 /* What value are we caching right now? */
829 current_alist_element
=
830 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
832 /* If the current buffer is not the buffer whose binding is
833 currently cached, or if it's a Lisp_Buffer_Local_Value and
834 we're looking at the default value, the cache is invalid; we
835 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
837 != XBUFFER (XCONS (XCONS (valcontents
)->cdr
)->car
))
838 || (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
839 && EQ (XCONS (current_alist_element
)->car
,
840 current_alist_element
)))
842 /* Write out the cached value for the old buffer; copy it
843 back to its alist element. This works if the current
844 buffer only sees the default value, too. */
845 Fsetcdr (current_alist_element
,
846 do_symval_forwarding (XCONS (valcontents
)->car
));
848 /* Find the new value for CURRENT-ALIST-ELEMENT. */
849 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
852 /* This buffer still sees the default value. */
854 /* If the variable is a Lisp_Some_Buffer_Local_Value,
855 make CURRENT-ALIST-ELEMENT point to itself,
856 indicating that we're seeing the default value. */
857 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
858 tem1
= XCONS (XCONS (valcontents
)->cdr
)->cdr
;
860 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
861 new assoc for a local value and set
862 CURRENT-ALIST-ELEMENT to point to that. */
865 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
866 current_buffer
->local_var_alist
=
867 Fcons (tem1
, current_buffer
->local_var_alist
);
870 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
871 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
= tem1
;
873 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
874 XSET (XCONS (XCONS (valcontents
)->cdr
)->car
,
875 Lisp_Buffer
, current_buffer
);
877 valcontents
= XCONS (valcontents
)->car
;
880 /* If storing void (making the symbol void), forward only through
881 buffer-local indicator, not through Lisp_Objfwd, etc. */
883 store_symval_forwarding (sym
, Qnil
, newval
);
885 store_symval_forwarding (sym
, valcontents
, newval
);
890 /* Access or set a buffer-local symbol's default value. */
892 /* Return the default value of SYM, but don't check for voidness.
893 Return Qunbound or a Lisp_Void object if it is void. */
899 register Lisp_Object valcontents
;
901 CHECK_SYMBOL (sym
, 0);
902 valcontents
= XSYMBOL (sym
)->value
;
904 /* For a built-in buffer-local variable, get the default value
905 rather than letting do_symval_forwarding get the current value. */
906 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
908 register int idx
= XUINT (valcontents
);
910 if (*(int *) (idx
+ (char *) &buffer_local_flags
) != 0)
911 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
914 /* Handle user-created local variables. */
915 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
916 || XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
918 /* If var is set up for a buffer that lacks a local value for it,
919 the current value is nominally the default value.
920 But the current value slot may be more up to date, since
921 ordinary setq stores just that slot. So use that. */
922 Lisp_Object current_alist_element
, alist_element_car
;
923 current_alist_element
924 = XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
925 alist_element_car
= XCONS (current_alist_element
)->car
;
926 if (EQ (alist_element_car
, current_alist_element
))
927 return do_symval_forwarding (XCONS (valcontents
)->car
);
929 return XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
;
931 /* For other variables, get the current value. */
932 return do_symval_forwarding (valcontents
);
935 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
936 "Return T if SYMBOL has a non-void default value.\n\
937 This is the value that is seen in buffers that do not have their own values\n\
942 register Lisp_Object value
;
944 value
= default_value (sym
);
945 return (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
)
949 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
950 "Return SYMBOL's default value.\n\
951 This is the value that is seen in buffers that do not have their own values\n\
952 for this variable. The default value is meaningful for variables with\n\
953 local bindings in certain buffers.")
957 register Lisp_Object value
;
959 value
= default_value (sym
);
960 if (XTYPE (value
) == Lisp_Void
|| EQ (value
, Qunbound
))
961 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
965 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
966 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
967 The default value is seen in buffers that do not have their own values\n\
970 Lisp_Object sym
, value
;
972 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
974 CHECK_SYMBOL (sym
, 0);
975 valcontents
= XSYMBOL (sym
)->value
;
977 /* Handle variables like case-fold-search that have special slots
978 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
980 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
982 register int idx
= XUINT (valcontents
);
983 #ifndef RTPC_REGISTER_BUG
984 register struct buffer
*b
;
988 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
992 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
993 for (b
= all_buffers
; b
; b
= b
->next
)
994 if (!(b
->local_var_flags
& mask
))
995 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1000 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1001 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1002 return Fset (sym
, value
);
1004 /* Store new value into the DEFAULT-VALUE slot */
1005 XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1007 /* If that slot is current, we must set the REALVALUE slot too */
1008 current_alist_element
= XCONS (XCONS (XCONS (valcontents
)->cdr
)->cdr
)->car
;
1009 alist_element_buffer
= Fcar (current_alist_element
);
1010 if (EQ (alist_element_buffer
, current_alist_element
))
1011 store_symval_forwarding (sym
, XCONS (valcontents
)->car
, value
);
1016 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1018 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
1019 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
1020 not have their own values for this variable.")
1024 register Lisp_Object args_left
;
1025 register Lisp_Object val
, sym
;
1026 struct gcpro gcpro1
;
1036 val
= Feval (Fcar (Fcdr (args_left
)));
1037 sym
= Fcar (args_left
);
1038 Fset_default (sym
, val
);
1039 args_left
= Fcdr (Fcdr (args_left
));
1041 while (!NILP (args_left
));
1047 /* Lisp functions for creating and removing buffer-local variables. */
1049 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1050 1, 1, "vMake Variable Buffer Local: ",
1051 "Make VARIABLE have a separate value for each buffer.\n\
1052 At any time, the value for the current buffer is in effect.\n\
1053 There is also a default value which is seen in any buffer which has not yet\n\
1054 set its own value.\n\
1055 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1056 for the current buffer if it was previously using the default value.\n\
1057 The function `default-value' gets the default value and `set-default' sets it.")
1059 register Lisp_Object sym
;
1061 register Lisp_Object tem
, valcontents
;
1063 CHECK_SYMBOL (sym
, 0);
1065 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1066 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1068 valcontents
= XSYMBOL (sym
)->value
;
1069 if ((XTYPE (valcontents
) == Lisp_Buffer_Local_Value
) ||
1070 (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
))
1072 if (XTYPE (valcontents
) == Lisp_Some_Buffer_Local_Value
)
1074 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1077 if (EQ (valcontents
, Qunbound
))
1078 XSYMBOL (sym
)->value
= Qnil
;
1079 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1080 XCONS (tem
)->car
= tem
;
1081 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Fcurrent_buffer (), tem
));
1082 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Buffer_Local_Value
);
1086 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1087 1, 1, "vMake Local Variable: ",
1088 "Make VARIABLE have a separate value in the current buffer.\n\
1089 Other buffers will continue to share a common default value.\n\
1090 See also `make-variable-buffer-local'.\n\n\
1091 If the variable is already arranged to become local when set,\n\
1092 this function causes a local value to exist for this buffer,\n\
1093 just as if the variable were set.")
1095 register Lisp_Object sym
;
1097 register Lisp_Object tem
, valcontents
;
1099 CHECK_SYMBOL (sym
, 0);
1101 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
))
1102 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1104 valcontents
= XSYMBOL (sym
)->value
;
1105 if (XTYPE (valcontents
) == Lisp_Buffer_Local_Value
1106 || XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1108 tem
= Fboundp (sym
);
1110 /* Make sure the symbol has a local value in this particular buffer,
1111 by setting it to the same value it already has. */
1112 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1115 /* Make sure sym is set up to hold per-buffer values */
1116 if (XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1118 if (EQ (valcontents
, Qunbound
))
1119 XSYMBOL (sym
)->value
= Qnil
;
1120 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1121 XCONS (tem
)->car
= tem
;
1122 XSYMBOL (sym
)->value
= Fcons (XSYMBOL (sym
)->value
, Fcons (Qnil
, tem
));
1123 XSETTYPE (XSYMBOL (sym
)->value
, Lisp_Some_Buffer_Local_Value
);
1125 /* Make sure this buffer has its own value of sym */
1126 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1129 current_buffer
->local_var_alist
1130 = Fcons (Fcons (sym
, XCONS (XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1131 current_buffer
->local_var_alist
);
1133 /* Make sure symbol does not think it is set up for this buffer;
1134 force it to look once again for this buffer's value */
1136 /* This local variable avoids "expression too complex" on IBM RT. */
1139 xs
= XSYMBOL (sym
)->value
;
1140 if (current_buffer
== XBUFFER (XCONS (XCONS (xs
)->cdr
)->car
))
1141 XCONS (XCONS (XSYMBOL (sym
)->value
)->cdr
)->car
= Qnil
;
1145 /* If the symbol forwards into a C variable, then swap in the
1146 variable for this buffer immediately. If C code modifies the
1147 variable before we swap in, then that new value will clobber the
1148 default value the next time we swap. */
1149 valcontents
= XCONS (XSYMBOL (sym
)->value
)->car
;
1150 if (XTYPE (valcontents
) == Lisp_Intfwd
1151 || XTYPE (valcontents
) == Lisp_Boolfwd
1152 || XTYPE (valcontents
) == Lisp_Objfwd
)
1153 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1158 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1159 1, 1, "vKill Local Variable: ",
1160 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1161 From now on the default value will apply in this buffer.")
1163 register Lisp_Object sym
;
1165 register Lisp_Object tem
, valcontents
;
1167 CHECK_SYMBOL (sym
, 0);
1169 valcontents
= XSYMBOL (sym
)->value
;
1171 if (XTYPE (valcontents
) == Lisp_Buffer_Objfwd
)
1173 register int idx
= XUINT (valcontents
);
1174 register int mask
= *(int *) (idx
+ (char *) &buffer_local_flags
);
1178 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1179 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1180 current_buffer
->local_var_flags
&= ~mask
;
1185 if (XTYPE (valcontents
) != Lisp_Buffer_Local_Value
&&
1186 XTYPE (valcontents
) != Lisp_Some_Buffer_Local_Value
)
1189 /* Get rid of this buffer's alist element, if any */
1191 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1193 current_buffer
->local_var_alist
= Fdelq (tem
, current_buffer
->local_var_alist
);
1195 /* Make sure symbol does not think it is set up for this buffer;
1196 force it to look once again for this buffer's value */
1199 sv
= XSYMBOL (sym
)->value
;
1200 if (current_buffer
== XBUFFER (XCONS (XCONS (sv
)->cdr
)->car
))
1201 XCONS (XCONS (sv
)->cdr
)->car
= Qnil
;
1207 /* Find the function at the end of a chain of symbol function indirections. */
1209 /* If OBJECT is a symbol, find the end of its function chain and
1210 return the value found there. If OBJECT is not a symbol, just
1211 return it. If there is a cycle in the function chain, signal a
1212 cyclic-function-indirection error.
1214 This is like Findirect_function, except that it doesn't signal an
1215 error if the chain ends up unbound. */
1217 indirect_function (object
)
1218 register Lisp_Object object
;
1220 Lisp_Object tortise
, hare
;
1222 hare
= tortise
= object
;
1226 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1228 hare
= XSYMBOL (hare
)->function
;
1229 if (XTYPE (hare
) != Lisp_Symbol
|| EQ (hare
, Qunbound
))
1231 hare
= XSYMBOL (hare
)->function
;
1233 tortise
= XSYMBOL (tortise
)->function
;
1235 if (EQ (hare
, tortise
))
1236 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1242 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1243 "Return the function at the end of OBJECT's function chain.\n\
1244 If OBJECT is a symbol, follow all function indirections and return the final\n\
1245 function binding.\n\
1246 If OBJECT is not a symbol, just return it.\n\
1247 Signal a void-function error if the final symbol is unbound.\n\
1248 Signal a cyclic-function-indirection error if there is a loop in the\n\
1249 function chain of symbols.")
1251 register Lisp_Object object
;
1255 result
= indirect_function (object
);
1257 if (EQ (result
, Qunbound
))
1258 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1262 /* Extract and set vector and string elements */
1264 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1265 "Return the element of ARRAY at index INDEX.\n\
1266 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1268 register Lisp_Object array
;
1271 register int idxval
;
1273 CHECK_NUMBER (idx
, 1);
1274 idxval
= XINT (idx
);
1275 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1276 && XTYPE (array
) != Lisp_Compiled
)
1277 array
= wrong_type_argument (Qarrayp
, array
);
1278 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1279 args_out_of_range (array
, idx
);
1280 if (XTYPE (array
) == Lisp_String
)
1283 XFASTINT (val
) = (unsigned char) XSTRING (array
)->data
[idxval
];
1287 return XVECTOR (array
)->contents
[idxval
];
1290 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1291 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1292 ARRAY may be a vector or a string. INDEX starts at 0.")
1293 (array
, idx
, newelt
)
1294 register Lisp_Object array
;
1295 Lisp_Object idx
, newelt
;
1297 register int idxval
;
1299 CHECK_NUMBER (idx
, 1);
1300 idxval
= XINT (idx
);
1301 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
)
1302 array
= wrong_type_argument (Qarrayp
, array
);
1303 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1304 args_out_of_range (array
, idx
);
1305 CHECK_IMPURE (array
);
1307 if (XTYPE (array
) == Lisp_Vector
)
1308 XVECTOR (array
)->contents
[idxval
] = newelt
;
1311 CHECK_NUMBER (newelt
, 2);
1312 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1319 Farray_length (array
)
1320 register Lisp_Object array
;
1322 register Lisp_Object size
;
1323 if (XTYPE (array
) != Lisp_Vector
&& XTYPE (array
) != Lisp_String
1324 && XTYPE (array
) != Lisp_Compiled
)
1325 array
= wrong_type_argument (Qarrayp
, array
);
1326 XFASTINT (size
) = XVECTOR (array
)->size
;
1330 /* Arithmetic functions */
1332 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1335 arithcompare (num1
, num2
, comparison
)
1336 Lisp_Object num1
, num2
;
1337 enum comparison comparison
;
1342 #ifdef LISP_FLOAT_TYPE
1343 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1344 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1346 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1349 f1
= (XTYPE (num1
) == Lisp_Float
) ? XFLOAT (num1
)->data
: XINT (num1
);
1350 f2
= (XTYPE (num2
) == Lisp_Float
) ? XFLOAT (num2
)->data
: XINT (num2
);
1353 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1354 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1355 #endif /* LISP_FLOAT_TYPE */
1360 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1365 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1370 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1375 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1380 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1385 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1394 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1395 "T if two args, both numbers or markers, are equal.")
1397 register Lisp_Object num1
, num2
;
1399 return arithcompare (num1
, num2
, equal
);
1402 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1403 "T if first arg is less than second arg. Both must be numbers or markers.")
1405 register Lisp_Object num1
, num2
;
1407 return arithcompare (num1
, num2
, less
);
1410 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1411 "T if first arg is greater than second arg. Both must be numbers or markers.")
1413 register Lisp_Object num1
, num2
;
1415 return arithcompare (num1
, num2
, grtr
);
1418 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1419 "T if first arg is less than or equal to second arg.\n\
1420 Both must be numbers or markers.")
1422 register Lisp_Object num1
, num2
;
1424 return arithcompare (num1
, num2
, less_or_equal
);
1427 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1428 "T if first arg is greater than or equal to second arg.\n\
1429 Both must be numbers or markers.")
1431 register Lisp_Object num1
, num2
;
1433 return arithcompare (num1
, num2
, grtr_or_equal
);
1436 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1437 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1439 register Lisp_Object num1
, num2
;
1441 return arithcompare (num1
, num2
, notequal
);
1444 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1446 register Lisp_Object num
;
1448 #ifdef LISP_FLOAT_TYPE
1449 CHECK_NUMBER_OR_FLOAT (num
, 0);
1451 if (XTYPE(num
) == Lisp_Float
)
1453 if (XFLOAT(num
)->data
== 0.0)
1458 CHECK_NUMBER (num
, 0);
1459 #endif /* LISP_FLOAT_TYPE */
1466 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1472 unsigned int top
= i
>> 16;
1473 unsigned int bot
= i
& 0xFFFF;
1475 return make_number (bot
);
1477 return Fcons (make_number (-1), make_number (bot
));
1478 return Fcons (make_number (top
), make_number (bot
));
1488 top
= XCONS (c
)->car
;
1489 bot
= XCONS (c
)->cdr
;
1491 bot
= XCONS (bot
)->car
;
1492 return ((XINT (top
) << 16) | XINT (bot
));
1495 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1496 "Convert NUM to a string by printing it in decimal.\n\
1497 Uses a minus sign if negative.\n\
1498 NUM may be an integer or a floating point number.")
1504 #ifndef LISP_FLOAT_TYPE
1505 CHECK_NUMBER (num
, 0);
1507 CHECK_NUMBER_OR_FLOAT (num
, 0);
1509 if (XTYPE(num
) == Lisp_Float
)
1511 char pigbuf
[350]; /* see comments in float_to_string */
1513 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1514 return build_string (pigbuf
);
1516 #endif /* LISP_FLOAT_TYPE */
1518 sprintf (buffer
, "%d", XINT (num
));
1519 return build_string (buffer
);
1522 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1523 "Convert STRING to a number by parsing it as a decimal number.\n\
1524 This parses both integers and floating point numbers.")
1526 register Lisp_Object str
;
1530 CHECK_STRING (str
, 0);
1532 p
= XSTRING (str
)->data
;
1534 /* Skip any whitespace at the front of the number. Some versions of
1535 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1536 while (*p
== ' ' || *p
== '\t')
1539 #ifdef LISP_FLOAT_TYPE
1540 if (isfloat_string (p
))
1541 return make_float (atof (p
));
1542 #endif /* LISP_FLOAT_TYPE */
1544 return make_number (atoi (p
));
1548 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1550 extern Lisp_Object
float_arith_driver ();
1553 arith_driver (code
, nargs
, args
)
1556 register Lisp_Object
*args
;
1558 register Lisp_Object val
;
1559 register int argnum
;
1563 #ifdef SWITCH_ENUM_BUG
1580 for (argnum
= 0; argnum
< nargs
; argnum
++)
1582 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1583 #ifdef LISP_FLOAT_TYPE
1584 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1586 if (XTYPE (val
) == Lisp_Float
) /* time to do serious math */
1587 return (float_arith_driver ((double) accum
, argnum
, code
,
1590 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1591 #endif /* LISP_FLOAT_TYPE */
1592 args
[argnum
] = val
; /* runs into a compiler bug. */
1593 next
= XINT (args
[argnum
]);
1594 #ifdef SWITCH_ENUM_BUG
1600 case Aadd
: accum
+= next
; break;
1602 if (!argnum
&& nargs
!= 1)
1606 case Amult
: accum
*= next
; break;
1608 if (!argnum
) accum
= next
;
1612 Fsignal (Qarith_error
, Qnil
);
1616 case Alogand
: accum
&= next
; break;
1617 case Alogior
: accum
|= next
; break;
1618 case Alogxor
: accum
^= next
; break;
1619 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1620 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1624 XSET (val
, Lisp_Int
, accum
);
1628 #ifdef LISP_FLOAT_TYPE
1630 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1632 register int argnum
;
1635 register Lisp_Object
*args
;
1637 register Lisp_Object val
;
1640 for (; argnum
< nargs
; argnum
++)
1642 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1643 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1645 if (XTYPE (val
) == Lisp_Float
)
1647 next
= XFLOAT (val
)->data
;
1651 args
[argnum
] = val
; /* runs into a compiler bug. */
1652 next
= XINT (args
[argnum
]);
1654 #ifdef SWITCH_ENUM_BUG
1664 if (!argnum
&& nargs
!= 1)
1677 Fsignal (Qarith_error
, Qnil
);
1684 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1686 if (!argnum
|| next
> accum
)
1690 if (!argnum
|| next
< accum
)
1696 return make_float (accum
);
1698 #endif /* LISP_FLOAT_TYPE */
1700 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1701 "Return sum of any number of arguments, which are numbers or markers.")
1706 return arith_driver (Aadd
, nargs
, args
);
1709 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1710 "Negate number or subtract numbers or markers.\n\
1711 With one arg, negates it. With more than one arg,\n\
1712 subtracts all but the first from the first.")
1717 return arith_driver (Asub
, nargs
, args
);
1720 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1721 "Returns product of any number of arguments, which are numbers or markers.")
1726 return arith_driver (Amult
, nargs
, args
);
1729 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1730 "Returns first argument divided by all the remaining arguments.\n\
1731 The arguments must be numbers or markers.")
1736 return arith_driver (Adiv
, nargs
, args
);
1739 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1740 "Returns remainder of first arg divided by second.\n\
1741 Both must be numbers or markers.")
1743 register Lisp_Object num1
, num2
;
1747 #ifdef LISP_FLOAT_TYPE
1748 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1749 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1751 if (XTYPE (num1
) == Lisp_Float
|| XTYPE (num2
) == Lisp_Float
)
1755 f1
= XTYPE (num1
) == Lisp_Float
? XFLOAT (num1
)->data
: XINT (num1
);
1756 f2
= XTYPE (num2
) == Lisp_Float
? XFLOAT (num2
)->data
: XINT (num2
);
1758 Fsignal (Qarith_error
, Qnil
);
1760 #if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux)
1765 /* If the "remainder" comes out with the wrong sign, fix it. */
1766 if ((f1
< 0) != (f2
< 0))
1768 return (make_float (f1
));
1770 #else /* not LISP_FLOAT_TYPE */
1771 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1772 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1773 #endif /* not LISP_FLOAT_TYPE */
1775 if (XFASTINT (num2
) == 0)
1776 Fsignal (Qarith_error
, Qnil
);
1778 XSET (val
, Lisp_Int
, XINT (num1
) % XINT (num2
));
1782 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
1783 "Return largest of all the arguments (which must be numbers or markers).\n\
1784 The value is always a number; markers are converted to numbers.")
1789 return arith_driver (Amax
, nargs
, args
);
1792 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
1793 "Return smallest of all the arguments (which must be numbers or markers).\n\
1794 The value is always a number; markers are converted to numbers.")
1799 return arith_driver (Amin
, nargs
, args
);
1802 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
1803 "Return bitwise-and of all the arguments.\n\
1804 Arguments may be integers, or markers converted to integers.")
1809 return arith_driver (Alogand
, nargs
, args
);
1812 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
1813 "Return bitwise-or of all the arguments.\n\
1814 Arguments may be integers, or markers converted to integers.")
1819 return arith_driver (Alogior
, nargs
, args
);
1822 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
1823 "Return bitwise-exclusive-or of all the arguments.\n\
1824 Arguments may be integers, or markers converted to integers.")
1829 return arith_driver (Alogxor
, nargs
, args
);
1832 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
1833 "Return VALUE with its bits shifted left by COUNT.\n\
1834 If COUNT is negative, shifting is actually to the right.\n\
1835 In this case, the sign bit is duplicated.")
1837 register Lisp_Object num1
, num2
;
1839 register Lisp_Object val
;
1841 CHECK_NUMBER (num1
, 0);
1842 CHECK_NUMBER (num2
, 1);
1844 if (XINT (num2
) > 0)
1845 XSET (val
, Lisp_Int
, XINT (num1
) << XFASTINT (num2
));
1847 XSET (val
, Lisp_Int
, XINT (num1
) >> -XINT (num2
));
1851 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
1852 "Return VALUE with its bits shifted left by COUNT.\n\
1853 If COUNT is negative, shifting is actually to the right.\n\
1854 In this case, zeros are shifted in on the left.")
1856 register Lisp_Object num1
, num2
;
1858 register Lisp_Object val
;
1860 CHECK_NUMBER (num1
, 0);
1861 CHECK_NUMBER (num2
, 1);
1863 if (XINT (num2
) > 0)
1864 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) << XFASTINT (num2
));
1866 XSET (val
, Lisp_Int
, (unsigned) XFASTINT (num1
) >> -XINT (num2
));
1870 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
1871 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1872 Markers are converted to integers.")
1874 register Lisp_Object num
;
1876 #ifdef LISP_FLOAT_TYPE
1877 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1879 if (XTYPE (num
) == Lisp_Float
)
1880 return (make_float (1.0 + XFLOAT (num
)->data
));
1882 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1883 #endif /* LISP_FLOAT_TYPE */
1885 XSETINT (num
, XFASTINT (num
) + 1);
1889 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
1890 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1891 Markers are converted to integers.")
1893 register Lisp_Object num
;
1895 #ifdef LISP_FLOAT_TYPE
1896 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
1898 if (XTYPE (num
) == Lisp_Float
)
1899 return (make_float (-1.0 + XFLOAT (num
)->data
));
1901 CHECK_NUMBER_COERCE_MARKER (num
, 0);
1902 #endif /* LISP_FLOAT_TYPE */
1904 XSETINT (num
, XFASTINT (num
) - 1);
1908 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
1909 "Return the bitwise complement of ARG. ARG must be an integer.")
1911 register Lisp_Object num
;
1913 CHECK_NUMBER (num
, 0);
1914 XSETINT (num
, ~XFASTINT (num
));
1921 Lisp_Object error_tail
, arith_tail
;
1923 Qquote
= intern ("quote");
1924 Qlambda
= intern ("lambda");
1925 Qsubr
= intern ("subr");
1926 Qerror_conditions
= intern ("error-conditions");
1927 Qerror_message
= intern ("error-message");
1928 Qtop_level
= intern ("top-level");
1930 Qerror
= intern ("error");
1931 Qquit
= intern ("quit");
1932 Qwrong_type_argument
= intern ("wrong-type-argument");
1933 Qargs_out_of_range
= intern ("args-out-of-range");
1934 Qvoid_function
= intern ("void-function");
1935 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
1936 Qvoid_variable
= intern ("void-variable");
1937 Qsetting_constant
= intern ("setting-constant");
1938 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
1940 Qinvalid_function
= intern ("invalid-function");
1941 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
1942 Qno_catch
= intern ("no-catch");
1943 Qend_of_file
= intern ("end-of-file");
1944 Qarith_error
= intern ("arith-error");
1945 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
1946 Qend_of_buffer
= intern ("end-of-buffer");
1947 Qbuffer_read_only
= intern ("buffer-read-only");
1949 Qlistp
= intern ("listp");
1950 Qconsp
= intern ("consp");
1951 Qsymbolp
= intern ("symbolp");
1952 Qintegerp
= intern ("integerp");
1953 Qnatnump
= intern ("natnump");
1954 Qstringp
= intern ("stringp");
1955 Qarrayp
= intern ("arrayp");
1956 Qsequencep
= intern ("sequencep");
1957 Qbufferp
= intern ("bufferp");
1958 Qvectorp
= intern ("vectorp");
1959 Qchar_or_string_p
= intern ("char-or-string-p");
1960 Qmarkerp
= intern ("markerp");
1961 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
1962 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
1963 Qboundp
= intern ("boundp");
1964 Qfboundp
= intern ("fboundp");
1966 #ifdef LISP_FLOAT_TYPE
1967 Qfloatp
= intern ("floatp");
1968 Qnumberp
= intern ("numberp");
1969 Qnumber_or_marker_p
= intern ("number-or-marker-p");
1970 #endif /* LISP_FLOAT_TYPE */
1972 Qcdr
= intern ("cdr");
1974 error_tail
= Fcons (Qerror
, Qnil
);
1976 /* ERROR is used as a signaler for random errors for which nothing else is right */
1978 Fput (Qerror
, Qerror_conditions
,
1980 Fput (Qerror
, Qerror_message
,
1981 build_string ("error"));
1983 Fput (Qquit
, Qerror_conditions
,
1984 Fcons (Qquit
, Qnil
));
1985 Fput (Qquit
, Qerror_message
,
1986 build_string ("Quit"));
1988 Fput (Qwrong_type_argument
, Qerror_conditions
,
1989 Fcons (Qwrong_type_argument
, error_tail
));
1990 Fput (Qwrong_type_argument
, Qerror_message
,
1991 build_string ("Wrong type argument"));
1993 Fput (Qargs_out_of_range
, Qerror_conditions
,
1994 Fcons (Qargs_out_of_range
, error_tail
));
1995 Fput (Qargs_out_of_range
, Qerror_message
,
1996 build_string ("Args out of range"));
1998 Fput (Qvoid_function
, Qerror_conditions
,
1999 Fcons (Qvoid_function
, error_tail
));
2000 Fput (Qvoid_function
, Qerror_message
,
2001 build_string ("Symbol's function definition is void"));
2003 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2004 Fcons (Qcyclic_function_indirection
, error_tail
));
2005 Fput (Qcyclic_function_indirection
, Qerror_message
,
2006 build_string ("Symbol's chain of function indirections contains a loop"));
2008 Fput (Qvoid_variable
, Qerror_conditions
,
2009 Fcons (Qvoid_variable
, error_tail
));
2010 Fput (Qvoid_variable
, Qerror_message
,
2011 build_string ("Symbol's value as variable is void"));
2013 Fput (Qsetting_constant
, Qerror_conditions
,
2014 Fcons (Qsetting_constant
, error_tail
));
2015 Fput (Qsetting_constant
, Qerror_message
,
2016 build_string ("Attempt to set a constant symbol"));
2018 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2019 Fcons (Qinvalid_read_syntax
, error_tail
));
2020 Fput (Qinvalid_read_syntax
, Qerror_message
,
2021 build_string ("Invalid read syntax"));
2023 Fput (Qinvalid_function
, Qerror_conditions
,
2024 Fcons (Qinvalid_function
, error_tail
));
2025 Fput (Qinvalid_function
, Qerror_message
,
2026 build_string ("Invalid function"));
2028 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2029 Fcons (Qwrong_number_of_arguments
, error_tail
));
2030 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2031 build_string ("Wrong number of arguments"));
2033 Fput (Qno_catch
, Qerror_conditions
,
2034 Fcons (Qno_catch
, error_tail
));
2035 Fput (Qno_catch
, Qerror_message
,
2036 build_string ("No catch for tag"));
2038 Fput (Qend_of_file
, Qerror_conditions
,
2039 Fcons (Qend_of_file
, error_tail
));
2040 Fput (Qend_of_file
, Qerror_message
,
2041 build_string ("End of file during parsing"));
2043 arith_tail
= Fcons (Qarith_error
, error_tail
);
2044 Fput (Qarith_error
, Qerror_conditions
,
2046 Fput (Qarith_error
, Qerror_message
,
2047 build_string ("Arithmetic error"));
2049 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2050 Fcons (Qbeginning_of_buffer
, error_tail
));
2051 Fput (Qbeginning_of_buffer
, Qerror_message
,
2052 build_string ("Beginning of buffer"));
2054 Fput (Qend_of_buffer
, Qerror_conditions
,
2055 Fcons (Qend_of_buffer
, error_tail
));
2056 Fput (Qend_of_buffer
, Qerror_message
,
2057 build_string ("End of buffer"));
2059 Fput (Qbuffer_read_only
, Qerror_conditions
,
2060 Fcons (Qbuffer_read_only
, error_tail
));
2061 Fput (Qbuffer_read_only
, Qerror_message
,
2062 build_string ("Buffer is read-only"));
2064 #ifdef LISP_FLOAT_TYPE
2065 Qrange_error
= intern ("range-error");
2066 Qdomain_error
= intern ("domain-error");
2067 Qsingularity_error
= intern ("singularity-error");
2068 Qoverflow_error
= intern ("overflow-error");
2069 Qunderflow_error
= intern ("underflow-error");
2071 Fput (Qdomain_error
, Qerror_conditions
,
2072 Fcons (Qdomain_error
, arith_tail
));
2073 Fput (Qdomain_error
, Qerror_message
,
2074 build_string ("Arithmetic domain error"));
2076 Fput (Qrange_error
, Qerror_conditions
,
2077 Fcons (Qrange_error
, arith_tail
));
2078 Fput (Qrange_error
, Qerror_message
,
2079 build_string ("Arithmetic range error"));
2081 Fput (Qsingularity_error
, Qerror_conditions
,
2082 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2083 Fput (Qsingularity_error
, Qerror_message
,
2084 build_string ("Arithmetic singularity error"));
2086 Fput (Qoverflow_error
, Qerror_conditions
,
2087 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2088 Fput (Qoverflow_error
, Qerror_message
,
2089 build_string ("Arithmetic overflow error"));
2091 Fput (Qunderflow_error
, Qerror_conditions
,
2092 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2093 Fput (Qunderflow_error
, Qerror_message
,
2094 build_string ("Arithmetic underflow error"));
2096 staticpro (&Qrange_error
);
2097 staticpro (&Qdomain_error
);
2098 staticpro (&Qsingularity_error
);
2099 staticpro (&Qoverflow_error
);
2100 staticpro (&Qunderflow_error
);
2101 #endif /* LISP_FLOAT_TYPE */
2105 staticpro (&Qquote
);
2106 staticpro (&Qlambda
);
2108 staticpro (&Qunbound
);
2109 staticpro (&Qerror_conditions
);
2110 staticpro (&Qerror_message
);
2111 staticpro (&Qtop_level
);
2113 staticpro (&Qerror
);
2115 staticpro (&Qwrong_type_argument
);
2116 staticpro (&Qargs_out_of_range
);
2117 staticpro (&Qvoid_function
);
2118 staticpro (&Qcyclic_function_indirection
);
2119 staticpro (&Qvoid_variable
);
2120 staticpro (&Qsetting_constant
);
2121 staticpro (&Qinvalid_read_syntax
);
2122 staticpro (&Qwrong_number_of_arguments
);
2123 staticpro (&Qinvalid_function
);
2124 staticpro (&Qno_catch
);
2125 staticpro (&Qend_of_file
);
2126 staticpro (&Qarith_error
);
2127 staticpro (&Qbeginning_of_buffer
);
2128 staticpro (&Qend_of_buffer
);
2129 staticpro (&Qbuffer_read_only
);
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
);