1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97, 1998 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, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
34 #include "syssignal.h"
36 #ifdef LISP_FLOAT_TYPE
43 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
44 #ifndef IEEE_FLOATING_POINT
45 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
46 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
47 #define IEEE_FLOATING_POINT 1
49 #define IEEE_FLOATING_POINT 0
53 /* Work around a problem that happens because math.h on hpux 7
54 defines two static variables--which, in Emacs, are not really static,
55 because `static' is defined as nothing. The problem is that they are
56 here, in floatfns.c, and in lread.c.
57 These macros prevent the name conflict. */
58 #if defined (HPUX) && !defined (HPUX8)
59 #define _MAXLDBL data_c_maxldbl
60 #define _NMAXLDBL data_c_nmaxldbl
64 #endif /* LISP_FLOAT_TYPE */
67 extern double atof ();
70 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
71 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
72 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
73 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
74 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
75 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
76 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
77 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
78 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
79 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
80 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
81 Lisp_Object Qbuffer_or_string_p
;
82 Lisp_Object Qboundp
, Qfboundp
;
83 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
86 Lisp_Object Qad_advice_info
, Qad_activate
;
88 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
89 Lisp_Object Qoverflow_error
, Qunderflow_error
;
91 #ifdef LISP_FLOAT_TYPE
93 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
96 static Lisp_Object Qinteger
, Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
97 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
99 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
100 static Lisp_Object Qchar_table
, Qbool_vector
;
102 static Lisp_Object
swap_in_symval_forwarding ();
104 Lisp_Object
set_internal ();
107 wrong_type_argument (predicate
, value
)
108 register Lisp_Object predicate
, value
;
110 register Lisp_Object tem
;
113 if (!EQ (Vmocklisp_arguments
, Qt
))
115 if (STRINGP (value
) &&
116 (EQ (predicate
, Qintegerp
) || EQ (predicate
, Qinteger_or_marker_p
)))
117 return Fstring_to_number (value
, Qnil
);
118 if (INTEGERP (value
) && EQ (predicate
, Qstringp
))
119 return Fnumber_to_string (value
);
122 /* If VALUE is not even a valid Lisp object, abort here
123 where we can get a backtrace showing where it came from. */
124 if ((unsigned int) XGCTYPE (value
) >= Lisp_Type_Limit
)
127 value
= Fsignal (Qwrong_type_argument
, Fcons (predicate
, Fcons (value
, Qnil
)));
128 tem
= call1 (predicate
, value
);
136 error ("Attempt to modify read-only object");
140 args_out_of_range (a1
, a2
)
144 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Qnil
)));
148 args_out_of_range_3 (a1
, a2
, a3
)
149 Lisp_Object a1
, a2
, a3
;
152 Fsignal (Qargs_out_of_range
, Fcons (a1
, Fcons (a2
, Fcons (a3
, Qnil
))));
155 /* On some machines, XINT needs a temporary location.
156 Here it is, in case it is needed. */
158 int sign_extend_temp
;
160 /* On a few machines, XINT can only be done by calling this. */
163 sign_extend_lisp_int (num
)
166 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
167 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
169 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
172 /* Data type predicates */
174 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
175 "Return t if the two args are the same Lisp object.")
177 Lisp_Object obj1
, obj2
;
184 DEFUN ("null", Fnull
, Snull
, 1, 1, 0, "Return t if OBJECT is nil.")
193 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
194 "Return a symbol representing the type of OBJECT.\n\
195 The symbol returned names the object's basic type;\n\
196 for example, (type-of 1) returns `integer'.")
200 switch (XGCTYPE (object
))
215 switch (XMISCTYPE (object
))
217 case Lisp_Misc_Marker
:
219 case Lisp_Misc_Overlay
:
221 case Lisp_Misc_Float
:
226 case Lisp_Vectorlike
:
227 if (GC_WINDOW_CONFIGURATIONP (object
))
228 return Qwindow_configuration
;
229 if (GC_PROCESSP (object
))
231 if (GC_WINDOWP (object
))
233 if (GC_SUBRP (object
))
235 if (GC_COMPILEDP (object
))
236 return Qcompiled_function
;
237 if (GC_BUFFERP (object
))
239 if (GC_CHAR_TABLE_P (object
))
241 if (GC_BOOL_VECTOR_P (object
))
243 if (GC_FRAMEP (object
))
247 #ifdef LISP_FLOAT_TYPE
257 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0, "Return t if OBJECT is a cons cell.")
266 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
267 "Return t if OBJECT is not a cons cell. This includes nil.")
276 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
277 "Return t if OBJECT is a list. This includes nil.")
281 if (CONSP (object
) || NILP (object
))
286 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
287 "Return t if OBJECT is not a list. Lists include nil.")
291 if (CONSP (object
) || NILP (object
))
296 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
297 "Return t if OBJECT is a symbol.")
301 if (SYMBOLP (object
))
306 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
307 "Return t if OBJECT is a vector.")
311 if (VECTORP (object
))
316 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
317 "Return t if OBJECT is a string.")
321 if (STRINGP (object
))
326 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
327 1, 1, 0, "Return t if OBJECT is a multibyte string.")
331 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
336 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
337 "Return t if OBJECT is a char-table.")
341 if (CHAR_TABLE_P (object
))
346 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
347 Svector_or_char_table_p
, 1, 1, 0,
348 "Return t if OBJECT is a char-table or vector.")
352 if (VECTORP (object
) || CHAR_TABLE_P (object
))
357 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
361 if (BOOL_VECTOR_P (object
))
366 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
370 if (VECTORP (object
) || STRINGP (object
)
371 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
376 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
377 "Return t if OBJECT is a sequence (list or array).")
379 register Lisp_Object object
;
381 if (CONSP (object
) || NILP (object
) || VECTORP (object
) || STRINGP (object
)
382 || CHAR_TABLE_P (object
) || BOOL_VECTOR_P (object
))
387 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
391 if (BUFFERP (object
))
396 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
400 if (MARKERP (object
))
405 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0, "Return t if OBJECT is a built-in function.")
414 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
415 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
419 if (COMPILEDP (object
))
424 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
425 "Return t if OBJECT is a character (an integer) or a string.")
427 register Lisp_Object object
;
429 if (INTEGERP (object
) || STRINGP (object
))
434 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0, "Return t if OBJECT is an integer.")
438 if (INTEGERP (object
))
443 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
444 "Return t if OBJECT is an integer or a marker (editor pointer).")
446 register Lisp_Object object
;
448 if (MARKERP (object
) || INTEGERP (object
))
453 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
454 "Return t if OBJECT is a nonnegative integer.")
458 if (NATNUMP (object
))
463 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
464 "Return t if OBJECT is a number (floating point or integer).")
468 if (NUMBERP (object
))
474 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
475 Snumber_or_marker_p
, 1, 1, 0,
476 "Return t if OBJECT is a number or a marker.")
480 if (NUMBERP (object
) || MARKERP (object
))
485 #ifdef LISP_FLOAT_TYPE
486 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
487 "Return t if OBJECT is a floating point number.")
495 #endif /* LISP_FLOAT_TYPE */
497 /* Extract and set components of lists */
499 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
500 "Return the car of LIST. If arg is nil, return nil.\n\
501 Error if arg is not nil and not a cons cell. See also `car-safe'.")
503 register Lisp_Object list
;
508 return XCONS (list
)->car
;
509 else if (EQ (list
, Qnil
))
512 list
= wrong_type_argument (Qlistp
, list
);
516 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
517 "Return the car of OBJECT if it is a cons cell, or else nil.")
522 return XCONS (object
)->car
;
527 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
528 "Return the cdr of LIST. If arg is nil, return nil.\n\
529 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
532 register Lisp_Object list
;
537 return XCONS (list
)->cdr
;
538 else if (EQ (list
, Qnil
))
541 list
= wrong_type_argument (Qlistp
, list
);
545 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
546 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
551 return XCONS (object
)->cdr
;
556 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
557 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
559 register Lisp_Object cell
, newcar
;
562 cell
= wrong_type_argument (Qconsp
, cell
);
565 XCONS (cell
)->car
= newcar
;
569 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
570 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
572 register Lisp_Object cell
, newcdr
;
575 cell
= wrong_type_argument (Qconsp
, cell
);
578 XCONS (cell
)->cdr
= newcdr
;
582 /* Extract and set components of symbols */
584 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0, "Return t if SYMBOL's value is not void.")
586 register Lisp_Object symbol
;
588 Lisp_Object valcontents
;
589 CHECK_SYMBOL (symbol
, 0);
591 valcontents
= XSYMBOL (symbol
)->value
;
593 if (BUFFER_LOCAL_VALUEP (valcontents
)
594 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
595 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
597 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
600 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
602 register Lisp_Object symbol
;
604 CHECK_SYMBOL (symbol
, 0);
605 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
608 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0, "Make SYMBOL's value be void.")
610 register Lisp_Object symbol
;
612 CHECK_SYMBOL (symbol
, 0);
613 if (NILP (symbol
) || EQ (symbol
, Qt
))
614 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
615 Fset (symbol
, Qunbound
);
619 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0, "Make SYMBOL's function definition be void.")
621 register Lisp_Object symbol
;
623 CHECK_SYMBOL (symbol
, 0);
624 if (NILP (symbol
) || EQ (symbol
, Qt
))
625 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
626 XSYMBOL (symbol
)->function
= Qunbound
;
630 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
631 "Return SYMBOL's function definition. Error if that is void.")
633 register Lisp_Object symbol
;
635 CHECK_SYMBOL (symbol
, 0);
636 if (EQ (XSYMBOL (symbol
)->function
, Qunbound
))
637 return Fsignal (Qvoid_function
, Fcons (symbol
, Qnil
));
638 return XSYMBOL (symbol
)->function
;
641 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0, "Return SYMBOL's property list.")
643 register Lisp_Object symbol
;
645 CHECK_SYMBOL (symbol
, 0);
646 return XSYMBOL (symbol
)->plist
;
649 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0, "Return SYMBOL's name, a string.")
651 register Lisp_Object symbol
;
653 register Lisp_Object name
;
655 CHECK_SYMBOL (symbol
, 0);
656 XSETSTRING (name
, XSYMBOL (symbol
)->name
);
660 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
661 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
663 register Lisp_Object symbol
, definition
;
665 CHECK_SYMBOL (symbol
, 0);
666 if (NILP (symbol
) || EQ (symbol
, Qt
))
667 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
668 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
669 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
671 XSYMBOL (symbol
)->function
= definition
;
672 /* Handle automatic advice activation */
673 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
675 call2 (Qad_activate
, symbol
, Qnil
);
676 definition
= XSYMBOL (symbol
)->function
;
681 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 2, 0,
682 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
683 Associates the function with the current load file, if any.")
685 register Lisp_Object symbol
, definition
;
687 CHECK_SYMBOL (symbol
, 0);
688 if (!NILP (Vautoload_queue
) && !EQ (XSYMBOL (symbol
)->function
, Qunbound
))
689 Vautoload_queue
= Fcons (Fcons (symbol
, XSYMBOL (symbol
)->function
),
691 XSYMBOL (symbol
)->function
= definition
;
692 /* Handle automatic advice activation */
693 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
695 call2 (Qad_activate
, symbol
, Qnil
);
696 definition
= XSYMBOL (symbol
)->function
;
698 LOADHIST_ATTACH (symbol
);
702 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
703 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
705 register Lisp_Object symbol
, newplist
;
707 CHECK_SYMBOL (symbol
, 0);
708 XSYMBOL (symbol
)->plist
= newplist
;
713 /* Getting and setting values of symbols */
715 /* Given the raw contents of a symbol value cell,
716 return the Lisp value of the symbol.
717 This does not handle buffer-local variables; use
718 swap_in_symval_forwarding for that. */
721 do_symval_forwarding (valcontents
)
722 register Lisp_Object valcontents
;
724 register Lisp_Object val
;
726 if (MISCP (valcontents
))
727 switch (XMISCTYPE (valcontents
))
729 case Lisp_Misc_Intfwd
:
730 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
733 case Lisp_Misc_Boolfwd
:
734 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
736 case Lisp_Misc_Objfwd
:
737 return *XOBJFWD (valcontents
)->objvar
;
739 case Lisp_Misc_Buffer_Objfwd
:
740 offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
741 return *(Lisp_Object
*)(offset
+ (char *)current_buffer
);
743 case Lisp_Misc_Kboard_Objfwd
:
744 offset
= XKBOARD_OBJFWD (valcontents
)->offset
;
745 return *(Lisp_Object
*)(offset
+ (char *)current_kboard
);
750 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
751 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
752 buffer-independent contents of the value cell: forwarded just one
753 step past the buffer-localness. */
756 store_symval_forwarding (symbol
, valcontents
, newval
)
758 register Lisp_Object valcontents
, newval
;
760 switch (SWITCH_ENUM_CAST (XTYPE (valcontents
)))
763 switch (XMISCTYPE (valcontents
))
765 case Lisp_Misc_Intfwd
:
766 CHECK_NUMBER (newval
, 1);
767 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
768 if (*XINTFWD (valcontents
)->intvar
!= XINT (newval
))
769 error ("Value out of range for variable `%s'",
770 XSYMBOL (symbol
)->name
->data
);
773 case Lisp_Misc_Boolfwd
:
774 *XBOOLFWD (valcontents
)->boolvar
= NILP (newval
) ? 0 : 1;
777 case Lisp_Misc_Objfwd
:
778 *XOBJFWD (valcontents
)->objvar
= newval
;
781 case Lisp_Misc_Buffer_Objfwd
:
783 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
786 type
= *(Lisp_Object
*)(offset
+ (char *)&buffer_local_types
);
787 if (! NILP (type
) && ! NILP (newval
)
788 && XTYPE (newval
) != XINT (type
))
789 buffer_slot_type_mismatch (offset
);
791 *(Lisp_Object
*)(offset
+ (char *)current_buffer
) = newval
;
795 case Lisp_Misc_Kboard_Objfwd
:
796 (*(Lisp_Object
*)((char *)current_kboard
797 + XKBOARD_OBJFWD (valcontents
)->offset
))
808 valcontents
= XSYMBOL (symbol
)->value
;
809 if (BUFFER_LOCAL_VALUEP (valcontents
)
810 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
811 XBUFFER_LOCAL_VALUE (valcontents
)->car
= newval
;
813 XSYMBOL (symbol
)->value
= newval
;
817 /* Set up the buffer-local symbol SYMBOL for validity in the current
818 buffer. VALCONTENTS is the contents of its value cell.
819 Return the value forwarded one step past the buffer-local indicator. */
822 swap_in_symval_forwarding (symbol
, valcontents
)
823 Lisp_Object symbol
, valcontents
;
825 /* valcontents is a pointer to a struct resembling the cons
826 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
828 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
829 local_var_alist, that being the element whose car is this
830 variable. Or it can be a pointer to the
831 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
832 an element in its alist for this variable.
834 If the current buffer is not BUFFER, we store the current
835 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
836 appropriate alist element for the buffer now current and set up
837 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
838 element, and store into BUFFER.
840 Note that REALVALUE can be a forwarding pointer. */
842 register Lisp_Object tem1
;
843 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
845 if (NILP (tem1
) || current_buffer
!= XBUFFER (tem1
))
847 tem1
= XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
849 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
850 tem1
= assq_no_quit (symbol
, current_buffer
->local_var_alist
);
852 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
853 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
= tem1
;
854 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
856 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
859 return XBUFFER_LOCAL_VALUE (valcontents
)->car
;
862 /* Find the value of a symbol, returning Qunbound if it's not bound.
863 This is helpful for code which just wants to get a variable's value
864 if it has one, without signaling an error.
865 Note that it must not be possible to quit
866 within this function. Great care is required for this. */
869 find_symbol_value (symbol
)
872 register Lisp_Object valcontents
, tem1
;
873 register Lisp_Object val
;
874 CHECK_SYMBOL (symbol
, 0);
875 valcontents
= XSYMBOL (symbol
)->value
;
877 if (BUFFER_LOCAL_VALUEP (valcontents
)
878 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
879 valcontents
= swap_in_symval_forwarding (symbol
, valcontents
);
881 if (MISCP (valcontents
))
883 switch (XMISCTYPE (valcontents
))
885 case Lisp_Misc_Intfwd
:
886 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
889 case Lisp_Misc_Boolfwd
:
890 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
892 case Lisp_Misc_Objfwd
:
893 return *XOBJFWD (valcontents
)->objvar
;
895 case Lisp_Misc_Buffer_Objfwd
:
896 return *(Lisp_Object
*)(XBUFFER_OBJFWD (valcontents
)->offset
897 + (char *)current_buffer
);
899 case Lisp_Misc_Kboard_Objfwd
:
900 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
901 + (char *)current_kboard
);
908 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
909 "Return SYMBOL's value. Error if that is void.")
915 val
= find_symbol_value (symbol
);
916 if (EQ (val
, Qunbound
))
917 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
922 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
923 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
925 register Lisp_Object symbol
, newval
;
927 return set_internal (symbol
, newval
, 0);
930 /* Store the value NEWVAL into SYMBOL.
931 If BINDFLAG is zero, then if this symbol is supposed to become
932 local in every buffer where it is set, then we make it local.
933 If BINDFLAG is nonzero, we don't do that. */
936 set_internal (symbol
, newval
, bindflag
)
937 register Lisp_Object symbol
, newval
;
940 int voide
= EQ (newval
, Qunbound
);
942 register Lisp_Object valcontents
, tem1
, current_alist_element
;
944 CHECK_SYMBOL (symbol
, 0);
945 if (NILP (symbol
) || EQ (symbol
, Qt
))
946 return Fsignal (Qsetting_constant
, Fcons (symbol
, Qnil
));
947 valcontents
= XSYMBOL (symbol
)->value
;
949 if (BUFFER_OBJFWDP (valcontents
))
951 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
952 register int mask
= XINT (*((Lisp_Object
*)
953 (idx
+ (char *)&buffer_local_flags
)));
955 current_buffer
->local_var_flags
|= mask
;
958 else if (BUFFER_LOCAL_VALUEP (valcontents
)
959 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
961 /* valcontents is actually a pointer to a struct resembling a cons,
962 with contents something like:
963 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
965 BUFFER is the last buffer for which this symbol's value was
968 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
969 local_var_alist, that being the element whose car is this
970 variable. Or it can be a pointer to the
971 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
972 have an element in its alist for this variable (that is, if
973 BUFFER sees the default value of this variable).
975 If we want to examine or set the value and BUFFER is current,
976 we just examine or set REALVALUE. If BUFFER is not current, we
977 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
978 then find the appropriate alist element for the buffer now
979 current and set up CURRENT-ALIST-ELEMENT. Then we set
980 REALVALUE out of that element, and store into BUFFER.
982 If we are setting the variable and the current buffer does
983 not have an alist entry for this variable, an alist entry is
986 Note that REALVALUE can be a forwarding pointer. Each time
987 it is examined or set, forwarding must be done. */
989 /* What value are we caching right now? */
990 current_alist_element
=
991 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
993 /* If the current buffer is not the buffer whose binding is
994 currently cached, or if it's a Lisp_Buffer_Local_Value and
995 we're looking at the default value, the cache is invalid; we
996 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
998 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
))
999 || (BUFFER_LOCAL_VALUEP (valcontents
)
1000 && EQ (XCONS (current_alist_element
)->car
,
1001 current_alist_element
)))
1003 /* Write out the cached value for the old buffer; copy it
1004 back to its alist element. This works if the current
1005 buffer only sees the default value, too. */
1006 Fsetcdr (current_alist_element
,
1007 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
));
1009 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1010 tem1
= Fassq (symbol
, current_buffer
->local_var_alist
);
1013 /* This buffer still sees the default value. */
1015 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1016 or if this is `let' rather than `set',
1017 make CURRENT-ALIST-ELEMENT point to itself,
1018 indicating that we're seeing the default value. */
1019 if (bindflag
|| SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1020 tem1
= XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
;
1022 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1023 give this buffer a new assoc for a local value and set
1024 CURRENT-ALIST-ELEMENT to point to that. */
1027 tem1
= Fcons (symbol
, Fcdr (current_alist_element
));
1028 current_buffer
->local_var_alist
=
1029 Fcons (tem1
, current_buffer
->local_var_alist
);
1032 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1033 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
1036 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1037 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
,
1040 valcontents
= XBUFFER_LOCAL_VALUE (valcontents
)->car
;
1043 /* If storing void (making the symbol void), forward only through
1044 buffer-local indicator, not through Lisp_Objfwd, etc. */
1046 store_symval_forwarding (symbol
, Qnil
, newval
);
1048 store_symval_forwarding (symbol
, valcontents
, newval
);
1053 /* Access or set a buffer-local symbol's default value. */
1055 /* Return the default value of SYMBOL, but don't check for voidness.
1056 Return Qunbound if it is void. */
1059 default_value (symbol
)
1062 register Lisp_Object valcontents
;
1064 CHECK_SYMBOL (symbol
, 0);
1065 valcontents
= XSYMBOL (symbol
)->value
;
1067 /* For a built-in buffer-local variable, get the default value
1068 rather than letting do_symval_forwarding get the current value. */
1069 if (BUFFER_OBJFWDP (valcontents
))
1071 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1073 if (XINT (*(Lisp_Object
*) (idx
+ (char *) &buffer_local_flags
)) != 0)
1074 return *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1077 /* Handle user-created local variables. */
1078 if (BUFFER_LOCAL_VALUEP (valcontents
)
1079 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1081 /* If var is set up for a buffer that lacks a local value for it,
1082 the current value is nominally the default value.
1083 But the current value slot may be more up to date, since
1084 ordinary setq stores just that slot. So use that. */
1085 Lisp_Object current_alist_element
, alist_element_car
;
1086 current_alist_element
1087 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1088 alist_element_car
= XCONS (current_alist_element
)->car
;
1089 if (EQ (alist_element_car
, current_alist_element
))
1090 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents
)->car
);
1092 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
;
1094 /* For other variables, get the current value. */
1095 return do_symval_forwarding (valcontents
);
1098 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1099 "Return t if SYMBOL has a non-void default value.\n\
1100 This is the value that is seen in buffers that do not have their own values\n\
1101 for this variable.")
1105 register Lisp_Object value
;
1107 value
= default_value (symbol
);
1108 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1111 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1112 "Return SYMBOL's default value.\n\
1113 This is the value that is seen in buffers that do not have their own values\n\
1114 for this variable. The default value is meaningful for variables with\n\
1115 local bindings in certain buffers.")
1119 register Lisp_Object value
;
1121 value
= default_value (symbol
);
1122 if (EQ (value
, Qunbound
))
1123 return Fsignal (Qvoid_variable
, Fcons (symbol
, Qnil
));
1127 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1128 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1129 The default value is seen in buffers that do not have their own values\n\
1130 for this variable.")
1132 Lisp_Object symbol
, value
;
1134 register Lisp_Object valcontents
, current_alist_element
, alist_element_buffer
;
1136 CHECK_SYMBOL (symbol
, 0);
1137 valcontents
= XSYMBOL (symbol
)->value
;
1139 /* Handle variables like case-fold-search that have special slots
1140 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1142 if (BUFFER_OBJFWDP (valcontents
))
1144 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1145 register struct buffer
*b
;
1146 register int mask
= XINT (*((Lisp_Object
*)
1147 (idx
+ (char *)&buffer_local_flags
)));
1151 *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
) = value
;
1152 for (b
= all_buffers
; b
; b
= b
->next
)
1153 if (!(b
->local_var_flags
& mask
))
1154 *(Lisp_Object
*)(idx
+ (char *) b
) = value
;
1159 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1160 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1161 return Fset (symbol
, value
);
1163 /* Store new value into the DEFAULT-VALUE slot */
1164 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->cdr
= value
;
1166 /* If that slot is current, we must set the REALVALUE slot too */
1167 current_alist_element
1168 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->cdr
)->car
;
1169 alist_element_buffer
= Fcar (current_alist_element
);
1170 if (EQ (alist_element_buffer
, current_alist_element
))
1171 store_symval_forwarding (symbol
, XBUFFER_LOCAL_VALUE (valcontents
)->car
,
1177 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 2, UNEVALLED
, 0,
1178 "Set the default value of variable VAR to VALUE.\n\
1179 VAR, the variable name, is literal (not evaluated);\n\
1180 VALUE is an expression and it is evaluated.\n\
1181 The default value of a variable is seen in buffers\n\
1182 that do not have their own values for the variable.\n\
1184 More generally, you can use multiple variables and values, as in\n\
1185 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1186 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1187 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1192 register Lisp_Object args_left
;
1193 register Lisp_Object val
, symbol
;
1194 struct gcpro gcpro1
;
1204 val
= Feval (Fcar (Fcdr (args_left
)));
1205 symbol
= Fcar (args_left
);
1206 Fset_default (symbol
, val
);
1207 args_left
= Fcdr (Fcdr (args_left
));
1209 while (!NILP (args_left
));
1215 /* Lisp functions for creating and removing buffer-local variables. */
1217 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1218 1, 1, "vMake Variable Buffer Local: ",
1219 "Make VARIABLE have a separate value for each buffer.\n\
1220 At any time, the value for the current buffer is in effect.\n\
1221 There is also a default value which is seen in any buffer which has not yet\n\
1222 set its own value.\n\
1223 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1224 for the current buffer if it was previously using the default value.\n\
1225 The function `default-value' gets the default value and `set-default' sets it.")
1227 register Lisp_Object variable
;
1229 register Lisp_Object tem
, valcontents
, newval
;
1231 CHECK_SYMBOL (variable
, 0);
1233 valcontents
= XSYMBOL (variable
)->value
;
1234 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1235 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1237 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1239 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1241 XMISCTYPE (XSYMBOL (variable
)->value
) = Lisp_Misc_Buffer_Local_Value
;
1244 if (EQ (valcontents
, Qunbound
))
1245 XSYMBOL (variable
)->value
= Qnil
;
1246 tem
= Fcons (Qnil
, Fsymbol_value (variable
));
1247 XCONS (tem
)->car
= tem
;
1248 newval
= allocate_misc ();
1249 XMISCTYPE (newval
) = Lisp_Misc_Buffer_Local_Value
;
1250 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1251 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Fcurrent_buffer (), tem
);
1252 XSYMBOL (variable
)->value
= newval
;
1256 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1257 1, 1, "vMake Local Variable: ",
1258 "Make VARIABLE have a separate value in the current buffer.\n\
1259 Other buffers will continue to share a common default value.\n\
1260 \(The buffer-local value of VARIABLE starts out as the same value\n\
1261 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1262 See also `make-variable-buffer-local'.\n\n\
1263 If the variable is already arranged to become local when set,\n\
1264 this function causes a local value to exist for this buffer,\n\
1265 just as setting the variable would do.\n\
1267 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1268 Use `make-local-hook' instead.")
1270 register Lisp_Object variable
;
1272 register Lisp_Object tem
, valcontents
;
1274 CHECK_SYMBOL (variable
, 0);
1276 valcontents
= XSYMBOL (variable
)->value
;
1277 if (EQ (variable
, Qnil
) || EQ (variable
, Qt
) || KBOARD_OBJFWDP (valcontents
))
1278 error ("Symbol %s may not be buffer-local", XSYMBOL (variable
)->name
->data
);
1280 if (BUFFER_LOCAL_VALUEP (valcontents
) || BUFFER_OBJFWDP (valcontents
))
1282 tem
= Fboundp (variable
);
1284 /* Make sure the symbol has a local value in this particular buffer,
1285 by setting it to the same value it already has. */
1286 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1289 /* Make sure symbol is set up to hold per-buffer values */
1290 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1293 tem
= Fcons (Qnil
, do_symval_forwarding (valcontents
));
1294 XCONS (tem
)->car
= tem
;
1295 newval
= allocate_misc ();
1296 XMISCTYPE (newval
) = Lisp_Misc_Some_Buffer_Local_Value
;
1297 XBUFFER_LOCAL_VALUE (newval
)->car
= XSYMBOL (variable
)->value
;
1298 XBUFFER_LOCAL_VALUE (newval
)->cdr
= Fcons (Qnil
, tem
);
1299 XSYMBOL (variable
)->value
= newval
;
1301 /* Make sure this buffer has its own value of symbol */
1302 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1305 /* Swap out any local binding for some other buffer, and make
1306 sure the current value is permanently recorded, if it's the
1308 find_symbol_value (variable
);
1310 current_buffer
->local_var_alist
1311 = Fcons (Fcons (variable
, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->cdr
)->cdr
)->cdr
),
1312 current_buffer
->local_var_alist
);
1314 /* Make sure symbol does not think it is set up for this buffer;
1315 force it to look once again for this buffer's value */
1317 Lisp_Object
*pvalbuf
;
1319 valcontents
= XSYMBOL (variable
)->value
;
1321 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1322 if (current_buffer
== XBUFFER (*pvalbuf
))
1327 /* If the symbol forwards into a C variable, then swap in the
1328 variable for this buffer immediately. If C code modifies the
1329 variable before we swap in, then that new value will clobber the
1330 default value the next time we swap. */
1331 valcontents
= XBUFFER_LOCAL_VALUE (XSYMBOL (variable
)->value
)->car
;
1332 if (INTFWDP (valcontents
) || BOOLFWDP (valcontents
) || OBJFWDP (valcontents
))
1333 swap_in_symval_forwarding (variable
, XSYMBOL (variable
)->value
);
1338 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1339 1, 1, "vKill Local Variable: ",
1340 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1341 From now on the default value will apply in this buffer.")
1343 register Lisp_Object variable
;
1345 register Lisp_Object tem
, valcontents
;
1347 CHECK_SYMBOL (variable
, 0);
1349 valcontents
= XSYMBOL (variable
)->value
;
1351 if (BUFFER_OBJFWDP (valcontents
))
1353 register int idx
= XBUFFER_OBJFWD (valcontents
)->offset
;
1354 register int mask
= XINT (*((Lisp_Object
*)
1355 (idx
+ (char *)&buffer_local_flags
)));
1359 *(Lisp_Object
*)(idx
+ (char *) current_buffer
)
1360 = *(Lisp_Object
*)(idx
+ (char *) &buffer_defaults
);
1361 current_buffer
->local_var_flags
&= ~mask
;
1366 if (!BUFFER_LOCAL_VALUEP (valcontents
)
1367 && !SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1370 /* Get rid of this buffer's alist element, if any */
1372 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1374 current_buffer
->local_var_alist
1375 = Fdelq (tem
, current_buffer
->local_var_alist
);
1377 /* If the symbol is set up for the current buffer, recompute its
1378 value. We have to do it now, or else forwarded objects won't
1381 Lisp_Object
*pvalbuf
;
1382 valcontents
= XSYMBOL (variable
)->value
;
1383 pvalbuf
= &XCONS (XBUFFER_LOCAL_VALUE (valcontents
)->cdr
)->car
;
1384 if (current_buffer
== XBUFFER (*pvalbuf
))
1387 find_symbol_value (variable
);
1394 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1396 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1397 BUFFER defaults to the current buffer.")
1399 register Lisp_Object variable
, buffer
;
1401 Lisp_Object valcontents
;
1402 register struct buffer
*buf
;
1405 buf
= current_buffer
;
1408 CHECK_BUFFER (buffer
, 0);
1409 buf
= XBUFFER (buffer
);
1412 CHECK_SYMBOL (variable
, 0);
1414 valcontents
= XSYMBOL (variable
)->value
;
1415 if (BUFFER_LOCAL_VALUEP (valcontents
)
1416 || SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1418 Lisp_Object tail
, elt
;
1419 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1421 elt
= XCONS (tail
)->car
;
1422 if (EQ (variable
, XCONS (elt
)->car
))
1426 if (BUFFER_OBJFWDP (valcontents
))
1428 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1429 int mask
= XINT (*(Lisp_Object
*)(offset
+ (char *)&buffer_local_flags
));
1430 if (mask
== -1 || (buf
->local_var_flags
& mask
))
1436 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1438 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1439 BUFFER defaults to the current buffer.")
1441 register Lisp_Object variable
, buffer
;
1443 Lisp_Object valcontents
;
1444 register struct buffer
*buf
;
1447 buf
= current_buffer
;
1450 CHECK_BUFFER (buffer
, 0);
1451 buf
= XBUFFER (buffer
);
1454 CHECK_SYMBOL (variable
, 0);
1456 valcontents
= XSYMBOL (variable
)->value
;
1458 /* This means that make-variable-buffer-local was done. */
1459 if (BUFFER_LOCAL_VALUEP (valcontents
))
1461 /* All these slots become local if they are set. */
1462 if (BUFFER_OBJFWDP (valcontents
))
1464 if (SOME_BUFFER_LOCAL_VALUEP (valcontents
))
1466 Lisp_Object tail
, elt
;
1467 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1469 elt
= XCONS (tail
)->car
;
1470 if (EQ (variable
, XCONS (elt
)->car
))
1477 /* Find the function at the end of a chain of symbol function indirections. */
1479 /* If OBJECT is a symbol, find the end of its function chain and
1480 return the value found there. If OBJECT is not a symbol, just
1481 return it. If there is a cycle in the function chain, signal a
1482 cyclic-function-indirection error.
1484 This is like Findirect_function, except that it doesn't signal an
1485 error if the chain ends up unbound. */
1487 indirect_function (object
)
1488 register Lisp_Object object
;
1490 Lisp_Object tortoise
, hare
;
1492 hare
= tortoise
= object
;
1496 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1498 hare
= XSYMBOL (hare
)->function
;
1499 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
1501 hare
= XSYMBOL (hare
)->function
;
1503 tortoise
= XSYMBOL (tortoise
)->function
;
1505 if (EQ (hare
, tortoise
))
1506 Fsignal (Qcyclic_function_indirection
, Fcons (object
, Qnil
));
1512 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 1, 0,
1513 "Return the function at the end of OBJECT's function chain.\n\
1514 If OBJECT is a symbol, follow all function indirections and return the final\n\
1515 function binding.\n\
1516 If OBJECT is not a symbol, just return it.\n\
1517 Signal a void-function error if the final symbol is unbound.\n\
1518 Signal a cyclic-function-indirection error if there is a loop in the\n\
1519 function chain of symbols.")
1521 register Lisp_Object object
;
1525 result
= indirect_function (object
);
1527 if (EQ (result
, Qunbound
))
1528 return Fsignal (Qvoid_function
, Fcons (object
, Qnil
));
1532 /* Extract and set vector and string elements */
1534 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
1535 "Return the element of ARRAY at index IDX.\n\
1536 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1537 or a byte-code object. IDX starts at 0.")
1539 register Lisp_Object array
;
1542 register int idxval
;
1544 CHECK_NUMBER (idx
, 1);
1545 idxval
= XINT (idx
);
1546 if (STRINGP (array
))
1551 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1552 args_out_of_range (array
, idx
);
1553 if (! STRING_MULTIBYTE (array
))
1554 return make_number ((unsigned char) XSTRING (array
)->data
[idxval
]);
1555 idxval_byte
= string_char_to_byte (array
, idxval
);
1557 c
= STRING_CHAR (&XSTRING (array
)->data
[idxval_byte
],
1558 XSTRING (array
)->size_byte
- idxval_byte
);
1559 return make_number (c
);
1561 else if (BOOL_VECTOR_P (array
))
1565 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1566 args_out_of_range (array
, idx
);
1568 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1569 return (val
& (1 << (idxval
% BITS_PER_CHAR
)) ? Qt
: Qnil
);
1571 else if (CHAR_TABLE_P (array
))
1576 args_out_of_range (array
, idx
);
1577 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1579 /* For ASCII and 8-bit European characters, the element is
1580 stored in the top table. */
1581 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1583 val
= XCHAR_TABLE (array
)->defalt
;
1584 while (NILP (val
)) /* Follow parents until we find some value. */
1586 array
= XCHAR_TABLE (array
)->parent
;
1589 val
= XCHAR_TABLE (array
)->contents
[idxval
];
1591 val
= XCHAR_TABLE (array
)->defalt
;
1598 Lisp_Object sub_table
;
1600 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1601 if (code
[0] != CHARSET_COMPOSITION
)
1603 if (code
[1] < 32) code
[1] = -1;
1604 else if (code
[2] < 32) code
[2] = -1;
1606 /* Here, the possible range of CODE[0] (== charset ID) is
1607 128..MAX_CHARSET. Since the top level char table contains
1608 data for multibyte characters after 256th element, we must
1609 increment CODE[0] by 128 to get a correct index. */
1611 code
[3] = -1; /* anchor */
1613 try_parent_char_table
:
1615 for (i
= 0; code
[i
] >= 0; i
++)
1617 val
= XCHAR_TABLE (sub_table
)->contents
[code
[i
]];
1618 if (SUB_CHAR_TABLE_P (val
))
1623 val
= XCHAR_TABLE (sub_table
)->defalt
;
1626 array
= XCHAR_TABLE (array
)->parent
;
1628 goto try_parent_char_table
;
1633 /* Here, VAL is a sub char table. We try the default value
1635 val
= XCHAR_TABLE (val
)->defalt
;
1638 array
= XCHAR_TABLE (array
)->parent
;
1640 goto try_parent_char_table
;
1648 if (VECTORP (array
))
1649 size
= XVECTOR (array
)->size
;
1650 else if (COMPILEDP (array
))
1651 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
1653 wrong_type_argument (Qarrayp
, array
);
1655 if (idxval
< 0 || idxval
>= size
)
1656 args_out_of_range (array
, idx
);
1657 return XVECTOR (array
)->contents
[idxval
];
1661 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
1662 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1663 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1665 (array
, idx
, newelt
)
1666 register Lisp_Object array
;
1667 Lisp_Object idx
, newelt
;
1669 register int idxval
;
1671 CHECK_NUMBER (idx
, 1);
1672 idxval
= XINT (idx
);
1673 if (!VECTORP (array
) && !STRINGP (array
) && !BOOL_VECTOR_P (array
)
1674 && ! CHAR_TABLE_P (array
))
1675 array
= wrong_type_argument (Qarrayp
, array
);
1676 CHECK_IMPURE (array
);
1678 if (VECTORP (array
))
1680 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
1681 args_out_of_range (array
, idx
);
1682 XVECTOR (array
)->contents
[idxval
] = newelt
;
1684 else if (BOOL_VECTOR_P (array
))
1688 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
1689 args_out_of_range (array
, idx
);
1691 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
];
1693 if (! NILP (newelt
))
1694 val
|= 1 << (idxval
% BITS_PER_CHAR
);
1696 val
&= ~(1 << (idxval
% BITS_PER_CHAR
));
1697 XBOOL_VECTOR (array
)->data
[idxval
/ BITS_PER_CHAR
] = val
;
1699 else if (CHAR_TABLE_P (array
))
1704 args_out_of_range (array
, idx
);
1705 if (idxval
< CHAR_TABLE_SINGLE_BYTE_SLOTS
)
1706 XCHAR_TABLE (array
)->contents
[idxval
] = newelt
;
1712 SPLIT_NON_ASCII_CHAR (idxval
, code
[0], code
[1], code
[2]);
1713 if (code
[0] != CHARSET_COMPOSITION
)
1715 if (code
[1] < 32) code
[1] = -1;
1716 else if (code
[2] < 32) code
[2] = -1;
1718 /* See the comment of the corresponding part in Faref. */
1720 code
[3] = -1; /* anchor */
1721 for (i
= 0; code
[i
+ 1] >= 0; i
++)
1723 val
= XCHAR_TABLE (array
)->contents
[code
[i
]];
1724 if (SUB_CHAR_TABLE_P (val
))
1730 /* VAL is a leaf. Create a sub char table with the
1731 default value VAL or XCHAR_TABLE (array)->defalt
1732 and look into it. */
1734 temp
= make_sub_char_table (NILP (val
)
1735 ? XCHAR_TABLE (array
)->defalt
1737 XCHAR_TABLE (array
)->contents
[code
[i
]] = temp
;
1741 XCHAR_TABLE (array
)->contents
[code
[i
]] = newelt
;
1744 else if (STRING_MULTIBYTE (array
))
1746 Lisp_Object new_len
;
1747 int c
, idxval_byte
, actual_len
;
1748 unsigned char *p
, *str
;
1750 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1751 args_out_of_range (array
, idx
);
1753 idxval_byte
= string_char_to_byte (array
, idxval
);
1754 p
= &XSTRING (array
)->data
[idxval_byte
];
1757 = MULTIBYTE_FORM_LENGTH (p
, XSTRING (array
)->size_byte
- idxval_byte
);
1758 new_len
= Fchar_bytes (newelt
);
1759 if (actual_len
!= XINT (new_len
))
1760 error ("Attempt to change byte length of a string");
1762 CHAR_STRING (XINT (newelt
), p
, str
);
1764 bcopy (str
, p
, actual_len
);
1768 if (idxval
< 0 || idxval
>= XSTRING (array
)->size
)
1769 args_out_of_range (array
, idx
);
1770 CHECK_NUMBER (newelt
, 2);
1771 XSTRING (array
)->data
[idxval
] = XINT (newelt
);
1777 /* Arithmetic functions */
1779 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
1782 arithcompare (num1
, num2
, comparison
)
1783 Lisp_Object num1
, num2
;
1784 enum comparison comparison
;
1789 #ifdef LISP_FLOAT_TYPE
1790 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
, 0);
1791 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
, 0);
1793 if (FLOATP (num1
) || FLOATP (num2
))
1796 f1
= (FLOATP (num1
)) ? XFLOAT (num1
)->data
: XINT (num1
);
1797 f2
= (FLOATP (num2
)) ? XFLOAT (num2
)->data
: XINT (num2
);
1800 CHECK_NUMBER_COERCE_MARKER (num1
, 0);
1801 CHECK_NUMBER_COERCE_MARKER (num2
, 0);
1802 #endif /* LISP_FLOAT_TYPE */
1807 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
1812 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
1817 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
1822 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
1827 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
1832 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
1841 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
1842 "Return t if two args, both numbers or markers, are equal.")
1844 register Lisp_Object num1
, num2
;
1846 return arithcompare (num1
, num2
, equal
);
1849 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
1850 "Return t if first arg is less than second arg. Both must be numbers or markers.")
1852 register Lisp_Object num1
, num2
;
1854 return arithcompare (num1
, num2
, less
);
1857 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
1858 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
1860 register Lisp_Object num1
, num2
;
1862 return arithcompare (num1
, num2
, grtr
);
1865 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
1866 "Return t if first arg is less than or equal to second arg.\n\
1867 Both must be numbers or markers.")
1869 register Lisp_Object num1
, num2
;
1871 return arithcompare (num1
, num2
, less_or_equal
);
1874 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
1875 "Return t if first arg is greater than or equal to second arg.\n\
1876 Both must be numbers or markers.")
1878 register Lisp_Object num1
, num2
;
1880 return arithcompare (num1
, num2
, grtr_or_equal
);
1883 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
1884 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
1886 register Lisp_Object num1
, num2
;
1888 return arithcompare (num1
, num2
, notequal
);
1891 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0, "Return t if NUMBER is zero.")
1893 register Lisp_Object number
;
1895 #ifdef LISP_FLOAT_TYPE
1896 CHECK_NUMBER_OR_FLOAT (number
, 0);
1898 if (FLOATP (number
))
1900 if (XFLOAT(number
)->data
== 0.0)
1905 CHECK_NUMBER (number
, 0);
1906 #endif /* LISP_FLOAT_TYPE */
1913 /* Convert between long values and pairs of Lisp integers. */
1919 unsigned int top
= i
>> 16;
1920 unsigned int bot
= i
& 0xFFFF;
1922 return make_number (bot
);
1923 if (top
== (unsigned long)-1 >> 16)
1924 return Fcons (make_number (-1), make_number (bot
));
1925 return Fcons (make_number (top
), make_number (bot
));
1932 Lisp_Object top
, bot
;
1935 top
= XCONS (c
)->car
;
1936 bot
= XCONS (c
)->cdr
;
1938 bot
= XCONS (bot
)->car
;
1939 return ((XINT (top
) << 16) | XINT (bot
));
1942 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
1943 "Convert NUMBER to a string by printing it in decimal.\n\
1944 Uses a minus sign if negative.\n\
1945 NUMBER may be an integer or a floating point number.")
1949 char buffer
[VALBITS
];
1951 #ifndef LISP_FLOAT_TYPE
1952 CHECK_NUMBER (number
, 0);
1954 CHECK_NUMBER_OR_FLOAT (number
, 0);
1956 if (FLOATP (number
))
1958 char pigbuf
[350]; /* see comments in float_to_string */
1960 float_to_string (pigbuf
, XFLOAT(number
)->data
);
1961 return build_string (pigbuf
);
1963 #endif /* LISP_FLOAT_TYPE */
1965 if (sizeof (int) == sizeof (EMACS_INT
))
1966 sprintf (buffer
, "%d", XINT (number
));
1967 else if (sizeof (long) == sizeof (EMACS_INT
))
1968 sprintf (buffer
, "%ld", XINT (number
));
1971 return build_string (buffer
);
1975 digit_to_number (character
, base
)
1976 int character
, base
;
1980 if (character
>= '0' && character
<= '9')
1981 digit
= character
- '0';
1982 else if (character
>= 'a' && character
<= 'z')
1983 digit
= character
- 'a' + 10;
1984 else if (character
>= 'A' && character
<= 'Z')
1985 digit
= character
- 'A' + 10;
1995 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
1996 "Convert STRING to a number by parsing it as a decimal number.\n\
1997 This parses both integers and floating point numbers.\n\
1998 It ignores leading spaces and tabs.\n\
2000 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2001 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2002 Floating point numbers always use base 10.")
2004 register Lisp_Object string
, base
;
2006 register unsigned char *p
;
2007 register int b
, digit
, v
= 0;
2010 CHECK_STRING (string
, 0);
2016 CHECK_NUMBER (base
, 1);
2018 if (b
< 2 || b
> 16)
2019 Fsignal (Qargs_out_of_range
, Fcons (base
, Qnil
));
2022 p
= XSTRING (string
)->data
;
2024 /* Skip any whitespace at the front of the number. Some versions of
2025 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2026 while (*p
== ' ' || *p
== '\t')
2037 #ifdef LISP_FLOAT_TYPE
2038 if (isfloat_string (p
))
2039 return make_float (negative
* atof (p
));
2040 #endif /* LISP_FLOAT_TYPE */
2044 int digit
= digit_to_number (*p
++, b
);
2050 return make_number (negative
* v
);
2055 { Aadd
, Asub
, Amult
, Adiv
, Alogand
, Alogior
, Alogxor
, Amax
, Amin
};
2057 extern Lisp_Object
float_arith_driver ();
2058 extern Lisp_Object
fmod_float ();
2061 arith_driver (code
, nargs
, args
)
2064 register Lisp_Object
*args
;
2066 register Lisp_Object val
;
2067 register int argnum
;
2068 register EMACS_INT accum
;
2069 register EMACS_INT next
;
2071 switch (SWITCH_ENUM_CAST (code
))
2084 for (argnum
= 0; argnum
< nargs
; argnum
++)
2086 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2087 #ifdef LISP_FLOAT_TYPE
2088 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2090 if (FLOATP (val
)) /* time to do serious math */
2091 return (float_arith_driver ((double) accum
, argnum
, code
,
2094 CHECK_NUMBER_COERCE_MARKER (val
, argnum
);
2095 #endif /* LISP_FLOAT_TYPE */
2096 args
[argnum
] = val
; /* runs into a compiler bug. */
2097 next
= XINT (args
[argnum
]);
2098 switch (SWITCH_ENUM_CAST (code
))
2100 case Aadd
: accum
+= next
; break;
2102 if (!argnum
&& nargs
!= 1)
2106 case Amult
: accum
*= next
; break;
2108 if (!argnum
) accum
= next
;
2112 Fsignal (Qarith_error
, Qnil
);
2116 case Alogand
: accum
&= next
; break;
2117 case Alogior
: accum
|= next
; break;
2118 case Alogxor
: accum
^= next
; break;
2119 case Amax
: if (!argnum
|| next
> accum
) accum
= next
; break;
2120 case Amin
: if (!argnum
|| next
< accum
) accum
= next
; break;
2124 XSETINT (val
, accum
);
2129 #define isnan(x) ((x) != (x))
2131 #ifdef LISP_FLOAT_TYPE
2134 float_arith_driver (accum
, argnum
, code
, nargs
, args
)
2136 register int argnum
;
2139 register Lisp_Object
*args
;
2141 register Lisp_Object val
;
2144 for (; argnum
< nargs
; argnum
++)
2146 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2147 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
, argnum
);
2151 next
= XFLOAT (val
)->data
;
2155 args
[argnum
] = val
; /* runs into a compiler bug. */
2156 next
= XINT (args
[argnum
]);
2158 switch (SWITCH_ENUM_CAST (code
))
2164 if (!argnum
&& nargs
!= 1)
2176 if (! IEEE_FLOATING_POINT
&& next
== 0)
2177 Fsignal (Qarith_error
, Qnil
);
2184 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2186 if (!argnum
|| isnan (next
) || next
> accum
)
2190 if (!argnum
|| isnan (next
) || next
< accum
)
2196 return make_float (accum
);
2198 #endif /* LISP_FLOAT_TYPE */
2200 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2201 "Return sum of any number of arguments, which are numbers or markers.")
2206 return arith_driver (Aadd
, nargs
, args
);
2209 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2210 "Negate number or subtract numbers or markers.\n\
2211 With one arg, negates it. With more than one arg,\n\
2212 subtracts all but the first from the first.")
2217 return arith_driver (Asub
, nargs
, args
);
2220 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2221 "Returns product of any number of arguments, which are numbers or markers.")
2226 return arith_driver (Amult
, nargs
, args
);
2229 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2230 "Returns first argument divided by all the remaining arguments.\n\
2231 The arguments must be numbers or markers.")
2236 return arith_driver (Adiv
, nargs
, args
);
2239 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2240 "Returns remainder of X divided by Y.\n\
2241 Both must be integers or markers.")
2243 register Lisp_Object x
, y
;
2247 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2248 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2250 if (XFASTINT (y
) == 0)
2251 Fsignal (Qarith_error
, Qnil
);
2253 XSETINT (val
, XINT (x
) % XINT (y
));
2267 /* If the magnitude of the result exceeds that of the divisor, or
2268 the sign of the result does not agree with that of the dividend,
2269 iterate with the reduced value. This does not yield a
2270 particularly accurate result, but at least it will be in the
2271 range promised by fmod. */
2273 r
-= f2
* floor (r
/ f2
);
2274 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2278 #endif /* ! HAVE_FMOD */
2280 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2281 "Returns X modulo Y.\n\
2282 The result falls between zero (inclusive) and Y (exclusive).\n\
2283 Both X and Y must be numbers or markers.")
2285 register Lisp_Object x
, y
;
2290 #ifdef LISP_FLOAT_TYPE
2291 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
, 0);
2292 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
, 1);
2294 if (FLOATP (x
) || FLOATP (y
))
2295 return fmod_float (x
, y
);
2297 #else /* not LISP_FLOAT_TYPE */
2298 CHECK_NUMBER_COERCE_MARKER (x
, 0);
2299 CHECK_NUMBER_COERCE_MARKER (y
, 1);
2300 #endif /* not LISP_FLOAT_TYPE */
2306 Fsignal (Qarith_error
, Qnil
);
2310 /* If the "remainder" comes out with the wrong sign, fix it. */
2311 if (i2
< 0 ? i1
> 0 : i1
< 0)
2318 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2319 "Return largest of all the arguments (which must be numbers or markers).\n\
2320 The value is always a number; markers are converted to numbers.")
2325 return arith_driver (Amax
, nargs
, args
);
2328 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2329 "Return smallest of all the arguments (which must be numbers or markers).\n\
2330 The value is always a number; markers are converted to numbers.")
2335 return arith_driver (Amin
, nargs
, args
);
2338 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2339 "Return bitwise-and of all the arguments.\n\
2340 Arguments may be integers, or markers converted to integers.")
2345 return arith_driver (Alogand
, nargs
, args
);
2348 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2349 "Return bitwise-or of all the arguments.\n\
2350 Arguments may be integers, or markers converted to integers.")
2355 return arith_driver (Alogior
, nargs
, args
);
2358 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2359 "Return bitwise-exclusive-or of all the arguments.\n\
2360 Arguments may be integers, or markers converted to integers.")
2365 return arith_driver (Alogxor
, nargs
, args
);
2368 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2369 "Return VALUE with its bits shifted left by COUNT.\n\
2370 If COUNT is negative, shifting is actually to the right.\n\
2371 In this case, the sign bit is duplicated.")
2373 register Lisp_Object value
, count
;
2375 register Lisp_Object val
;
2377 CHECK_NUMBER (value
, 0);
2378 CHECK_NUMBER (count
, 1);
2380 if (XINT (count
) > 0)
2381 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2383 XSETINT (val
, XINT (value
) >> -XINT (count
));
2387 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2388 "Return VALUE with its bits shifted left by COUNT.\n\
2389 If COUNT is negative, shifting is actually to the right.\n\
2390 In this case, zeros are shifted in on the left.")
2392 register Lisp_Object value
, count
;
2394 register Lisp_Object val
;
2396 CHECK_NUMBER (value
, 0);
2397 CHECK_NUMBER (count
, 1);
2399 if (XINT (count
) > 0)
2400 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2402 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2406 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2407 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2408 Markers are converted to integers.")
2410 register Lisp_Object number
;
2412 #ifdef LISP_FLOAT_TYPE
2413 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2415 if (FLOATP (number
))
2416 return (make_float (1.0 + XFLOAT (number
)->data
));
2418 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2419 #endif /* LISP_FLOAT_TYPE */
2421 XSETINT (number
, XINT (number
) + 1);
2425 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2426 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2427 Markers are converted to integers.")
2429 register Lisp_Object number
;
2431 #ifdef LISP_FLOAT_TYPE
2432 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
, 0);
2434 if (FLOATP (number
))
2435 return (make_float (-1.0 + XFLOAT (number
)->data
));
2437 CHECK_NUMBER_COERCE_MARKER (number
, 0);
2438 #endif /* LISP_FLOAT_TYPE */
2440 XSETINT (number
, XINT (number
) - 1);
2444 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2445 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2447 register Lisp_Object number
;
2449 CHECK_NUMBER (number
, 0);
2450 XSETINT (number
, ~XINT (number
));
2457 Lisp_Object error_tail
, arith_tail
;
2459 Qquote
= intern ("quote");
2460 Qlambda
= intern ("lambda");
2461 Qsubr
= intern ("subr");
2462 Qerror_conditions
= intern ("error-conditions");
2463 Qerror_message
= intern ("error-message");
2464 Qtop_level
= intern ("top-level");
2466 Qerror
= intern ("error");
2467 Qquit
= intern ("quit");
2468 Qwrong_type_argument
= intern ("wrong-type-argument");
2469 Qargs_out_of_range
= intern ("args-out-of-range");
2470 Qvoid_function
= intern ("void-function");
2471 Qcyclic_function_indirection
= intern ("cyclic-function-indirection");
2472 Qvoid_variable
= intern ("void-variable");
2473 Qsetting_constant
= intern ("setting-constant");
2474 Qinvalid_read_syntax
= intern ("invalid-read-syntax");
2476 Qinvalid_function
= intern ("invalid-function");
2477 Qwrong_number_of_arguments
= intern ("wrong-number-of-arguments");
2478 Qno_catch
= intern ("no-catch");
2479 Qend_of_file
= intern ("end-of-file");
2480 Qarith_error
= intern ("arith-error");
2481 Qbeginning_of_buffer
= intern ("beginning-of-buffer");
2482 Qend_of_buffer
= intern ("end-of-buffer");
2483 Qbuffer_read_only
= intern ("buffer-read-only");
2484 Qmark_inactive
= intern ("mark-inactive");
2486 Qlistp
= intern ("listp");
2487 Qconsp
= intern ("consp");
2488 Qsymbolp
= intern ("symbolp");
2489 Qintegerp
= intern ("integerp");
2490 Qnatnump
= intern ("natnump");
2491 Qwholenump
= intern ("wholenump");
2492 Qstringp
= intern ("stringp");
2493 Qarrayp
= intern ("arrayp");
2494 Qsequencep
= intern ("sequencep");
2495 Qbufferp
= intern ("bufferp");
2496 Qvectorp
= intern ("vectorp");
2497 Qchar_or_string_p
= intern ("char-or-string-p");
2498 Qmarkerp
= intern ("markerp");
2499 Qbuffer_or_string_p
= intern ("buffer-or-string-p");
2500 Qinteger_or_marker_p
= intern ("integer-or-marker-p");
2501 Qboundp
= intern ("boundp");
2502 Qfboundp
= intern ("fboundp");
2504 #ifdef LISP_FLOAT_TYPE
2505 Qfloatp
= intern ("floatp");
2506 Qnumberp
= intern ("numberp");
2507 Qnumber_or_marker_p
= intern ("number-or-marker-p");
2508 #endif /* LISP_FLOAT_TYPE */
2510 Qchar_table_p
= intern ("char-table-p");
2511 Qvector_or_char_table_p
= intern ("vector-or-char-table-p");
2513 Qcdr
= intern ("cdr");
2515 /* Handle automatic advice activation */
2516 Qad_advice_info
= intern ("ad-advice-info");
2517 Qad_activate
= intern ("ad-activate");
2519 error_tail
= Fcons (Qerror
, Qnil
);
2521 /* ERROR is used as a signaler for random errors for which nothing else is right */
2523 Fput (Qerror
, Qerror_conditions
,
2525 Fput (Qerror
, Qerror_message
,
2526 build_string ("error"));
2528 Fput (Qquit
, Qerror_conditions
,
2529 Fcons (Qquit
, Qnil
));
2530 Fput (Qquit
, Qerror_message
,
2531 build_string ("Quit"));
2533 Fput (Qwrong_type_argument
, Qerror_conditions
,
2534 Fcons (Qwrong_type_argument
, error_tail
));
2535 Fput (Qwrong_type_argument
, Qerror_message
,
2536 build_string ("Wrong type argument"));
2538 Fput (Qargs_out_of_range
, Qerror_conditions
,
2539 Fcons (Qargs_out_of_range
, error_tail
));
2540 Fput (Qargs_out_of_range
, Qerror_message
,
2541 build_string ("Args out of range"));
2543 Fput (Qvoid_function
, Qerror_conditions
,
2544 Fcons (Qvoid_function
, error_tail
));
2545 Fput (Qvoid_function
, Qerror_message
,
2546 build_string ("Symbol's function definition is void"));
2548 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2549 Fcons (Qcyclic_function_indirection
, error_tail
));
2550 Fput (Qcyclic_function_indirection
, Qerror_message
,
2551 build_string ("Symbol's chain of function indirections contains a loop"));
2553 Fput (Qvoid_variable
, Qerror_conditions
,
2554 Fcons (Qvoid_variable
, error_tail
));
2555 Fput (Qvoid_variable
, Qerror_message
,
2556 build_string ("Symbol's value as variable is void"));
2558 Fput (Qsetting_constant
, Qerror_conditions
,
2559 Fcons (Qsetting_constant
, error_tail
));
2560 Fput (Qsetting_constant
, Qerror_message
,
2561 build_string ("Attempt to set a constant symbol"));
2563 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
2564 Fcons (Qinvalid_read_syntax
, error_tail
));
2565 Fput (Qinvalid_read_syntax
, Qerror_message
,
2566 build_string ("Invalid read syntax"));
2568 Fput (Qinvalid_function
, Qerror_conditions
,
2569 Fcons (Qinvalid_function
, error_tail
));
2570 Fput (Qinvalid_function
, Qerror_message
,
2571 build_string ("Invalid function"));
2573 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
2574 Fcons (Qwrong_number_of_arguments
, error_tail
));
2575 Fput (Qwrong_number_of_arguments
, Qerror_message
,
2576 build_string ("Wrong number of arguments"));
2578 Fput (Qno_catch
, Qerror_conditions
,
2579 Fcons (Qno_catch
, error_tail
));
2580 Fput (Qno_catch
, Qerror_message
,
2581 build_string ("No catch for tag"));
2583 Fput (Qend_of_file
, Qerror_conditions
,
2584 Fcons (Qend_of_file
, error_tail
));
2585 Fput (Qend_of_file
, Qerror_message
,
2586 build_string ("End of file during parsing"));
2588 arith_tail
= Fcons (Qarith_error
, error_tail
);
2589 Fput (Qarith_error
, Qerror_conditions
,
2591 Fput (Qarith_error
, Qerror_message
,
2592 build_string ("Arithmetic error"));
2594 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
2595 Fcons (Qbeginning_of_buffer
, error_tail
));
2596 Fput (Qbeginning_of_buffer
, Qerror_message
,
2597 build_string ("Beginning of buffer"));
2599 Fput (Qend_of_buffer
, Qerror_conditions
,
2600 Fcons (Qend_of_buffer
, error_tail
));
2601 Fput (Qend_of_buffer
, Qerror_message
,
2602 build_string ("End of buffer"));
2604 Fput (Qbuffer_read_only
, Qerror_conditions
,
2605 Fcons (Qbuffer_read_only
, error_tail
));
2606 Fput (Qbuffer_read_only
, Qerror_message
,
2607 build_string ("Buffer is read-only"));
2609 #ifdef LISP_FLOAT_TYPE
2610 Qrange_error
= intern ("range-error");
2611 Qdomain_error
= intern ("domain-error");
2612 Qsingularity_error
= intern ("singularity-error");
2613 Qoverflow_error
= intern ("overflow-error");
2614 Qunderflow_error
= intern ("underflow-error");
2616 Fput (Qdomain_error
, Qerror_conditions
,
2617 Fcons (Qdomain_error
, arith_tail
));
2618 Fput (Qdomain_error
, Qerror_message
,
2619 build_string ("Arithmetic domain error"));
2621 Fput (Qrange_error
, Qerror_conditions
,
2622 Fcons (Qrange_error
, arith_tail
));
2623 Fput (Qrange_error
, Qerror_message
,
2624 build_string ("Arithmetic range error"));
2626 Fput (Qsingularity_error
, Qerror_conditions
,
2627 Fcons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
2628 Fput (Qsingularity_error
, Qerror_message
,
2629 build_string ("Arithmetic singularity error"));
2631 Fput (Qoverflow_error
, Qerror_conditions
,
2632 Fcons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2633 Fput (Qoverflow_error
, Qerror_message
,
2634 build_string ("Arithmetic overflow error"));
2636 Fput (Qunderflow_error
, Qerror_conditions
,
2637 Fcons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
2638 Fput (Qunderflow_error
, Qerror_message
,
2639 build_string ("Arithmetic underflow error"));
2641 staticpro (&Qrange_error
);
2642 staticpro (&Qdomain_error
);
2643 staticpro (&Qsingularity_error
);
2644 staticpro (&Qoverflow_error
);
2645 staticpro (&Qunderflow_error
);
2646 #endif /* LISP_FLOAT_TYPE */
2650 staticpro (&Qquote
);
2651 staticpro (&Qlambda
);
2653 staticpro (&Qunbound
);
2654 staticpro (&Qerror_conditions
);
2655 staticpro (&Qerror_message
);
2656 staticpro (&Qtop_level
);
2658 staticpro (&Qerror
);
2660 staticpro (&Qwrong_type_argument
);
2661 staticpro (&Qargs_out_of_range
);
2662 staticpro (&Qvoid_function
);
2663 staticpro (&Qcyclic_function_indirection
);
2664 staticpro (&Qvoid_variable
);
2665 staticpro (&Qsetting_constant
);
2666 staticpro (&Qinvalid_read_syntax
);
2667 staticpro (&Qwrong_number_of_arguments
);
2668 staticpro (&Qinvalid_function
);
2669 staticpro (&Qno_catch
);
2670 staticpro (&Qend_of_file
);
2671 staticpro (&Qarith_error
);
2672 staticpro (&Qbeginning_of_buffer
);
2673 staticpro (&Qend_of_buffer
);
2674 staticpro (&Qbuffer_read_only
);
2675 staticpro (&Qmark_inactive
);
2677 staticpro (&Qlistp
);
2678 staticpro (&Qconsp
);
2679 staticpro (&Qsymbolp
);
2680 staticpro (&Qintegerp
);
2681 staticpro (&Qnatnump
);
2682 staticpro (&Qwholenump
);
2683 staticpro (&Qstringp
);
2684 staticpro (&Qarrayp
);
2685 staticpro (&Qsequencep
);
2686 staticpro (&Qbufferp
);
2687 staticpro (&Qvectorp
);
2688 staticpro (&Qchar_or_string_p
);
2689 staticpro (&Qmarkerp
);
2690 staticpro (&Qbuffer_or_string_p
);
2691 staticpro (&Qinteger_or_marker_p
);
2692 #ifdef LISP_FLOAT_TYPE
2693 staticpro (&Qfloatp
);
2694 staticpro (&Qnumberp
);
2695 staticpro (&Qnumber_or_marker_p
);
2696 #endif /* LISP_FLOAT_TYPE */
2697 staticpro (&Qchar_table_p
);
2698 staticpro (&Qvector_or_char_table_p
);
2700 staticpro (&Qboundp
);
2701 staticpro (&Qfboundp
);
2703 staticpro (&Qad_advice_info
);
2704 staticpro (&Qad_activate
);
2706 /* Types that type-of returns. */
2707 Qinteger
= intern ("integer");
2708 Qsymbol
= intern ("symbol");
2709 Qstring
= intern ("string");
2710 Qcons
= intern ("cons");
2711 Qmarker
= intern ("marker");
2712 Qoverlay
= intern ("overlay");
2713 Qfloat
= intern ("float");
2714 Qwindow_configuration
= intern ("window-configuration");
2715 Qprocess
= intern ("process");
2716 Qwindow
= intern ("window");
2717 /* Qsubr = intern ("subr"); */
2718 Qcompiled_function
= intern ("compiled-function");
2719 Qbuffer
= intern ("buffer");
2720 Qframe
= intern ("frame");
2721 Qvector
= intern ("vector");
2722 Qchar_table
= intern ("char-table");
2723 Qbool_vector
= intern ("bool-vector");
2725 staticpro (&Qinteger
);
2726 staticpro (&Qsymbol
);
2727 staticpro (&Qstring
);
2729 staticpro (&Qmarker
);
2730 staticpro (&Qoverlay
);
2731 staticpro (&Qfloat
);
2732 staticpro (&Qwindow_configuration
);
2733 staticpro (&Qprocess
);
2734 staticpro (&Qwindow
);
2735 /* staticpro (&Qsubr); */
2736 staticpro (&Qcompiled_function
);
2737 staticpro (&Qbuffer
);
2738 staticpro (&Qframe
);
2739 staticpro (&Qvector
);
2740 staticpro (&Qchar_table
);
2741 staticpro (&Qbool_vector
);
2745 defsubr (&Stype_of
);
2750 defsubr (&Sintegerp
);
2751 defsubr (&Sinteger_or_marker_p
);
2752 defsubr (&Snumberp
);
2753 defsubr (&Snumber_or_marker_p
);
2754 #ifdef LISP_FLOAT_TYPE
2756 #endif /* LISP_FLOAT_TYPE */
2757 defsubr (&Snatnump
);
2758 defsubr (&Ssymbolp
);
2759 defsubr (&Sstringp
);
2760 defsubr (&Smultibyte_string_p
);
2761 defsubr (&Svectorp
);
2762 defsubr (&Schar_table_p
);
2763 defsubr (&Svector_or_char_table_p
);
2764 defsubr (&Sbool_vector_p
);
2766 defsubr (&Ssequencep
);
2767 defsubr (&Sbufferp
);
2768 defsubr (&Smarkerp
);
2770 defsubr (&Sbyte_code_function_p
);
2771 defsubr (&Schar_or_string_p
);
2774 defsubr (&Scar_safe
);
2775 defsubr (&Scdr_safe
);
2778 defsubr (&Ssymbol_function
);
2779 defsubr (&Sindirect_function
);
2780 defsubr (&Ssymbol_plist
);
2781 defsubr (&Ssymbol_name
);
2782 defsubr (&Smakunbound
);
2783 defsubr (&Sfmakunbound
);
2785 defsubr (&Sfboundp
);
2787 defsubr (&Sdefalias
);
2788 defsubr (&Ssetplist
);
2789 defsubr (&Ssymbol_value
);
2791 defsubr (&Sdefault_boundp
);
2792 defsubr (&Sdefault_value
);
2793 defsubr (&Sset_default
);
2794 defsubr (&Ssetq_default
);
2795 defsubr (&Smake_variable_buffer_local
);
2796 defsubr (&Smake_local_variable
);
2797 defsubr (&Skill_local_variable
);
2798 defsubr (&Slocal_variable_p
);
2799 defsubr (&Slocal_variable_if_set_p
);
2802 defsubr (&Snumber_to_string
);
2803 defsubr (&Sstring_to_number
);
2804 defsubr (&Seqlsign
);
2828 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
2835 #if defined(USG) && !defined(POSIX_SIGNALS)
2836 /* USG systems forget handlers when they are used;
2837 must reestablish each time */
2838 signal (signo
, arith_error
);
2841 /* VMS systems are like USG. */
2842 signal (signo
, arith_error
);
2846 #else /* not BSD4_1 */
2847 sigsetmask (SIGEMPTYMASK
);
2848 #endif /* not BSD4_1 */
2850 Fsignal (Qarith_error
, Qnil
);
2855 /* Don't do this if just dumping out.
2856 We don't want to call `signal' in this case
2857 so that we don't have trouble with dumping
2858 signal-delivering routines in an inconsistent state. */
2862 #endif /* CANNOT_DUMP */
2863 signal (SIGFPE
, arith_error
);
2866 signal (SIGEMT
, arith_error
);