1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 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 2, 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. */
32 #include "syssignal.h"
35 /* These are redefined (correctly, but differently) in values.h. */
41 #ifdef LISP_FLOAT_TYPE
47 /* Work around a problem that happens because math.h on hpux 7
48 defines two static variables--which, in Emacs, are not really static,
49 because `static' is defined as nothing. The problem is that they are
50 here, in floatfns.c, and in lread.c.
51 These macros prevent the name conflict. */
52 #if defined (HPUX) && !defined (HPUX8)
53 #define _MAXLDBL data_c_maxldbl
54 #define _NMAXLDBL data_c_nmaxldbl
58 #endif /* LISP_FLOAT_TYPE */
61 extern double atof ();
64 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
65 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
66 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
67 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
68 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
69 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
70 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
71 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
72 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
73 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
74 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
75 Lisp_Object Qbuffer_or_string_p
;
76 Lisp_Object Qboundp
, Qfboundp
;
79 Lisp_Object Qad_advice_info
, Qad_activate
;
81 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
82 Lisp_Object Qoverflow_error
, Qunderflow_error
;
84 #ifdef LISP_FLOAT_TYPE
86 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
89 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
90 static Lisp_Object Qfloat
, Qwindow_configuration
, Qprocess
, Qwindow
;
91 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
93 static Lisp_Object
swap_in_symval_forwarding ();
96 wrong_type_argument (predicate
, value
)
97 register Lisp_Object predicate
, value
;
99 register Lisp_Object tem
;
102 if (!EQ (Vmocklisp_arguments
, Qt
))
104 if (STRINGP (value
) &&
105 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
106 return Fstring_to_number (value
);
107 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
108 return Fnumber_to_string (value
);
111 /* If VALUE is not even a valid Lisp object, abort here
112 where we can get a backtrace showing where it came from. */
113 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
116 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
117 tem
= call1 (predicate
, value
);
125 error ("Attempt to modify read-only object");
129 args_out_of_range (a1
, a2
)
133 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
137 args_out_of_range_3 (a1
, a2
, a3
)
138 Lisp_Object a1
, a2
, a3
;
141 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
148 register Lisp_Object val
;
153 /* On some machines, XINT needs a temporary location.
154 Here it is, in case it is needed. */
156 int sign_extend_temp
;
158 /* On a few machines, XINT can only be done by calling this. */
161 sign_extend_lisp_int (num
)
164 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
165 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
167 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
170 /* Data type predicates */
172 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
173 "T if the two args are the same Lisp object.")
175 Lisp_Object obj1
, obj2
;
182 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "T if OBJECT is nil.")
191 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
192 "Return a symbol representing the type of OBJECT.\n\
193 The symbol returned names the object's basic type;\n\
194 for example, (type-of 1) returns `integer'.")
198 switch (XGCTYPE (object
))
213 switch (XMISCTYPE (object
))
215 case Lisp_Misc_Marker
:
217 case Lisp_Misc_Overlay
:
219 case Lisp_Misc_Float
:
224 case Lisp_Vectorlike
:
225 if (GC_WINDOW_CONFIGURATIONP (object
))
226 return Qwindow_configuration
;
227 if (GC_PROCESSP (object
))
229 if (GC_WINDOWP (object
))
231 if (GC_SUBRP (object
))
233 if (GC_COMPILEDP (object
))
234 return Qcompiled_function
;
235 if (GC_BUFFERP (object
))
239 if (GC_FRAMEP (object
))
244 #ifdef LISP_FLOAT_TYPE
254 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "T if OBJECT is a cons cell.")
263 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
272 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
276 if (CONSP (object
) || NILP (object
))
281 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
285 if (CONSP (object
) || NILP (object
))
290 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0, "T if OBJECT is a symbol.")
294 if (SYMBOLP (object
))
299 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0, "T if OBJECT is a vector.")
303 if (VECTORP (object
))
308 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0, "T if OBJECT is a string.")
312 if (STRINGP (object
))
317 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "T if OBJECT is an array (string or vector).")
321 if (VECTORP (object
) || STRINGP (object
))
326 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
327 "T if OBJECT is a sequence (list or array).")
329 register Lisp_Object object
;
331 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
))
336 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "T if OBJECT is an editor buffer.")
340 if (BUFFERP (object
))
345 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
349 if (MARKERP (object
))
354 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "T if OBJECT is a built-in function.")
363 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
364 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
368 if (COMPILEDP (object
))
373 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
374 "T if OBJECT is a character (an integer) or a string.")
376 register Lisp_Object object
;
378 if (INTEGERP (object
) || STRINGP (object
))
383 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "T if OBJECT is an integer.")
387 if (INTEGERP (object
))
392 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
393 "T if OBJECT is an integer or a marker (editor pointer).")
395 register Lisp_Object object
;
397 if (MARKERP (object
) || INTEGERP (object
))
402 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
403 "T if OBJECT is a nonnegative integer.")
407 if (NATNUMP (object
))
412 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
413 "T if OBJECT is a number (floating point or integer).")
417 if (NUMBERP (object
))
423 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
424 Snumber_or_marker_p
, 1, 1, 0,
425 "T if OBJECT is a number or a marker.")
429 if (NUMBERP (object
) || MARKERP (object
))
434 #ifdef LISP_FLOAT_TYPE
435 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
436 "T if OBJECT is a floating point number.")
444 #endif /* LISP_FLOAT_TYPE */
446 /* Extract and set components of lists */
448 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
449 "Return the car of LIST. If arg is nil, return nil.\n\
450 Error if arg is not nil and not a cons cell. See also `car-safe'.")
452 register Lisp_Object list
;
457 return XCONS (list
)->car
;
458 else if (EQ (list
, Qnil
))
461 list
= wrong_type_argument (Qlistp
, list
);
465 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
466 "Return the car of OBJECT if it is a cons cell, or else nil.")
471 return XCONS (object
)->car
;
476 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
477 "Return the cdr of LIST. If arg is nil, return nil.\n\
478 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
481 register Lisp_Object list
;
486 return XCONS (list
)->cdr
;
487 else if (EQ (list
, Qnil
))
490 list
= wrong_type_argument (Qlistp
, list
);
494 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
495 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
500 return XCONS (object
)->cdr
;
505 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
506 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
508 register Lisp_Object cell
, newcar
;
511 cell
= wrong_type_argument (Qconsp
, cell
);
514 XCONS (cell
)->car
= newcar
;
518 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
519 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
521 register Lisp_Object cell
, newcdr
;
524 cell
= wrong_type_argument (Qconsp
, cell
);
527 XCONS (cell
)->cdr
= newcdr
;
531 /* Extract and set components of symbols */
533 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "T if SYMBOL's value is not void.")
535 register Lisp_Object sym
;
537 Lisp_Object valcontents
;
538 CHECK_SYMBOL (sym
, 0);
540 valcontents
= XSYMBOL (sym
)->value
;
542 if (BUFFER_LOCAL_VALUEP (valcontents
)
543 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
544 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
546 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
549 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "T if SYMBOL's function definition is not void.")
551 register Lisp_Object sym
;
553 CHECK_SYMBOL (sym
, 0);
554 return (EQ (XSYMBOL (sym
)->function
, Qunbound
) ? Qnil
: Qt
);
557 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
559 register Lisp_Object sym
;
561 CHECK_SYMBOL (sym
, 0);
562 if (NILP (sym
) || EQ (sym
, Qt
))
563 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
564 Fset (sym
, Qunbound
);
568 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
570 register Lisp_Object sym
;
572 CHECK_SYMBOL (sym
, 0);
573 if (NILP (sym
) || EQ (sym
, Qt
))
574 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
575 XSYMBOL (sym
)->function
= Qunbound
;
579 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
580 "Return SYMBOL's function definition. Error if that is void.")
582 register Lisp_Object symbol
;
584 CHECK_SYMBOL (symbol
, 0);
585 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
586 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
587 return XSYMBOL (symbol
)->function
;
590 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
592 register Lisp_Object sym
;
594 CHECK_SYMBOL (sym
, 0);
595 return XSYMBOL (sym
)->plist
;
598 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
600 register Lisp_Object sym
;
602 register Lisp_Object name
;
604 CHECK_SYMBOL (sym
, 0);
605 XSETSTRING (name
, XSYMBOL (sym
)->name
);
609 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
610 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
612 register Lisp_Object sym
, newdef
;
614 CHECK_SYMBOL (sym
, 0);
615 if (NILP (sym
) || EQ (sym
, Qt
))
616 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
617 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
618 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
620 XSYMBOL (sym
)->function
= newdef
;
621 /* Handle automatic advice activation */
622 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
624 call2 (Qad_activate
, sym
, Qnil
);
625 newdef
= XSYMBOL (sym
)->function
;
630 /* This name should be removed once it is eliminated from elsewhere. */
632 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
633 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
634 Associates the function with the current load file, if any.")
636 register Lisp_Object sym
, newdef
;
638 CHECK_SYMBOL (sym
, 0);
639 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
640 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
642 XSYMBOL (sym
)->function
= newdef
;
643 /* Handle automatic advice activation */
644 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
646 call2 (Qad_activate
, sym
, Qnil
);
647 newdef
= XSYMBOL (sym
)->function
;
649 LOADHIST_ATTACH (sym
);
653 DEFUN ("define-function", Fdefine_function
, Sdefine_function
, 2, 2, 0,
654 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
655 Associates the function with the current load file, if any.")
657 register Lisp_Object sym
, newdef
;
659 CHECK_SYMBOL (sym
, 0);
660 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (sym
)->function
, Qunbound
))
661 Vautoload_queue
= Fcons (Fcons (sym
, XSYMBOL (sym
)->function
),
663 XSYMBOL (sym
)->function
= newdef
;
664 /* Handle automatic advice activation */
665 if (CONSP (XSYMBOL (sym
)->plist
) && !NILP (Fget (sym
, Qad_advice_info
)))
667 call2 (Qad_activate
, sym
, Qnil
);
668 newdef
= XSYMBOL (sym
)->function
;
670 LOADHIST_ATTACH (sym
);
674 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
675 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
677 register Lisp_Object sym
, newplist
;
679 CHECK_SYMBOL (sym
, 0);
680 XSYMBOL (sym
)->plist
= newplist
;
685 /* Getting and setting values of symbols */
687 /* Given the raw contents of a symbol value cell,
688 return the Lisp value of the symbol.
689 This does not handle buffer-local variables; use
690 swap_in_symval_forwarding for that. */
693 do_symval_forwarding (valcontents
)
694 register Lisp_Object valcontents
;
696 register Lisp_Object val
;
698 if (MISCP (valcontents
))
699 switch (XMISCTYPE (valcontents
))
701 case Lisp_Misc_Intfwd
:
702 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
705 case Lisp_Misc_Boolfwd
:
706 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
708 case Lisp_Misc_Objfwd
:
709 return *XOBJFWD (valcontents
)->objvar
;
711 case Lisp_Misc_Buffer_Objfwd
:
712 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
713 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
715 case Lisp_Misc_Kboard_Objfwd
:
716 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
717 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
722 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
723 of SYM. If SYM is buffer-local, VALCONTENTS should be the
724 buffer-independent contents of the value cell: forwarded just one
725 step past the buffer-localness. */
728 store_symval_forwarding (sym
, valcontents
, newval
)
730 register Lisp_Object valcontents
, newval
;
732 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
735 switch (XMISCTYPE (valcontents
))
737 case Lisp_Misc_Intfwd
:
738 CHECK_NUMBER (newval
, 1);
739 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
740 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
741 error ("Value out of range for variable `%s'",
742 XSYMBOL (sym
)->name
->data
);
745 case Lisp_Misc_Boolfwd
:
746 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
749 case Lisp_Misc_Objfwd
:
750 *XOBJFWD (valcontents
)->objvar
= newval
;
753 case Lisp_Misc_Buffer_Objfwd
:
755 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
758 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
759 if (! NILP (type
) && ! NILP (newval
)
760 && XTYPE (newval
) != XINT (type
))
761 buffer_slot_type_mismatch (offset
);
763 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
767 case Lisp_Misc_Kboard_Objfwd
:
768 (*(Lisp_Object
*)((char *)current_kboard
769 + XKBOARD_OBJFWD (valcontents
)->offset
))
780 valcontents
= XSYMBOL (sym
)->value
;
781 if (BUFFER_LOCAL_VALUEP (valcontents
)
782 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
783 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
785 XSYMBOL (sym
)->value
= newval
;
789 /* Set up the buffer-local symbol SYM for validity in the current
790 buffer. VALCONTENTS is the contents of its value cell.
791 Return the value forwarded one step past the buffer-local indicator. */
794 swap_in_symval_forwarding (sym
, valcontents
)
795 Lisp_Object sym
, valcontents
;
797 /* valcontents is a pointer to a struct resembling the cons
798 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
800 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
801 local_var_alist, that being the element whose car is this
802 variable. Or it can be a pointer to the
803 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
804 an element in its alist for this variable.
806 If the current buffer is not BUFFER, we store the current
807 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
808 appropriate alist element for the buffer now current and set up
809 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
810 element, and store into BUFFER.
812 Note that REALVALUE can be a forwarding pointer. */
814 register Lisp_Object tem1
;
815 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
817 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
819 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
821 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
822 tem1
= assq_no_quit (sym
, current_buffer
->local_var_alist
);
824 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
825 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
826 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
828 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
831 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
834 /* Find the value of a symbol, returning Qunbound if it's not bound.
835 This is helpful for code which just wants to get a variable's value
836 if it has one, without signalling an error.
837 Note that it must not be possible to quit
838 within this function. Great care is required for this. */
841 find_symbol_value (sym
)
844 register Lisp_Object valcontents
, tem1
;
845 register Lisp_Object val
;
846 CHECK_SYMBOL (sym
, 0);
847 valcontents
= XSYMBOL (sym
)->value
;
849 if (BUFFER_LOCAL_VALUEP (valcontents
)
850 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
851 valcontents
= swap_in_symval_forwarding (sym
, valcontents
);
853 if (MISCP (valcontents
))
855 switch (XMISCTYPE (valcontents
))
857 case Lisp_Misc_Intfwd
:
858 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
861 case Lisp_Misc_Boolfwd
:
862 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
864 case Lisp_Misc_Objfwd
:
865 return *XOBJFWD (valcontents
)->objvar
;
867 case Lisp_Misc_Buffer_Objfwd
:
868 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
869 + (char *)current_buffer
);
871 case Lisp_Misc_Kboard_Objfwd
:
872 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
873 + (char *)current_kboard
);
880 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
881 "Return SYMBOL's value. Error if that is void.")
887 val
= find_symbol_value (sym
);
888 if (EQ (val
, Qunbound
))
889 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
894 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
895 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
897 register Lisp_Object sym
, newval
;
899 int voide
= EQ (newval
, Qunbound
);
901 register Lisp_Object valcontents
, tem1
, current_alist_element
;
903 CHECK_SYMBOL (sym
, 0);
904 if (NILP (sym
) || EQ (sym
, Qt
))
905 return Fsignal (Qsetting_constant
, Fcons (sym
, Qnil
));
906 valcontents
= XSYMBOL (sym
)->value
;
908 if (BUFFER_OBJFWDP (valcontents
))
910 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
911 register int mask
= XINT (*((Lisp_Object
*)
912 (idx
+ (char *)&buffer_local_flags
)));
914 current_buffer
->local_var_flags
|= mask
;
917 else if (BUFFER_LOCAL_VALUEP (valcontents
)
918 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
920 /* valcontents is actually a pointer to a struct resembling a cons,
921 with contents something like:
922 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
924 BUFFER is the last buffer for which this symbol's value was
927 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
928 local_var_alist, that being the element whose car is this
929 variable. Or it can be a pointer to the
930 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
931 have an element in its alist for this variable (that is, if
932 BUFFER sees the default value of this variable).
934 If we want to examine or set the value and BUFFER is current,
935 we just examine or set REALVALUE. If BUFFER is not current, we
936 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
937 then find the appropriate alist element for the buffer now
938 current and set up CURRENT-ALIST-ELEMENT. Then we set
939 REALVALUE out of that element, and store into BUFFER.
941 If we are setting the variable and the current buffer does
942 not have an alist entry for this variable, an alist entry is
945 Note that REALVALUE can be a forwarding pointer. Each time
946 it is examined or set, forwarding must be done. */
948 /* What value are we caching right now? */
949 current_alist_element
=
950 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
952 /* If the current buffer is not the buffer whose binding is
953 currently cached, or if it's a Lisp_Buffer_Local_Value and
954 we're looking at the default value, the cache is invalid; we
955 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
957 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
958 || (BUFFER_LOCAL_VALUEP (valcontents
)
959 && EQ (XCONS (current_alist_element
)->car
,
960 current_alist_element
)))
962 /* Write out the cached value for the old buffer; copy it
963 back to its alist element. This works if the current
964 buffer only sees the default value, too. */
965 Fsetcdr (current_alist_element
,
966 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
968 /* Find the new value for CURRENT-ALIST-ELEMENT. */
969 tem1
= Fassq (sym
, current_buffer
->local_var_alist
);
972 /* This buffer still sees the default value. */
974 /* If the variable is a Lisp_Some_Buffer_Local_Value,
975 make CURRENT-ALIST-ELEMENT point to itself,
976 indicating that we're seeing the default value. */
977 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
978 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
980 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
981 new assoc for a local value and set
982 CURRENT-ALIST-ELEMENT to point to that. */
985 tem1
= Fcons (sym
, Fcdr (current_alist_element
));
986 current_buffer
->local_var_alist
=
987 Fcons (tem1
, current_buffer
->local_var_alist
);
990 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
991 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
994 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
995 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
998 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1001 /* If storing void (making the symbol void), forward only through
1002 buffer-local indicator, not through Lisp_Objfwd, etc. */
1004 store_symval_forwarding (sym
, Qnil
, newval
);
1006 store_symval_forwarding (sym
, valcontents
, newval
);
1011 /* Access or set a buffer-local symbol's default value. */
1013 /* Return the default value of SYM, but don't check for voidness.
1014 Return Qunbound if it is void. */
1020 register Lisp_Object valcontents
;
1022 CHECK_SYMBOL (sym
, 0);
1023 valcontents
= XSYMBOL (sym
)->value
;
1025 /* For a built-in buffer-local variable, get the default value
1026 rather than letting do_symval_forwarding get the current value. */
1027 if (BUFFER_OBJFWDP (valcontents
))
1029 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1031 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1032 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1035 /* Handle user-created local variables. */
1036 if (BUFFER_LOCAL_VALUEP (valcontents
)
1037 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1039 /* If var is set up for a buffer that lacks a local value for it,
1040 the current value is nominally the default value.
1041 But the current value slot may be more up to date, since
1042 ordinary setq stores just that slot. So use that. */
1043 Lisp_Object current_alist_element
, alist_element_car
;
1044 current_alist_element
1045 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1046 alist_element_car
= XCONS (current_alist_element
)->car
;
1047 if (EQ (alist_element_car
, current_alist_element
))
1048 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1050 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1052 /* For other variables, get the current value. */
1053 return do_symval_forwarding (valcontents
);
1056 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1057 "Return T if SYMBOL has a non-void default value.\n\
1058 This is the value that is seen in buffers that do not have their own values\n\
1059 for this variable.")
1063 register Lisp_Object value
;
1065 value
= default_value (sym
);
1066 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1069 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1070 "Return SYMBOL's default value.\n\
1071 This is the value that is seen in buffers that do not have their own values\n\
1072 for this variable. The default value is meaningful for variables with\n\
1073 local bindings in certain buffers.")
1077 register Lisp_Object value
;
1079 value
= default_value (sym
);
1080 if (EQ (value
, Qunbound
))
1081 return Fsignal (Qvoid_variable
, Fcons (sym
, Qnil
));
1085 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1086 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1087 The default value is seen in buffers that do not have their own values\n\
1088 for this variable.")
1090 Lisp_Object sym
, value
;
1092 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1094 CHECK_SYMBOL (sym
, 0);
1095 valcontents
= XSYMBOL (sym
)->value
;
1097 /* Handle variables like case-fold-search that have special slots
1098 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1100 if (BUFFER_OBJFWDP (valcontents
))
1102 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1103 register struct buffer
*b
;
1104 register int mask
= XINT (*((Lisp_Object
*)
1105 (idx
+ (char *)&buffer_local_flags
)));
1109 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1110 for (b
= all_buffers
; b
; b
= b
->next
)
1111 if (!(b
->local_var_flags
& mask
))
1112 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1117 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1118 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1119 return Fset (sym
, value
);
1121 /* Store new value into the DEFAULT-VALUE slot */
1122 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1124 /* If that slot is current, we must set the REALVALUE slot too */
1125 current_alist_element
1126 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1127 alist_element_buffer
= Fcar (current_alist_element
);
1128 if (EQ (alist_element_buffer
, current_alist_element
))
1129 store_symval_forwarding (sym
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1135 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1136 "Set the default value of variable VAR to VALUE.\n\
1137 VAR, the variable name, is literal (not evaluated);\n\
1138 VALUE is an expression and it is evaluated.\n\
1139 The default value of a variable is seen in buffers\n\
1140 that do not have their own values for the variable.\n\
1142 More generally, you can use multiple variables and values, as in\n\
1143 (setq-default SYM VALUE SYM VALUE...)\n\
1144 This sets each SYM's default value to the corresponding VALUE.\n\
1145 The VALUE for the Nth SYM can refer to the new default values\n\
1150 register Lisp_Object args_left
;
1151 register Lisp_Object val
, sym
;
1152 struct gcpro gcpro1
;
1162 val
= Feval (Fcar (Fcdr (args_left
)));
1163 sym
= Fcar (args_left
);
1164 Fset_default (sym
, val
);
1165 args_left
= Fcdr (Fcdr (args_left
));
1167 while (!NILP (args_left
));
1173 /* Lisp functions for creating and removing buffer-local variables. */
1175 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1176 1, 1, "vMake Variable Buffer Local: ",
1177 "Make VARIABLE have a separate value for each buffer.\n\
1178 At any time, the value for the current buffer is in effect.\n\
1179 There is also a default value which is seen in any buffer which has not yet\n\
1180 set its own value.\n\
1181 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1182 for the current buffer if it was previously using the default value.\n\
1183 The function `default-value' gets the default value and `set-default' sets it.")
1185 register Lisp_Object sym
;
1187 register Lisp_Object tem
, valcontents
, newval
;
1189 CHECK_SYMBOL (sym
, 0);
1191 valcontents
= XSYMBOL (sym
)->value
;
1192 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1193 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1195 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1197 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1199 XMISCTYPE (XSYMBOL (sym
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1202 if (EQ (valcontents
, Qunbound
))
1203 XSYMBOL (sym
)->value
= Qnil
;
1204 tem
= Fcons (Qnil
, Fsymbol_value (sym
));
1205 XCONS (tem
)->car
= tem
;
1206 newval
= allocate_misc ();
1207 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1208 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1209 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1210 XSYMBOL (sym
)->value
= newval
;
1214 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1215 1, 1, "vMake Local Variable: ",
1216 "Make VARIABLE have a separate value in the current buffer.\n\
1217 Other buffers will continue to share a common default value.\n\
1218 \(The buffer-local value of VARIABLE starts out as the same value\n\
1219 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1220 See also `make-variable-buffer-local'.\n\n\
1221 If the variable is already arranged to become local when set,\n\
1222 this function causes a local value to exist for this buffer,\n\
1223 just as setting the variable would do.\n\
1225 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1226 Use `make-local-hook' instead.")
1228 register Lisp_Object sym
;
1230 register Lisp_Object tem
, valcontents
;
1232 CHECK_SYMBOL (sym
, 0);
1234 valcontents
= XSYMBOL (sym
)->value
;
1235 if (EQ (sym
, Qnil
) || EQ (sym
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1236 error ("Symbol %s may not be buffer-local", XSYMBOL (sym
)->name
->data
);
1238 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1240 tem
= Fboundp (sym
);
1242 /* Make sure the symbol has a local value in this particular buffer,
1243 by setting it to the same value it already has. */
1244 Fset (sym
, (EQ (tem
, Qt
) ? Fsymbol_value (sym
) : Qunbound
));
1247 /* Make sure sym is set up to hold per-buffer values */
1248 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1251 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1252 XCONS (tem
)->car
= tem
;
1253 newval
= allocate_misc ();
1254 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1255 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (sym
)->value
;
1256 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1257 XSYMBOL (sym
)->value
= newval
;
1259 /* Make sure this buffer has its own value of sym */
1260 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1263 current_buffer
->local_var_alist
1264 = Fcons (Fcons (sym
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->cdr
)->cdr
)->cdr
),
1265 current_buffer
->local_var_alist
);
1267 /* Make sure symbol does not think it is set up for this buffer;
1268 force it to look once again for this buffer's value */
1270 Lisp_Object
*pvalbuf
;
1271 valcontents
= XSYMBOL (sym
)->value
;
1272 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1273 if (current_buffer
== XBUFFER (*pvalbuf
))
1278 /* If the symbol forwards into a C variable, then swap in the
1279 variable for this buffer immediately. If C code modifies the
1280 variable before we swap in, then that new value will clobber the
1281 default value the next time we swap. */
1282 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (sym
)->value
)->car
;
1283 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1284 swap_in_symval_forwarding (sym
, XSYMBOL (sym
)->value
);
1289 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1290 1, 1, "vKill Local Variable: ",
1291 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1292 From now on the default value will apply in this buffer.")
1294 register Lisp_Object sym
;
1296 register Lisp_Object tem
, valcontents
;
1298 CHECK_SYMBOL (sym
, 0);
1300 valcontents
= XSYMBOL (sym
)->value
;
1302 if (BUFFER_OBJFWDP (valcontents
))
1304 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1305 register int mask
= XINT (*((Lisp_Object
*)
1306 (idx
+ (char *)&buffer_local_flags
)));
1310 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1311 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1312 current_buffer
->local_var_flags
&= ~mask
;
1317 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1318 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1321 /* Get rid of this buffer's alist element, if any */
1323 tem
= Fassq (sym
, current_buffer
->local_var_alist
);
1325 current_buffer
->local_var_alist
1326 = Fdelq (tem
, current_buffer
->local_var_alist
);
1328 /* Make sure symbol does not think it is set up for this buffer;
1329 force it to look once again for this buffer's value */
1331 Lisp_Object
*pvalbuf
;
1332 valcontents
= XSYMBOL (sym
)->value
;
1333 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1334 if (current_buffer
== XBUFFER (*pvalbuf
))
1341 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1343 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1344 BUFFER defaults to the current buffer.")
1346 register Lisp_Object sym
, buffer
;
1348 Lisp_Object valcontents
;
1349 register struct buffer
*buf
;
1352 buf
= current_buffer
;
1355 CHECK_BUFFER (buffer
, 0);
1356 buf
= XBUFFER (buffer
);
1359 CHECK_SYMBOL (sym
, 0);
1361 valcontents
= XSYMBOL (sym
)->value
;
1362 if (BUFFER_LOCAL_VALUEP (valcontents
)
1363 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1365 Lisp_Object tail
, elt
;
1366 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1368 elt
= XCONS (tail
)->car
;
1369 if (EQ (sym
, XCONS (elt
)->car
))
1373 if (BUFFER_OBJFWDP (valcontents
))
1375 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1376 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1377 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1383 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1385 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1386 BUFFER defaults to the current buffer.")
1388 register Lisp_Object sym
, buffer
;
1390 Lisp_Object valcontents
;
1391 register struct buffer
*buf
;
1394 buf
= current_buffer
;
1397 CHECK_BUFFER (buffer
, 0);
1398 buf
= XBUFFER (buffer
);
1401 CHECK_SYMBOL (sym
, 0);
1403 valcontents
= XSYMBOL (sym
)->value
;
1405 /* This means that make-variable-buffer-local was done. */
1406 if (BUFFER_LOCAL_VALUEP (valcontents
))
1408 /* All these slots become local if they are set. */
1409 if (BUFFER_OBJFWDP (valcontents
))
1411 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1413 Lisp_Object tail
, elt
;
1414 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1416 elt
= XCONS (tail
)->car
;
1417 if (EQ (sym
, XCONS (elt
)->car
))
1424 /* Find the function at the end of a chain of symbol function indirections. */
1426 /* If OBJECT is a symbol, find the end of its function chain and
1427 return the value found there. If OBJECT is not a symbol, just
1428 return it. If there is a cycle in the function chain, signal a
1429 cyclic-function-indirection error.
1431 This is like Findirect_function, except that it doesn't signal an
1432 error if the chain ends up unbound. */
1434 indirect_function (object
)
1435 register Lisp_Object object
;
1437 Lisp_Object tortoise
, hare
;
1439 hare
= tortoise
= object
;
1443 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1445 hare
= XSYMBOL (hare
)->function
;
1446 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1448 hare
= XSYMBOL (hare
)->function
;
1450 tortoise
= XSYMBOL (tortoise
)->function
;
1452 if (EQ (hare
, tortoise
))
1453 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1459 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1460 "Return the function at the end of OBJECT's function chain.\n\
1461 If OBJECT is a symbol, follow all function indirections and return the final\n\
1462 function binding.\n\
1463 If OBJECT is not a symbol, just return it.\n\
1464 Signal a void-function error if the final symbol is unbound.\n\
1465 Signal a cyclic-function-indirection error if there is a loop in the\n\
1466 function chain of symbols.")
1468 register Lisp_Object object
;
1472 result
= indirect_function (object
);
1474 if (EQ (result
, Qunbound
))
1475 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1479 /* Extract and set vector and string elements */
1481 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1482 "Return the element of ARRAY at index INDEX.\n\
1483 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1485 register Lisp_Object array
;
1488 register int idxval
;
1490 CHECK_NUMBER (idx
, 1);
1491 idxval
= XINT (idx
);
1492 if (STRINGP (array
))
1495 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1496 args_out_of_range (array
, idx
);
1497 XSETFASTINT (val
, (unsigned char) XSTRING (array
)->data
[idxval
]);
1503 if (VECTORP (array
))
1504 size
= XVECTOR (array
)->size
;
1505 else if (COMPILEDP (array
))
1506 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1508 wrong_type_argument (Qarrayp
, array
);
1510 if (idxval
< 0 || idxval
>= size
)
1511 args_out_of_range (array
, idx
);
1512 return XVECTOR (array
)->contents
[idxval
];
1516 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1517 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1518 ARRAY may be a vector or a string. IDX starts at 0.")
1519 (array
, idx
, newelt
)
1520 register Lisp_Object array
;
1521 Lisp_Object idx
, newelt
;
1523 register int idxval
;
1525 CHECK_NUMBER (idx
, 1);
1526 idxval
= XINT (idx
);
1527 if (!VECTORP (array
) && !STRINGP (array
))
1528 array
= wrong_type_argument (Qarrayp
, array
);
1529 CHECK_IMPURE (array
);
1531 if (VECTORP (array
))
1533 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1534 args_out_of_range (array
, idx
);
1535 XVECTOR (array
)->contents
[idxval
] = newelt
;
1539 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1540 args_out_of_range (array
, idx
);
1541 CHECK_NUMBER (newelt
, 2);
1542 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1548 /* Arithmetic functions */
1550 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1553 arithcompare (num1
, num2
, comparison
)
1554 Lisp_Object num1
, num2
;
1555 enum comparison comparison
;
1560 #ifdef LISP_FLOAT_TYPE
1561 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1562 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1564 if (FLOATP (num1
) || FLOATP (num2
))
1567 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1568 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1571 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1572 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1573 #endif /* LISP_FLOAT_TYPE */
1578 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1583 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1588 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1593 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1598 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1603 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1612 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1613 "T if two args, both numbers or markers, are equal.")
1615 register Lisp_Object num1
, num2
;
1617 return arithcompare (num1
, num2
, equal
);
1620 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1621 "T if first arg is less than second arg. Both must be numbers or markers.")
1623 register Lisp_Object num1
, num2
;
1625 return arithcompare (num1
, num2
, less
);
1628 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1629 "T if first arg is greater than second arg. Both must be numbers or markers.")
1631 register Lisp_Object num1
, num2
;
1633 return arithcompare (num1
, num2
, grtr
);
1636 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1637 "T if first arg is less than or equal to second arg.\n\
1638 Both must be numbers or markers.")
1640 register Lisp_Object num1
, num2
;
1642 return arithcompare (num1
, num2
, less_or_equal
);
1645 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1646 "T if first arg is greater than or equal to second arg.\n\
1647 Both must be numbers or markers.")
1649 register Lisp_Object num1
, num2
;
1651 return arithcompare (num1
, num2
, grtr_or_equal
);
1654 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1655 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1657 register Lisp_Object num1
, num2
;
1659 return arithcompare (num1
, num2
, notequal
);
1662 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "T if NUMBER is zero.")
1664 register Lisp_Object num
;
1666 #ifdef LISP_FLOAT_TYPE
1667 CHECK_NUMBER_OR_FLOAT (num
, 0);
1671 if (XFLOAT(num
)->data
== 0.0)
1676 CHECK_NUMBER (num
, 0);
1677 #endif /* LISP_FLOAT_TYPE */
1684 /* Convert between long values and pairs of Lisp integers. */
1690 unsigned int top
= i
>> 16;
1691 unsigned int bot
= i
& 0xFFFF;
1693 return make_number (bot
);
1694 if (top
== (unsigned long)-1 >> 16)
1695 return Fcons (make_number (-1), make_number (bot
));
1696 return Fcons (make_number (top
), make_number (bot
));
1703 Lisp_Object top
, bot
;
1706 top
= XCONS (c
)->car
;
1707 bot
= XCONS (c
)->cdr
;
1709 bot
= XCONS (bot
)->car
;
1710 return ((XINT (top
) << 16) | XINT (bot
));
1713 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1714 "Convert NUM to a string by printing it in decimal.\n\
1715 Uses a minus sign if negative.\n\
1716 NUM may be an integer or a floating point number.")
1720 char buffer
[VALBITS
];
1722 #ifndef LISP_FLOAT_TYPE
1723 CHECK_NUMBER (num
, 0);
1725 CHECK_NUMBER_OR_FLOAT (num
, 0);
1729 char pigbuf
[350]; /* see comments in float_to_string */
1731 float_to_string (pigbuf
, XFLOAT(num
)->data
);
1732 return build_string (pigbuf
);
1734 #endif /* LISP_FLOAT_TYPE */
1736 if (sizeof (int) == sizeof (EMACS_INT
))
1737 sprintf (buffer
, "%d", XINT (num
));
1738 else if (sizeof (long) == sizeof (EMACS_INT
))
1739 sprintf (buffer
, "%ld", XINT (num
));
1742 return build_string (buffer
);
1745 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 1, 0,
1746 "Convert STRING to a number by parsing it as a decimal number.\n\
1747 This parses both integers and floating point numbers.\n\
1748 It ignores leading spaces and tabs.")
1750 register Lisp_Object str
;
1755 CHECK_STRING (str
, 0);
1757 p
= XSTRING (str
)->data
;
1759 /* Skip any whitespace at the front of the number. Some versions of
1760 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1761 while (*p
== ' ' || *p
== '\t')
1764 #ifdef LISP_FLOAT_TYPE
1765 if (isfloat_string (p
))
1766 return make_float (atof (p
));
1767 #endif /* LISP_FLOAT_TYPE */
1769 if (sizeof (int) == sizeof (EMACS_INT
))
1770 XSETINT (value
, atoi (p
));
1771 else if (sizeof (long) == sizeof (EMACS_INT
))
1772 XSETINT (value
, atol (p
));
1779 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
1781 extern Lisp_Object
float_arith_driver ();
1784 arith_driver (code
, nargs
, args
)
1787 register Lisp_Object
*args
;
1789 register Lisp_Object val
;
1790 register int argnum
;
1791 register EMACS_INT accum
;
1792 register EMACS_INT next
;
1794 switch (SWITCH_ENUM_CAST (code
))
1807 for (argnum
= 0; argnum
< nargs
; argnum
++)
1809 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1810 #ifdef LISP_FLOAT_TYPE
1811 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1813 if (FLOATP (val
)) /* time to do serious math */
1814 return (float_arith_driver ((double) accum
, argnum
, code
,
1817 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
1818 #endif /* LISP_FLOAT_TYPE */
1819 args
[argnum
] = val
; /* runs into a compiler bug. */
1820 next
= XINT (args
[argnum
]);
1821 switch (SWITCH_ENUM_CAST (code
))
1823 case Aadd
: accum
+= next
; break;
1825 if (!argnum
&& nargs
!= 1)
1829 case Amult
: accum
*= next
; break;
1831 if (!argnum
) accum
= next
;
1835 Fsignal (Qarith_error
, Qnil
);
1839 case Alogand
: accum
&= next
; break;
1840 case Alogior
: accum
|= next
; break;
1841 case Alogxor
: accum
^= next
; break;
1842 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
1843 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
1847 XSETINT (val
, accum
);
1851 #ifdef LISP_FLOAT_TYPE
1854 #define isnan(x) ((x) != (x))
1857 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
1859 register int argnum
;
1862 register Lisp_Object
*args
;
1864 register Lisp_Object val
;
1867 for (; argnum
< nargs
; argnum
++)
1869 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1870 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
1874 next
= XFLOAT (val
)->data
;
1878 args
[argnum
] = val
; /* runs into a compiler bug. */
1879 next
= XINT (args
[argnum
]);
1881 switch (SWITCH_ENUM_CAST (code
))
1887 if (!argnum
&& nargs
!= 1)
1900 Fsignal (Qarith_error
, Qnil
);
1907 return wrong_type_argument (Qinteger_or_marker_p
, val
);
1909 if (!argnum
|| isnan (next
) || next
> accum
)
1913 if (!argnum
|| isnan (next
) || next
< accum
)
1919 return make_float (accum
);
1921 #endif /* LISP_FLOAT_TYPE */
1923 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
1924 "Return sum of any number of arguments, which are numbers or markers.")
1929 return arith_driver (Aadd
, nargs
, args
);
1932 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
1933 "Negate number or subtract numbers or markers.\n\
1934 With one arg, negates it. With more than one arg,\n\
1935 subtracts all but the first from the first.")
1940 return arith_driver (Asub
, nargs
, args
);
1943 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
1944 "Returns product of any number of arguments, which are numbers or markers.")
1949 return arith_driver (Amult
, nargs
, args
);
1952 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
1953 "Returns first argument divided by all the remaining arguments.\n\
1954 The arguments must be numbers or markers.")
1959 return arith_driver (Adiv
, nargs
, args
);
1962 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
1963 "Returns remainder of first arg divided by second.\n\
1964 Both must be integers or markers.")
1966 register Lisp_Object num1
, num2
;
1970 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1971 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
1973 if (XFASTINT (num2
) == 0)
1974 Fsignal (Qarith_error
, Qnil
);
1976 XSETINT (val
, XINT (num1
) % XINT (num2
));
1985 #ifdef HAVE_DREM /* Some systems use this non-standard name. */
1986 return (drem (f1
, f2
));
1987 #else /* Other systems don't seem to have it at all. */
1988 return (f1
- f2
* floor (f1
/f2
));
1991 #endif /* ! HAVE_FMOD */
1993 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
1994 "Returns X modulo Y.\n\
1995 The result falls between zero (inclusive) and Y (exclusive).\n\
1996 Both X and Y must be numbers or markers.")
1998 register Lisp_Object num1
, num2
;
2003 #ifdef LISP_FLOAT_TYPE
2004 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
2005 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 1);
2007 if (FLOATP (num1
) || FLOATP (num2
))
2011 f1
= FLOATP (num1
) ? XFLOAT (num1
)->data
: XINT (num1
);
2012 f2
= FLOATP (num2
) ? XFLOAT (num2
)->data
: XINT (num2
);
2014 Fsignal (Qarith_error
, Qnil
);
2017 /* If the "remainder" comes out with the wrong sign, fix it. */
2018 if (f2
< 0 ? f1
> 0 : f1
< 0)
2020 return (make_float (f1
));
2022 #else /* not LISP_FLOAT_TYPE */
2023 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
2024 CHECK_NUMBER_COERCE_MARKER (num2
, 1);
2025 #endif /* not LISP_FLOAT_TYPE */
2031 Fsignal (Qarith_error
, Qnil
);
2035 /* If the "remainder" comes out with the wrong sign, fix it. */
2036 if (i2
< 0 ? i1
> 0 : i1
< 0)
2043 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2044 "Return largest of all the arguments (which must be numbers or markers).\n\
2045 The value is always a number; markers are converted to numbers.")
2050 return arith_driver (Amax
, nargs
, args
);
2053 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2054 "Return smallest of all the arguments (which must be numbers or markers).\n\
2055 The value is always a number; markers are converted to numbers.")
2060 return arith_driver (Amin
, nargs
, args
);
2063 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2064 "Return bitwise-and of all the arguments.\n\
2065 Arguments may be integers, or markers converted to integers.")
2070 return arith_driver (Alogand
, nargs
, args
);
2073 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2074 "Return bitwise-or of all the arguments.\n\
2075 Arguments may be integers, or markers converted to integers.")
2080 return arith_driver (Alogior
, nargs
, args
);
2083 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2084 "Return bitwise-exclusive-or of all the arguments.\n\
2085 Arguments may be integers, or markers converted to integers.")
2090 return arith_driver (Alogxor
, nargs
, args
);
2093 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2094 "Return VALUE with its bits shifted left by COUNT.\n\
2095 If COUNT is negative, shifting is actually to the right.\n\
2096 In this case, the sign bit is duplicated.")
2098 register Lisp_Object value
, count
;
2100 register Lisp_Object val
;
2102 CHECK_NUMBER (value
, 0);
2103 CHECK_NUMBER (count
, 1);
2105 if (XINT (count
) > 0)
2106 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2108 XSETINT (val
, XINT (value
) >> -XINT (count
));
2112 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2113 "Return VALUE with its bits shifted left by COUNT.\n\
2114 If COUNT is negative, shifting is actually to the right.\n\
2115 In this case, zeros are shifted in on the left.")
2117 register Lisp_Object value
, count
;
2119 register Lisp_Object val
;
2121 CHECK_NUMBER (value
, 0);
2122 CHECK_NUMBER (count
, 1);
2124 if (XINT (count
) > 0)
2125 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2127 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2131 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2132 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2133 Markers are converted to integers.")
2135 register Lisp_Object num
;
2137 #ifdef LISP_FLOAT_TYPE
2138 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2141 return (make_float (1.0 + XFLOAT (num
)->data
));
2143 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2144 #endif /* LISP_FLOAT_TYPE */
2146 XSETINT (num
, XINT (num
) + 1);
2150 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2151 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2152 Markers are converted to integers.")
2154 register Lisp_Object num
;
2156 #ifdef LISP_FLOAT_TYPE
2157 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num
, 0);
2160 return (make_float (-1.0 + XFLOAT (num
)->data
));
2162 CHECK_NUMBER_COERCE_MARKER (num
, 0);
2163 #endif /* LISP_FLOAT_TYPE */
2165 XSETINT (num
, XINT (num
) - 1);
2169 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2170 "Return the bitwise complement of ARG. ARG must be an integer.")
2172 register Lisp_Object num
;
2174 CHECK_NUMBER (num
, 0);
2175 XSETINT (num
, ~XINT (num
));
2182 Lisp_Object error_tail
, arith_tail
;
2184 Qquote
= intern ("quote");
2185 Qlambda
= intern ("lambda");
2186 Qsubr
= intern ("subr");
2187 Qerror_conditions
= intern ("error-conditions");
2188 Qerror_message
= intern ("error-message");
2189 Qtop_level
= intern ("top-level");
2191 Qerror
= intern ("error");
2192 Qquit
= intern ("quit");
2193 Qwrong_type_argument
= intern ("wrong-type-argument");
2194 Qargs_out_of_range
= intern ("args-out-of-range");
2195 Qvoid_function
= intern ("void-function");
2196 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2197 Qvoid_variable
= intern ("void-variable");
2198 Qsetting_constant
= intern ("setting-constant");
2199 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2201 Qinvalid_function
= intern ("invalid-function");
2202 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2203 Qno_catch
= intern ("no-catch");
2204 Qend_of_file
= intern ("end-of-file");
2205 Qarith_error
= intern ("arith-error");
2206 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2207 Qend_of_buffer
= intern ("end-of-buffer");
2208 Qbuffer_read_only
= intern ("buffer-read-only");
2209 Qmark_inactive
= intern ("mark-inactive");
2211 Qlistp
= intern ("listp");
2212 Qconsp
= intern ("consp");
2213 Qsymbolp
= intern ("symbolp");
2214 Qintegerp
= intern ("integerp");
2215 Qnatnump
= intern ("natnump");
2216 Qwholenump
= intern ("wholenump");
2217 Qstringp
= intern ("stringp");
2218 Qarrayp
= intern ("arrayp");
2219 Qsequencep
= intern ("sequencep");
2220 Qbufferp
= intern ("bufferp");
2221 Qvectorp
= intern ("vectorp");
2222 Qchar_or_string_p
= intern ("char-or-string-p");
2223 Qmarkerp
= intern ("markerp");
2224 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2225 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2226 Qboundp
= intern ("boundp");
2227 Qfboundp
= intern ("fboundp");
2229 #ifdef LISP_FLOAT_TYPE
2230 Qfloatp
= intern ("floatp");
2231 Qnumberp
= intern ("numberp");
2232 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2233 #endif /* LISP_FLOAT_TYPE */
2235 Qcdr
= intern ("cdr");
2237 /* Handle automatic advice activation */
2238 Qad_advice_info
= intern ("ad-advice-info");
2239 Qad_activate
= intern ("ad-activate");
2241 error_tail
= Fcons (Qerror
, Qnil
);
2243 /* ERROR is used as a signaler for random errors for which nothing else is right */
2245 Fput (Qerror
, Qerror_conditions
,
2247 Fput (Qerror
, Qerror_message
,
2248 build_string ("error"));
2250 Fput (Qquit
, Qerror_conditions
,
2251 Fcons (Qquit
, Qnil
));
2252 Fput (Qquit
, Qerror_message
,
2253 build_string ("Quit"));
2255 Fput (Qwrong_type_argument
, Qerror_conditions
,
2256 Fcons (Qwrong_type_argument
, error_tail
));
2257 Fput (Qwrong_type_argument
, Qerror_message
,
2258 build_string ("Wrong type argument"));
2260 Fput (Qargs_out_of_range
, Qerror_conditions
,
2261 Fcons (Qargs_out_of_range
, error_tail
));
2262 Fput (Qargs_out_of_range
, Qerror_message
,
2263 build_string ("Args out of range"));
2265 Fput (Qvoid_function
, Qerror_conditions
,
2266 Fcons (Qvoid_function
, error_tail
));
2267 Fput (Qvoid_function
, Qerror_message
,
2268 build_string ("Symbol's function definition is void"));
2270 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2271 Fcons (Qcyclic_function_indirection
, error_tail
));
2272 Fput (Qcyclic_function_indirection
, Qerror_message
,
2273 build_string ("Symbol's chain of function indirections contains a loop"));
2275 Fput (Qvoid_variable
, Qerror_conditions
,
2276 Fcons (Qvoid_variable
, error_tail
));
2277 Fput (Qvoid_variable
, Qerror_message
,
2278 build_string ("Symbol's value as variable is void"));
2280 Fput (Qsetting_constant
, Qerror_conditions
,
2281 Fcons (Qsetting_constant
, error_tail
));
2282 Fput (Qsetting_constant
, Qerror_message
,
2283 build_string ("Attempt to set a constant symbol"));
2285 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2286 Fcons (Qinvalid_read_syntax
, error_tail
));
2287 Fput (Qinvalid_read_syntax
, Qerror_message
,
2288 build_string ("Invalid read syntax"));
2290 Fput (Qinvalid_function
, Qerror_conditions
,
2291 Fcons (Qinvalid_function
, error_tail
));
2292 Fput (Qinvalid_function
, Qerror_message
,
2293 build_string ("Invalid function"));
2295 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2296 Fcons (Qwrong_number_of_arguments
, error_tail
));
2297 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2298 build_string ("Wrong number of arguments"));
2300 Fput (Qno_catch
, Qerror_conditions
,
2301 Fcons (Qno_catch
, error_tail
));
2302 Fput (Qno_catch
, Qerror_message
,
2303 build_string ("No catch for tag"));
2305 Fput (Qend_of_file
, Qerror_conditions
,
2306 Fcons (Qend_of_file
, error_tail
));
2307 Fput (Qend_of_file
, Qerror_message
,
2308 build_string ("End of file during parsing"));
2310 arith_tail
= Fcons (Qarith_error
, error_tail
);
2311 Fput (Qarith_error
, Qerror_conditions
,
2313 Fput (Qarith_error
, Qerror_message
,
2314 build_string ("Arithmetic error"));
2316 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2317 Fcons (Qbeginning_of_buffer
, error_tail
));
2318 Fput (Qbeginning_of_buffer
, Qerror_message
,
2319 build_string ("Beginning of buffer"));
2321 Fput (Qend_of_buffer
, Qerror_conditions
,
2322 Fcons (Qend_of_buffer
, error_tail
));
2323 Fput (Qend_of_buffer
, Qerror_message
,
2324 build_string ("End of buffer"));
2326 Fput (Qbuffer_read_only
, Qerror_conditions
,
2327 Fcons (Qbuffer_read_only
, error_tail
));
2328 Fput (Qbuffer_read_only
, Qerror_message
,
2329 build_string ("Buffer is read-only"));
2331 #ifdef LISP_FLOAT_TYPE
2332 Qrange_error
= intern ("range-error");
2333 Qdomain_error
= intern ("domain-error");
2334 Qsingularity_error
= intern ("singularity-error");
2335 Qoverflow_error
= intern ("overflow-error");
2336 Qunderflow_error
= intern ("underflow-error");
2338 Fput (Qdomain_error
, Qerror_conditions
,
2339 Fcons (Qdomain_error
, arith_tail
));
2340 Fput (Qdomain_error
, Qerror_message
,
2341 build_string ("Arithmetic domain error"));
2343 Fput (Qrange_error
, Qerror_conditions
,
2344 Fcons (Qrange_error
, arith_tail
));
2345 Fput (Qrange_error
, Qerror_message
,
2346 build_string ("Arithmetic range error"));
2348 Fput (Qsingularity_error
, Qerror_conditions
,
2349 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2350 Fput (Qsingularity_error
, Qerror_message
,
2351 build_string ("Arithmetic singularity error"));
2353 Fput (Qoverflow_error
, Qerror_conditions
,
2354 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2355 Fput (Qoverflow_error
, Qerror_message
,
2356 build_string ("Arithmetic overflow error"));
2358 Fput (Qunderflow_error
, Qerror_conditions
,
2359 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2360 Fput (Qunderflow_error
, Qerror_message
,
2361 build_string ("Arithmetic underflow error"));
2363 staticpro (&Qrange_error
);
2364 staticpro (&Qdomain_error
);
2365 staticpro (&Qsingularity_error
);
2366 staticpro (&Qoverflow_error
);
2367 staticpro (&Qunderflow_error
);
2368 #endif /* LISP_FLOAT_TYPE */
2372 staticpro (&Qquote
);
2373 staticpro (&Qlambda
);
2375 staticpro (&Qunbound
);
2376 staticpro (&Qerror_conditions
);
2377 staticpro (&Qerror_message
);
2378 staticpro (&Qtop_level
);
2380 staticpro (&Qerror
);
2382 staticpro (&Qwrong_type_argument
);
2383 staticpro (&Qargs_out_of_range
);
2384 staticpro (&Qvoid_function
);
2385 staticpro (&Qcyclic_function_indirection
);
2386 staticpro (&Qvoid_variable
);
2387 staticpro (&Qsetting_constant
);
2388 staticpro (&Qinvalid_read_syntax
);
2389 staticpro (&Qwrong_number_of_arguments
);
2390 staticpro (&Qinvalid_function
);
2391 staticpro (&Qno_catch
);
2392 staticpro (&Qend_of_file
);
2393 staticpro (&Qarith_error
);
2394 staticpro (&Qbeginning_of_buffer
);
2395 staticpro (&Qend_of_buffer
);
2396 staticpro (&Qbuffer_read_only
);
2397 staticpro (&Qmark_inactive
);
2399 staticpro (&Qlistp
);
2400 staticpro (&Qconsp
);
2401 staticpro (&Qsymbolp
);
2402 staticpro (&Qintegerp
);
2403 staticpro (&Qnatnump
);
2404 staticpro (&Qwholenump
);
2405 staticpro (&Qstringp
);
2406 staticpro (&Qarrayp
);
2407 staticpro (&Qsequencep
);
2408 staticpro (&Qbufferp
);
2409 staticpro (&Qvectorp
);
2410 staticpro (&Qchar_or_string_p
);
2411 staticpro (&Qmarkerp
);
2412 staticpro (&Qbuffer_or_string_p
);
2413 staticpro (&Qinteger_or_marker_p
);
2414 #ifdef LISP_FLOAT_TYPE
2415 staticpro (&Qfloatp
);
2416 staticpro (&Qnumberp
);
2417 staticpro (&Qnumber_or_marker_p
);
2418 #endif /* LISP_FLOAT_TYPE */
2420 staticpro (&Qboundp
);
2421 staticpro (&Qfboundp
);
2423 staticpro (&Qad_advice_info
);
2424 staticpro (&Qad_activate
);
2426 /* Types that type-of returns. */
2427 Qinteger
= intern ("integer");
2428 Qsymbol
= intern ("symbol");
2429 Qstring
= intern ("string");
2430 Qcons
= intern ("cons");
2431 Qmarker
= intern ("marker");
2432 Qoverlay
= intern ("overlay");
2433 Qfloat
= intern ("float");
2434 Qwindow_configuration
= intern ("window-configuration");
2435 Qprocess
= intern ("process");
2436 Qwindow
= intern ("window");
2437 /* Qsubr = intern ("subr"); */
2438 Qcompiled_function
= intern ("compiled-function");
2439 Qbuffer
= intern ("buffer");
2440 Qframe
= intern ("frame");
2441 Qvector
= intern ("vector");
2443 staticpro (&Qinteger
);
2444 staticpro (&Qsymbol
);
2445 staticpro (&Qstring
);
2447 staticpro (&Qmarker
);
2448 staticpro (&Qoverlay
);
2449 staticpro (&Qfloat
);
2450 staticpro (&Qwindow_configuration
);
2451 staticpro (&Qprocess
);
2452 staticpro (&Qwindow
);
2453 /* staticpro (&Qsubr); */
2454 staticpro (&Qcompiled_function
);
2455 staticpro (&Qbuffer
);
2456 staticpro (&Qframe
);
2457 staticpro (&Qvector
);
2461 defsubr (&Stype_of
);
2466 defsubr (&Sintegerp
);
2467 defsubr (&Sinteger_or_marker_p
);
2468 defsubr (&Snumberp
);
2469 defsubr (&Snumber_or_marker_p
);
2470 #ifdef LISP_FLOAT_TYPE
2472 #endif /* LISP_FLOAT_TYPE */
2473 defsubr (&Snatnump
);
2474 defsubr (&Ssymbolp
);
2475 defsubr (&Sstringp
);
2476 defsubr (&Svectorp
);
2478 defsubr (&Ssequencep
);
2479 defsubr (&Sbufferp
);
2480 defsubr (&Smarkerp
);
2482 defsubr (&Sbyte_code_function_p
);
2483 defsubr (&Schar_or_string_p
);
2486 defsubr (&Scar_safe
);
2487 defsubr (&Scdr_safe
);
2490 defsubr (&Ssymbol_function
);
2491 defsubr (&Sindirect_function
);
2492 defsubr (&Ssymbol_plist
);
2493 defsubr (&Ssymbol_name
);
2494 defsubr (&Smakunbound
);
2495 defsubr (&Sfmakunbound
);
2497 defsubr (&Sfboundp
);
2499 defsubr (&Sdefalias
);
2500 defsubr (&Sdefine_function
);
2501 defsubr (&Ssetplist
);
2502 defsubr (&Ssymbol_value
);
2504 defsubr (&Sdefault_boundp
);
2505 defsubr (&Sdefault_value
);
2506 defsubr (&Sset_default
);
2507 defsubr (&Ssetq_default
);
2508 defsubr (&Smake_variable_buffer_local
);
2509 defsubr (&Smake_local_variable
);
2510 defsubr (&Skill_local_variable
);
2511 defsubr (&Slocal_variable_p
);
2512 defsubr (&Slocal_variable_if_set_p
);
2515 defsubr (&Snumber_to_string
);
2516 defsubr (&Sstring_to_number
);
2517 defsubr (&Seqlsign
);
2541 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2549 /* USG systems forget handlers when they are used;
2550 must reestablish each time */
2551 signal (signo
, arith_error
);
2554 /* VMS systems are like USG. */
2555 signal (signo
, arith_error
);
2559 #else /* not BSD4_1 */
2560 sigsetmask (SIGEMPTYMASK
);
2561 #endif /* not BSD4_1 */
2563 Fsignal (Qarith_error
, Qnil
);
2568 /* Don't do this if just dumping out.
2569 We don't want to call `signal' in this case
2570 so that we don't have trouble with dumping
2571 signal-delivering routines in an inconsistent state. */
2575 #endif /* CANNOT_DUMP */
2576 signal (SIGFPE
, arith_error
);
2579 signal (SIGEMT
, arith_error
);