/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
+ 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
+the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
-#include <signal.h>
-
#include <config.h>
+#include <signal.h>
+#include <stdio.h>
#include "lisp.h"
#include "puresize.h"
-
-#ifndef standalone
+#include "charset.h"
#include "buffer.h"
-#endif
-
+#include "keyboard.h"
+#include "frame.h"
#include "syssignal.h"
-#if 0 /* That is untrue--XINT is used below, and it uses INTBITS.
- What in the world is values.h, anyway? */
-#ifdef MSDOS
-/* These are redefined in values.h and not used here */
-#undef INTBITS
-#undef LONGBITS
-#undef SHORTBITS
-#endif
+#ifdef STDC_HEADERS
+#include <float.h>
#endif
-#ifdef LISP_FLOAT_TYPE
-
-#ifdef STDC_HEADERS
-#include <stdlib.h>
+/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
+#ifndef IEEE_FLOATING_POINT
+#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
+ && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
+#define IEEE_FLOATING_POINT 1
+#else
+#define IEEE_FLOATING_POINT 0
+#endif
#endif
/* Work around a problem that happens because math.h on hpux 7
#endif
#include <math.h>
-#endif /* LISP_FLOAT_TYPE */
#if !defined (atof)
extern double atof ();
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
+Lisp_Object Qcyclic_variable_indirection, Qcircular_list;
Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
-Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qlistp, Qconsp;
+Lisp_Object Qtext_read_only;
+
+Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
-Lisp_Object Qbuffer_or_string_p;
+Lisp_Object Qbuffer_or_string_p, Qkeywordp;
Lisp_Object Qboundp, Qfboundp;
+Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
+
Lisp_Object Qcdr;
+Lisp_Object Qad_advice_info, Qad_activate_internal;
Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
Lisp_Object Qoverflow_error, Qunderflow_error;
-#ifdef LISP_FLOAT_TYPE
Lisp_Object Qfloatp;
Lisp_Object Qnumberp, Qnumber_or_marker_p;
-#endif
-static Lisp_Object swap_in_symval_forwarding ();
+Lisp_Object Qinteger;
+static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
+static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
+Lisp_Object Qprocess;
+static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
+static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
+static Lisp_Object Qsubrp, Qmany, Qunevalled;
+
+static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object));
+
+Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
+
+
+void
+circular_list_error (list)
+ Lisp_Object list;
+{
+ xsignal (Qcircular_list, list);
+}
+
Lisp_Object
wrong_type_argument (predicate, value)
register Lisp_Object predicate, value;
{
- register Lisp_Object tem;
- do
- {
- if (!EQ (Vmocklisp_arguments, Qt))
- {
- if (XTYPE (value) == Lisp_String &&
- (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
- return Fstring_to_number (value);
- if (XTYPE (value) == Lisp_Int && EQ (predicate, Qstringp))
- return Fnumber_to_string (value);
- }
- value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
- tem = call1 (predicate, value);
- }
- while (NILP (tem));
- return value;
+ /* If VALUE is not even a valid Lisp object, abort here
+ where we can get a backtrace showing where it came from. */
+ if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
+ abort ();
+
+ xsignal2 (Qwrong_type_argument, predicate, value);
}
+void
pure_write_error ()
{
error ("Attempt to modify read-only object");
args_out_of_range (a1, a2)
Lisp_Object a1, a2;
{
- while (1)
- Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
+ xsignal2 (Qargs_out_of_range, a1, a2);
}
void
args_out_of_range_3 (a1, a2, a3)
Lisp_Object a1, a2, a3;
{
- while (1)
- Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
-}
-
-Lisp_Object
-make_number (num)
- int num;
-{
- register Lisp_Object val;
- XSET (val, Lisp_Int, num);
- return val;
+ xsignal3 (Qargs_out_of_range, a1, a2, a3);
}
/* On some machines, XINT needs a temporary location.
int
sign_extend_lisp_int (num)
- int num;
+ EMACS_INT num;
{
- if (num & (1 << (VALBITS - 1)))
- return num | ((-1) << VALBITS);
+ if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
+ return num | (((EMACS_INT) (-1)) << VALBITS);
else
- return num & ((1 << VALBITS) - 1);
+ return num & ((((EMACS_INT) 1) << VALBITS) - 1);
}
\f
/* Data type predicates */
DEFUN ("eq", Feq, Seq, 2, 2, 0,
- "T if the two args are the same Lisp object.")
- (obj1, obj2)
+ doc: /* Return t if the two args are the same Lisp object. */)
+ (obj1, obj2)
Lisp_Object obj1, obj2;
{
if (EQ (obj1, obj2))
return Qnil;
}
-DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
- (obj)
- Lisp_Object obj;
+DEFUN ("null", Fnull, Snull, 1, 1, 0,
+ doc: /* Return t if OBJECT is nil. */)
+ (object)
+ Lisp_Object object;
{
- if (NILP (obj))
+ if (NILP (object))
return Qt;
return Qnil;
}
-DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
- (obj)
- Lisp_Object obj;
+DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
+ doc: /* Return a symbol representing the type of OBJECT.
+The symbol returned names the object's basic type;
+for example, (type-of 1) returns `integer'. */)
+ (object)
+ Lisp_Object object;
+{
+ switch (XGCTYPE (object))
+ {
+ case Lisp_Int:
+ return Qinteger;
+
+ case Lisp_Symbol:
+ return Qsymbol;
+
+ case Lisp_String:
+ return Qstring;
+
+ case Lisp_Cons:
+ return Qcons;
+
+ case Lisp_Misc:
+ switch (XMISCTYPE (object))
+ {
+ case Lisp_Misc_Marker:
+ return Qmarker;
+ case Lisp_Misc_Overlay:
+ return Qoverlay;
+ case Lisp_Misc_Float:
+ return Qfloat;
+ }
+ abort ();
+
+ case Lisp_Vectorlike:
+ if (GC_WINDOW_CONFIGURATIONP (object))
+ return Qwindow_configuration;
+ if (GC_PROCESSP (object))
+ return Qprocess;
+ if (GC_WINDOWP (object))
+ return Qwindow;
+ if (GC_SUBRP (object))
+ return Qsubr;
+ if (GC_COMPILEDP (object))
+ return Qcompiled_function;
+ if (GC_BUFFERP (object))
+ return Qbuffer;
+ if (GC_CHAR_TABLE_P (object))
+ return Qchar_table;
+ if (GC_BOOL_VECTOR_P (object))
+ return Qbool_vector;
+ if (GC_FRAMEP (object))
+ return Qframe;
+ if (GC_HASH_TABLE_P (object))
+ return Qhash_table;
+ return Qvector;
+
+ case Lisp_Float:
+ return Qfloat;
+
+ default:
+ abort ();
+ }
+}
+
+DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a cons cell. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Cons)
+ if (CONSP (object))
return Qt;
return Qnil;
}
-DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
- (obj)
- Lisp_Object obj;
+DEFUN ("atom", Fatom, Satom, 1, 1, 0,
+ doc: /* Return t if OBJECT is not a cons cell. This includes nil. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Cons)
+ if (CONSP (object))
return Qnil;
return Qt;
}
-DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
- (obj)
- Lisp_Object obj;
+DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
+Otherwise, return nil. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Cons || NILP (obj))
+ if (CONSP (object) || NILP (object))
return Qt;
return Qnil;
}
-DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
- (obj)
- Lisp_Object obj;
+DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
+ doc: /* Return t if OBJECT is not a list. Lists include nil. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Cons || NILP (obj))
+ if (CONSP (object) || NILP (object))
return Qnil;
return Qt;
}
\f
-DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
- (obj)
- Lisp_Object obj;
+DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a symbol. */)
+ (object)
+ Lisp_Object object;
+{
+ if (SYMBOLP (object))
+ return Qt;
+ return Qnil;
+}
+
+/* Define this in C to avoid unnecessarily consing up the symbol
+ name. */
+DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a keyword.
+This means that it is a symbol with a print name beginning with `:'
+interned in the initial obarray. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Symbol)
+ if (SYMBOLP (object)
+ && SREF (SYMBOL_NAME (object), 0) == ':'
+ && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
return Qt;
return Qnil;
}
-DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
- (obj)
- Lisp_Object obj;
+DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a vector. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Vector)
+ if (VECTORP (object))
return Qt;
return Qnil;
}
-DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
- (obj)
- Lisp_Object obj;
+DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a string. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_String)
+ if (STRINGP (object))
return Qt;
return Qnil;
}
-DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
- (obj)
- Lisp_Object obj;
+DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
+ 1, 1, 0,
+ doc: /* Return t if OBJECT is a multibyte string. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
+ if (STRINGP (object) && STRING_MULTIBYTE (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
+ doc: /* Return t if OBJECT is a char-table. */)
+ (object)
+ Lisp_Object object;
+{
+ if (CHAR_TABLE_P (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
+ Svector_or_char_table_p, 1, 1, 0,
+ doc: /* Return t if OBJECT is a char-table or vector. */)
+ (object)
+ Lisp_Object object;
+{
+ if (VECTORP (object) || CHAR_TABLE_P (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
+ doc: /* Return t if OBJECT is a bool-vector. */)
+ (object)
+ Lisp_Object object;
+{
+ if (BOOL_VECTOR_P (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
+ doc: /* Return t if OBJECT is an array (string or vector). */)
+ (object)
+ Lisp_Object object;
+{
+ if (ARRAYP (object))
return Qt;
return Qnil;
}
DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
- "T if OBJECT is a sequence (list or array).")
- (obj)
- register Lisp_Object obj;
+ doc: /* Return t if OBJECT is a sequence (list or array). */)
+ (object)
+ register Lisp_Object object;
{
- if (CONSP (obj) || NILP (obj) ||
- XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
+ if (CONSP (object) || NILP (object) || ARRAYP (object))
return Qt;
return Qnil;
}
-DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
- (obj)
- Lisp_Object obj;
+DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
+ doc: /* Return t if OBJECT is an editor buffer. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Buffer)
+ if (BUFFERP (object))
return Qt;
return Qnil;
}
-DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
- (obj)
- Lisp_Object obj;
+DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a marker (editor pointer). */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Marker)
+ if (MARKERP (object))
return Qt;
return Qnil;
}
-DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
- (obj)
- Lisp_Object obj;
+DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a built-in function. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Subr)
+ if (SUBRP (object))
return Qt;
return Qnil;
}
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
- 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
- (obj)
- Lisp_Object obj;
+ 1, 1, 0,
+ doc: /* Return t if OBJECT is a byte-compiled function object. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Compiled)
+ if (COMPILEDP (object))
return Qt;
return Qnil;
}
-DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, "T if OBJECT is a character (a number) or a string.")
- (obj)
- register Lisp_Object obj;
+DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
+ doc: /* Return t if OBJECT is a character (an integer) or a string. */)
+ (object)
+ register Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Int || XTYPE (obj) == Lisp_String)
+ if (INTEGERP (object) || STRINGP (object))
return Qt;
return Qnil;
}
\f
-DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is a number.")
- (obj)
- Lisp_Object obj;
+DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
+ doc: /* Return t if OBJECT is an integer. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Int)
+ if (INTEGERP (object))
return Qt;
return Qnil;
}
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
- "T if OBJECT is an integer or a marker (editor pointer).")
- (obj)
- register Lisp_Object obj;
+ doc: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
+ (object)
+ register Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int)
+ if (MARKERP (object) || INTEGERP (object))
return Qt;
return Qnil;
}
-DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.")
- (obj)
- Lisp_Object obj;
+DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
+ doc: /* Return t if OBJECT is a nonnegative integer. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0)
+ if (NATNUMP (object))
return Qt;
return Qnil;
}
DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
- "T if OBJECT is a number (floating point or integer).")
- (obj)
- Lisp_Object obj;
+ doc: /* Return t if OBJECT is a number (floating point or integer). */)
+ (object)
+ Lisp_Object object;
{
- if (NUMBERP (obj))
+ if (NUMBERP (object))
return Qt;
else
return Qnil;
DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
Snumber_or_marker_p, 1, 1, 0,
- "T if OBJECT is a number or a marker.")
- (obj)
- Lisp_Object obj;
+ doc: /* Return t if OBJECT is a number or a marker. */)
+ (object)
+ Lisp_Object object;
{
- if (NUMBERP (obj)
- || XTYPE (obj) == Lisp_Marker)
+ if (NUMBERP (object) || MARKERP (object))
return Qt;
return Qnil;
}
-#ifdef LISP_FLOAT_TYPE
DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
- "T if OBJECT is a floating point number.")
- (obj)
- Lisp_Object obj;
+ doc: /* Return t if OBJECT is a floating point number. */)
+ (object)
+ Lisp_Object object;
{
- if (XTYPE (obj) == Lisp_Float)
+ if (FLOATP (object))
return Qt;
return Qnil;
}
-#endif /* LISP_FLOAT_TYPE */
+
\f
/* Extract and set components of lists */
DEFUN ("car", Fcar, Scar, 1, 1, 0,
- "Return the car of CONSCELL. If arg is nil, return nil.\n\
-Error if arg is not nil and not a cons cell. See also `car-safe'.")
- (list)
+ doc: /* Return the car of LIST. If arg is nil, return nil.
+Error if arg is not nil and not a cons cell. See also `car-safe'.
+
+See Info node `(elisp)Cons Cells' for a discussion of related basic
+Lisp concepts such as car, cdr, cons cell and list. */)
+ (list)
register Lisp_Object list;
{
- while (1)
- {
- if (XTYPE (list) == Lisp_Cons)
- return XCONS (list)->car;
- else if (EQ (list, Qnil))
- return Qnil;
- else
- list = wrong_type_argument (Qlistp, list);
- }
+ return CAR (list);
}
DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
- "Return the car of OBJECT if it is a cons cell, or else nil.")
- (object)
+ doc: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
+ (object)
Lisp_Object object;
{
- if (XTYPE (object) == Lisp_Cons)
- return XCONS (object)->car;
- else
- return Qnil;
+ return CAR_SAFE (object);
}
DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
- "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
-Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
+ doc: /* Return the cdr of LIST. If arg is nil, return nil.
+Error if arg is not nil and not a cons cell. See also `cdr-safe'.
- (list)
+See Info node `(elisp)Cons Cells' for a discussion of related basic
+Lisp concepts such as cdr, car, cons cell and list. */)
+ (list)
register Lisp_Object list;
{
- while (1)
- {
- if (XTYPE (list) == Lisp_Cons)
- return XCONS (list)->cdr;
- else if (EQ (list, Qnil))
- return Qnil;
- else
- list = wrong_type_argument (Qlistp, list);
- }
+ return CDR (list);
}
DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
- "Return the cdr of OBJECT if it is a cons cell, or else nil.")
- (object)
+ doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
+ (object)
Lisp_Object object;
{
- if (XTYPE (object) == Lisp_Cons)
- return XCONS (object)->cdr;
- else
- return Qnil;
+ return CDR_SAFE (object);
}
DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
- "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
- (cell, newcar)
+ doc: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
+ (cell, newcar)
register Lisp_Object cell, newcar;
{
- if (XTYPE (cell) != Lisp_Cons)
- cell = wrong_type_argument (Qconsp, cell);
-
+ CHECK_CONS (cell);
CHECK_IMPURE (cell);
- XCONS (cell)->car = newcar;
+ XSETCAR (cell, newcar);
return newcar;
}
DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
- "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
- (cell, newcdr)
+ doc: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
+ (cell, newcdr)
register Lisp_Object cell, newcdr;
{
- if (XTYPE (cell) != Lisp_Cons)
- cell = wrong_type_argument (Qconsp, cell);
-
+ CHECK_CONS (cell);
CHECK_IMPURE (cell);
- XCONS (cell)->cdr = newcdr;
+ XSETCDR (cell, newcdr);
return newcdr;
}
\f
/* Extract and set components of symbols */
-DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
- (sym)
- register Lisp_Object sym;
+DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
+ doc: /* Return t if SYMBOL's value is not void. */)
+ (symbol)
+ register Lisp_Object symbol;
{
Lisp_Object valcontents;
- CHECK_SYMBOL (sym, 0);
+ CHECK_SYMBOL (symbol);
- valcontents = XSYMBOL (sym)->value;
+ valcontents = SYMBOL_VALUE (symbol);
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (valcontents))
-#else
- switch (XTYPE (valcontents))
-#endif
- {
- case Lisp_Buffer_Local_Value:
- case Lisp_Some_Buffer_Local_Value:
- valcontents = swap_in_symval_forwarding (sym, valcontents);
- }
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ valcontents = swap_in_symval_forwarding (symbol, valcontents);
- return (XTYPE (valcontents) == Lisp_Void || EQ (valcontents, Qunbound)
- ? Qnil : Qt);
+ return (EQ (valcontents, Qunbound) ? Qnil : Qt);
}
-DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
- (sym)
- register Lisp_Object sym;
+DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
+ doc: /* Return t if SYMBOL's function definition is not void. */)
+ (symbol)
+ register Lisp_Object symbol;
{
- CHECK_SYMBOL (sym, 0);
- return (XTYPE (XSYMBOL (sym)->function) == Lisp_Void
- || EQ (XSYMBOL (sym)->function, Qunbound))
- ? Qnil : Qt;
+ CHECK_SYMBOL (symbol);
+ return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
}
-DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
- (sym)
- register Lisp_Object sym;
+DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
+ doc: /* Make SYMBOL's value be void.
+Return SYMBOL. */)
+ (symbol)
+ register Lisp_Object symbol;
{
- CHECK_SYMBOL (sym, 0);
- if (NILP (sym) || EQ (sym, Qt))
- return Fsignal (Qsetting_constant, Fcons (sym, Qnil));
- Fset (sym, Qunbound);
- return sym;
+ CHECK_SYMBOL (symbol);
+ if (SYMBOL_CONSTANT_P (symbol))
+ xsignal1 (Qsetting_constant, symbol);
+ Fset (symbol, Qunbound);
+ return symbol;
}
-DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
- (sym)
- register Lisp_Object sym;
+DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
+ doc: /* Make SYMBOL's function definition be void.
+Return SYMBOL. */)
+ (symbol)
+ register Lisp_Object symbol;
{
- CHECK_SYMBOL (sym, 0);
- XSYMBOL (sym)->function = Qunbound;
- return sym;
+ CHECK_SYMBOL (symbol);
+ if (NILP (symbol) || EQ (symbol, Qt))
+ xsignal1 (Qsetting_constant, symbol);
+ XSYMBOL (symbol)->function = Qunbound;
+ return symbol;
}
DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
- "Return SYMBOL's function definition. Error if that is void.")
- (symbol)
+ doc: /* Return SYMBOL's function definition. Error if that is void. */)
+ (symbol)
register Lisp_Object symbol;
{
- CHECK_SYMBOL (symbol, 0);
- if (EQ (XSYMBOL (symbol)->function, Qunbound))
- return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
- return XSYMBOL (symbol)->function;
+ CHECK_SYMBOL (symbol);
+ if (!EQ (XSYMBOL (symbol)->function, Qunbound))
+ return XSYMBOL (symbol)->function;
+ xsignal1 (Qvoid_function, symbol);
}
-DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
- (sym)
- register Lisp_Object sym;
+DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
+ doc: /* Return SYMBOL's property list. */)
+ (symbol)
+ register Lisp_Object symbol;
{
- CHECK_SYMBOL (sym, 0);
- return XSYMBOL (sym)->plist;
+ CHECK_SYMBOL (symbol);
+ return XSYMBOL (symbol)->plist;
}
-DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
- (sym)
- register Lisp_Object sym;
+DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
+ doc: /* Return SYMBOL's name, a string. */)
+ (symbol)
+ register Lisp_Object symbol;
{
register Lisp_Object name;
- CHECK_SYMBOL (sym, 0);
- XSET (name, Lisp_String, XSYMBOL (sym)->name);
+ CHECK_SYMBOL (symbol);
+ name = SYMBOL_NAME (symbol);
return name;
}
DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
- (sym, newdef)
- register Lisp_Object sym, newdef;
-{
- CHECK_SYMBOL (sym, 0);
-
- if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
- Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
+ doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
+ (symbol, definition)
+ register Lisp_Object symbol, definition;
+{
+ CHECK_SYMBOL (symbol);
+ if (NILP (symbol) || EQ (symbol, Qt))
+ xsignal1 (Qsetting_constant, symbol);
+ if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
+ Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
Vautoload_queue);
- XSYMBOL (sym)->function = newdef;
- return newdef;
+ XSYMBOL (symbol)->function = definition;
+ /* Handle automatic advice activation */
+ if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
+ {
+ call2 (Qad_activate_internal, symbol, Qnil);
+ definition = XSYMBOL (symbol)->function;
+ }
+ return definition;
}
-/* This name should be removed once it is eliminated from elsewhere. */
+extern Lisp_Object Qfunction_documentation;
-DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
-Associates the function with the current load file, if any.")
- (sym, newdef)
- register Lisp_Object sym, newdef;
+DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
+ doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
+Associates the function with the current load file, if any.
+The optional third argument DOCSTRING specifies the documentation string
+for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
+determined by DEFINITION. */)
+ (symbol, definition, docstring)
+ register Lisp_Object symbol, definition, docstring;
{
- CHECK_SYMBOL (sym, 0);
- if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
- Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
- Vautoload_queue);
- XSYMBOL (sym)->function = newdef;
- LOADHIST_ATTACH (sym);
- return newdef;
+ CHECK_SYMBOL (symbol);
+ if (CONSP (XSYMBOL (symbol)->function)
+ && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
+ LOADHIST_ATTACH (Fcons (Qt, symbol));
+ definition = Ffset (symbol, definition);
+ LOADHIST_ATTACH (Fcons (Qdefun, symbol));
+ if (!NILP (docstring))
+ Fput (symbol, Qfunction_documentation, docstring);
+ return definition;
}
-DEFUN ("define-function", Fdefine_function, Sdefine_function, 2, 2, 0,
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
-Associates the function with the current load file, if any.")
- (sym, newdef)
- register Lisp_Object sym, newdef;
+DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
+ doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
+ (symbol, newplist)
+ register Lisp_Object symbol, newplist;
{
- CHECK_SYMBOL (sym, 0);
- if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
- Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
- Vautoload_queue);
- XSYMBOL (sym)->function = newdef;
- LOADHIST_ATTACH (sym);
- return newdef;
+ CHECK_SYMBOL (symbol);
+ XSYMBOL (symbol)->plist = newplist;
+ return newplist;
}
-DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
- "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
- (sym, newplist)
- register Lisp_Object sym, newplist;
+DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
+ doc: /* Return minimum and maximum number of args allowed for SUBR.
+SUBR must be a built-in function.
+The returned value is a pair (MIN . MAX). MIN is the minimum number
+of args. MAX is the maximum number or the symbol `many', for a
+function with `&rest' args, or `unevalled' for a special form. */)
+ (subr)
+ Lisp_Object subr;
+{
+ short minargs, maxargs;
+ CHECK_SUBR (subr);
+ minargs = XSUBR (subr)->min_args;
+ maxargs = XSUBR (subr)->max_args;
+ if (maxargs == MANY)
+ return Fcons (make_number (minargs), Qmany);
+ else if (maxargs == UNEVALLED)
+ return Fcons (make_number (minargs), Qunevalled);
+ else
+ return Fcons (make_number (minargs), make_number (maxargs));
+}
+
+DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
+ doc: /* Return name of subroutine SUBR.
+SUBR must be a built-in function. */)
+ (subr)
+ Lisp_Object subr;
{
- CHECK_SYMBOL (sym, 0);
- XSYMBOL (sym)->plist = newplist;
- return newplist;
+ const char *name;
+ CHECK_SUBR (subr);
+ name = XSUBR (subr)->symbol_name;
+ return make_string (name, strlen (name));
+}
+
+DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
+ doc: /* Return the interactive form of CMD or nil if none.
+If CMD is not a command, the return value is nil.
+Value, if non-nil, is a list \(interactive SPEC). */)
+ (cmd)
+ Lisp_Object cmd;
+{
+ Lisp_Object fun = indirect_function (cmd);
+
+ if (SUBRP (fun))
+ {
+ if (XSUBR (fun)->prompt)
+ return list2 (Qinteractive, build_string (XSUBR (fun)->prompt));
+ }
+ else if (COMPILEDP (fun))
+ {
+ if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
+ return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
+ }
+ else if (CONSP (fun))
+ {
+ Lisp_Object funcar = XCAR (fun);
+ if (EQ (funcar, Qlambda))
+ return Fassq (Qinteractive, Fcdr (XCDR (fun)));
+ else if (EQ (funcar, Qautoload))
+ {
+ struct gcpro gcpro1;
+ GCPRO1 (cmd);
+ do_autoload (fun, cmd);
+ UNGCPRO;
+ return Finteractive_form (cmd);
+ }
+ }
+ return Qnil;
}
\f
-/* Getting and setting values of symbols */
+/***********************************************************************
+ Getting and Setting Values of Symbols
+ ***********************************************************************/
+
+/* Return the symbol holding SYMBOL's value. Signal
+ `cyclic-variable-indirection' if SYMBOL's chain of variable
+ indirections contains a loop. */
+
+Lisp_Object
+indirect_variable (symbol)
+ Lisp_Object symbol;
+{
+ Lisp_Object tortoise, hare;
+
+ hare = tortoise = symbol;
+
+ while (XSYMBOL (hare)->indirect_variable)
+ {
+ hare = XSYMBOL (hare)->value;
+ if (!XSYMBOL (hare)->indirect_variable)
+ break;
+
+ hare = XSYMBOL (hare)->value;
+ tortoise = XSYMBOL (tortoise)->value;
+
+ if (EQ (hare, tortoise))
+ xsignal1 (Qcyclic_variable_indirection, symbol);
+ }
+
+ return hare;
+}
+
+
+DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
+ doc: /* Return the variable at the end of OBJECT's variable chain.
+If OBJECT is a symbol, follow all variable indirections and return the final
+variable. If OBJECT is not a symbol, just return it.
+Signal a cyclic-variable-indirection error if there is a loop in the
+variable chain of symbols. */)
+ (object)
+ Lisp_Object object;
+{
+ if (SYMBOLP (object))
+ object = indirect_variable (object);
+ return object;
+}
+
/* Given the raw contents of a symbol value cell,
return the Lisp value of the symbol.
register Lisp_Object valcontents;
{
register Lisp_Object val;
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (valcontents))
-#else
- switch (XTYPE (valcontents))
-#endif
- {
- case Lisp_Intfwd:
- XSET (val, Lisp_Int, *XINTPTR (valcontents));
- return val;
+ int offset;
+ if (MISCP (valcontents))
+ switch (XMISCTYPE (valcontents))
+ {
+ case Lisp_Misc_Intfwd:
+ XSETINT (val, *XINTFWD (valcontents)->intvar);
+ return val;
- case Lisp_Boolfwd:
- if (*XINTPTR (valcontents))
- return Qt;
- return Qnil;
+ case Lisp_Misc_Boolfwd:
+ return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
- case Lisp_Objfwd:
- return *XOBJFWD (valcontents);
+ case Lisp_Misc_Objfwd:
+ return *XOBJFWD (valcontents)->objvar;
- case Lisp_Buffer_Objfwd:
- return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
- }
+ case Lisp_Misc_Buffer_Objfwd:
+ offset = XBUFFER_OBJFWD (valcontents)->offset;
+ return PER_BUFFER_VALUE (current_buffer, offset);
+
+ case Lisp_Misc_Kboard_Objfwd:
+ offset = XKBOARD_OBJFWD (valcontents)->offset;
+ return *(Lisp_Object *)(offset + (char *)current_kboard);
+ }
return valcontents;
}
-/* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
- of SYM. If SYM is buffer-local, VALCONTENTS should be the
+/* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
+ of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
buffer-independent contents of the value cell: forwarded just one
- step past the buffer-localness. */
+ step past the buffer-localness.
+
+ BUF non-zero means set the value in buffer BUF instead of the
+ current buffer. This only plays a role for per-buffer variables. */
void
-store_symval_forwarding (sym, valcontents, newval)
- Lisp_Object sym;
+store_symval_forwarding (symbol, valcontents, newval, buf)
+ Lisp_Object symbol;
register Lisp_Object valcontents, newval;
+ struct buffer *buf;
{
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (valcontents))
-#else
- switch (XTYPE (valcontents))
-#endif
+ switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
{
- case Lisp_Intfwd:
- CHECK_NUMBER (newval, 1);
- *XINTPTR (valcontents) = XINT (newval);
- break;
+ case Lisp_Misc:
+ switch (XMISCTYPE (valcontents))
+ {
+ case Lisp_Misc_Intfwd:
+ CHECK_NUMBER (newval);
+ *XINTFWD (valcontents)->intvar = XINT (newval);
+ if (*XINTFWD (valcontents)->intvar != XINT (newval))
+ error ("Value out of range for variable `%s'",
+ SDATA (SYMBOL_NAME (symbol)));
+ break;
- case Lisp_Boolfwd:
- *XINTPTR (valcontents) = NILP(newval) ? 0 : 1;
- break;
+ case Lisp_Misc_Boolfwd:
+ *XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1;
+ break;
- case Lisp_Objfwd:
- *XOBJFWD (valcontents) = newval;
- break;
+ case Lisp_Misc_Objfwd:
+ *XOBJFWD (valcontents)->objvar = newval;
- case Lisp_Buffer_Objfwd:
- {
- unsigned int offset = XUINT (valcontents);
- Lisp_Object type =
- *(Lisp_Object *)(offset + (char *)&buffer_local_types);
-
- if (! NILP (type) && ! NILP (newval)
- && XTYPE (newval) != XINT (type))
- buffer_slot_type_mismatch (valcontents, newval);
-
- *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer)
- = newval;
- break;
- }
+ /* If this variable is a default for something stored
+ in the buffer itself, such as default-fill-column,
+ find the buffers that don't have local values for it
+ and update them. */
+ if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults
+ && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1))
+ {
+ int offset = ((char *) XOBJFWD (valcontents)->objvar
+ - (char *) &buffer_defaults);
+ int idx = PER_BUFFER_IDX (offset);
+
+ Lisp_Object tail;
+
+ if (idx <= 0)
+ break;
+
+ for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
+ {
+ Lisp_Object buf;
+ struct buffer *b;
+
+ buf = Fcdr (XCAR (tail));
+ if (!BUFFERP (buf)) continue;
+ b = XBUFFER (buf);
+
+ if (! PER_BUFFER_VALUE_P (b, idx))
+ PER_BUFFER_VALUE (b, offset) = newval;
+ }
+ }
+ break;
+
+ case Lisp_Misc_Buffer_Objfwd:
+ {
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ Lisp_Object type;
+
+ type = PER_BUFFER_TYPE (offset);
+ if (! NILP (type) && ! NILP (newval)
+ && XTYPE (newval) != XINT (type))
+ buffer_slot_type_mismatch (offset);
+
+ if (buf == NULL)
+ buf = current_buffer;
+ PER_BUFFER_VALUE (buf, offset) = newval;
+ }
+ break;
+
+ case Lisp_Misc_Kboard_Objfwd:
+ {
+ char *base = (char *) current_kboard;
+ char *p = base + XKBOARD_OBJFWD (valcontents)->offset;
+ *(Lisp_Object *) p = newval;
+ }
+ break;
+
+ default:
+ goto def;
+ }
+ break;
default:
- valcontents = XSYMBOL (sym)->value;
- if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
- || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
- XCONS (XSYMBOL (sym)->value)->car = newval;
+ def:
+ valcontents = SYMBOL_VALUE (symbol);
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval;
else
- XSYMBOL (sym)->value = newval;
+ SET_SYMBOL_VALUE (symbol, newval);
}
}
-/* Set up the buffer-local symbol SYM for validity in the current
- buffer. VALCONTENTS is the contents of its value cell.
- Return the value forwarded one step past the buffer-local indicator. */
+/* Set up SYMBOL to refer to its global binding.
+ This makes it safe to alter the status of other bindings. */
-static Lisp_Object
-swap_in_symval_forwarding (sym, valcontents)
- Lisp_Object sym, valcontents;
-{
- /* valcontents is a list
- (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
-
- CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
- local_var_alist, that being the element whose car is this
- variable. Or it can be a pointer to the
- (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
- an element in its alist for this variable.
-
- If the current buffer is not BUFFER, we store the current
- REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
- appropriate alist element for the buffer now current and set up
- CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
- element, and store into BUFFER.
-
- Note that REALVALUE can be a forwarding pointer. */
+void
+swap_in_global_binding (symbol)
+ Lisp_Object symbol;
+{
+ Lisp_Object valcontents, cdr;
+ valcontents = SYMBOL_VALUE (symbol);
+ if (!BUFFER_LOCAL_VALUEP (valcontents)
+ && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ abort ();
+ cdr = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
+
+ /* Unload the previously loaded binding. */
+ Fsetcdr (XCAR (cdr),
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
+
+ /* Select the global binding in the symbol. */
+ XSETCAR (cdr, cdr);
+ store_symval_forwarding (symbol, valcontents, XCDR (cdr), NULL);
+
+ /* Indicate that the global binding is set up now. */
+ XBUFFER_LOCAL_VALUE (valcontents)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->buffer = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
+}
+
+/* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
+ VALCONTENTS is the contents of its value cell,
+ which points to a struct Lisp_Buffer_Local_Value.
+
+ Return the value forwarded one step past the buffer-local stage.
+ This could be another forwarding pointer. */
+
+static Lisp_Object
+swap_in_symval_forwarding (symbol, valcontents)
+ Lisp_Object symbol, valcontents;
+{
register Lisp_Object tem1;
- tem1 = XCONS (XCONS (valcontents)->cdr)->car;
- if (NILP (tem1) || current_buffer != XBUFFER (tem1))
+ tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer;
+
+ if (NILP (tem1)
+ || current_buffer != XBUFFER (tem1)
+ || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
+ && ! EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)))
{
- tem1 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
- Fsetcdr (tem1, do_symval_forwarding (XCONS (valcontents)->car));
- tem1 = assq_no_quit (sym, current_buffer->local_var_alist);
+ if (XSYMBOL (symbol)->indirect_variable)
+ symbol = indirect_variable (symbol);
+
+ /* Unload the previously loaded binding. */
+ tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
+ Fsetcdr (tem1,
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
+ /* Choose the new binding. */
+ tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
if (NILP (tem1))
- tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
- XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer);
- store_symval_forwarding (sym, XCONS (valcontents)->car, Fcdr (tem1));
+ {
+ if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
+ tem1 = assq_no_quit (symbol, XFRAME (selected_frame)->param_alist);
+ if (! NILP (tem1))
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
+ else
+ tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
+ }
+ else
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
+
+ /* Load the new binding. */
+ XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, tem1);
+ XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer);
+ XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
+ store_symval_forwarding (symbol,
+ XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
+ Fcdr (tem1), NULL);
}
- return XCONS (valcontents)->car;
+ return XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
\f
/* Find the value of a symbol, returning Qunbound if it's not bound.
This is helpful for code which just wants to get a variable's value
- if it has one, without signalling an error.
+ if it has one, without signaling an error.
Note that it must not be possible to quit
within this function. Great care is required for this. */
Lisp_Object
-find_symbol_value (sym)
- Lisp_Object sym;
+find_symbol_value (symbol)
+ Lisp_Object symbol;
{
- register Lisp_Object valcontents, tem1;
+ register Lisp_Object valcontents;
register Lisp_Object val;
- CHECK_SYMBOL (sym, 0);
- valcontents = XSYMBOL (sym)->value;
- retry:
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (valcontents))
-#else
- switch (XTYPE (valcontents))
-#endif
- {
- case Lisp_Buffer_Local_Value:
- case Lisp_Some_Buffer_Local_Value:
- valcontents = swap_in_symval_forwarding (sym, valcontents);
- goto retry;
+ CHECK_SYMBOL (symbol);
+ valcontents = SYMBOL_VALUE (symbol);
- case Lisp_Intfwd:
- XSET (val, Lisp_Int, *XINTPTR (valcontents));
- return val;
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ valcontents = swap_in_symval_forwarding (symbol, valcontents);
- case Lisp_Boolfwd:
- if (*XINTPTR (valcontents))
- return Qt;
- return Qnil;
+ if (MISCP (valcontents))
+ {
+ switch (XMISCTYPE (valcontents))
+ {
+ case Lisp_Misc_Intfwd:
+ XSETINT (val, *XINTFWD (valcontents)->intvar);
+ return val;
+
+ case Lisp_Misc_Boolfwd:
+ return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
- case Lisp_Objfwd:
- return *XOBJFWD (valcontents);
+ case Lisp_Misc_Objfwd:
+ return *XOBJFWD (valcontents)->objvar;
- case Lisp_Buffer_Objfwd:
- return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
+ case Lisp_Misc_Buffer_Objfwd:
+ return PER_BUFFER_VALUE (current_buffer,
+ XBUFFER_OBJFWD (valcontents)->offset);
- case Lisp_Void:
- return Qunbound;
+ case Lisp_Misc_Kboard_Objfwd:
+ return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
+ + (char *)current_kboard);
+ }
}
return valcontents;
}
DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
- "Return SYMBOL's value. Error if that is void.")
- (sym)
- Lisp_Object sym;
+ doc: /* Return SYMBOL's value. Error if that is void. */)
+ (symbol)
+ Lisp_Object symbol;
{
- Lisp_Object val = find_symbol_value (sym);
+ Lisp_Object val;
- if (EQ (val, Qunbound))
- return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
- else
+ val = find_symbol_value (symbol);
+ if (!EQ (val, Qunbound))
return val;
+
+ xsignal1 (Qvoid_variable, symbol);
}
DEFUN ("set", Fset, Sset, 2, 2, 0,
- "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
- (sym, newval)
- register Lisp_Object sym, newval;
+ doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
+ (symbol, newval)
+ register Lisp_Object symbol, newval;
{
- int voide = (XTYPE (newval) == Lisp_Void || EQ (newval, Qunbound));
+ return set_internal (symbol, newval, current_buffer, 0);
+}
-#ifndef RTPC_REGISTER_BUG
- register Lisp_Object valcontents, tem1, current_alist_element;
-#else /* RTPC_REGISTER_BUG */
- register Lisp_Object tem1;
- Lisp_Object valcontents, current_alist_element;
-#endif /* RTPC_REGISTER_BUG */
+/* Return 1 if SYMBOL currently has a let-binding
+ which was made in the buffer that is now current. */
- CHECK_SYMBOL (sym, 0);
- if (NILP (sym) || EQ (sym, Qt))
- return Fsignal (Qsetting_constant, Fcons (sym, Qnil));
- valcontents = XSYMBOL (sym)->value;
+static int
+let_shadows_buffer_binding_p (symbol)
+ Lisp_Object symbol;
+{
+ volatile struct specbinding *p;
- if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
- {
- register int idx = XUINT (valcontents);
- register int mask = *(int *)(idx + (char *) &buffer_local_flags);
- if (mask > 0)
- current_buffer->local_var_flags |= mask;
- }
+ for (p = specpdl_ptr - 1; p >= specpdl; p--)
+ if (p->func == NULL
+ && CONSP (p->symbol))
+ {
+ Lisp_Object let_bound_symbol = XCAR (p->symbol);
+ if ((EQ (symbol, let_bound_symbol)
+ || (XSYMBOL (let_bound_symbol)->indirect_variable
+ && EQ (symbol, indirect_variable (let_bound_symbol))))
+ && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
+ break;
+ }
- else if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
- || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
- {
- /* valcontents is actually a pointer to a cons heading something like:
- (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
+ return p >= specpdl;
+}
- BUFFER is the last buffer for which this symbol's value was
- made up to date.
+/* Store the value NEWVAL into SYMBOL.
+ If buffer-locality is an issue, BUF specifies which buffer to use.
+ (0 stands for the current buffer.)
+
+ If BINDFLAG is zero, then if this symbol is supposed to become
+ local in every buffer where it is set, then we make it local.
+ If BINDFLAG is nonzero, we don't do that. */
+
+Lisp_Object
+set_internal (symbol, newval, buf, bindflag)
+ register Lisp_Object symbol, newval;
+ struct buffer *buf;
+ int bindflag;
+{
+ int voide = EQ (newval, Qunbound);
- CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
- local_var_alist, that being the element whose car is this
- variable. Or it can be a pointer to the
- (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
- have an element in its alist for this variable (that is, if
- BUFFER sees the default value of this variable).
+ register Lisp_Object valcontents, innercontents, tem1, current_alist_element;
- If we want to examine or set the value and BUFFER is current,
- we just examine or set REALVALUE. If BUFFER is not current, we
- store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
- then find the appropriate alist element for the buffer now
- current and set up CURRENT-ALIST-ELEMENT. Then we set
- REALVALUE out of that element, and store into BUFFER.
+ if (buf == 0)
+ buf = current_buffer;
- If we are setting the variable and the current buffer does
- not have an alist entry for this variable, an alist entry is
- created.
+ /* If restoring in a dead buffer, do nothing. */
+ if (NILP (buf->name))
+ return newval;
- Note that REALVALUE can be a forwarding pointer. Each time
- it is examined or set, forwarding must be done. */
+ CHECK_SYMBOL (symbol);
+ if (SYMBOL_CONSTANT_P (symbol)
+ && (NILP (Fkeywordp (symbol))
+ || !EQ (newval, SYMBOL_VALUE (symbol))))
+ xsignal1 (Qsetting_constant, symbol);
- /* What value are we caching right now? */
- current_alist_element =
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
+ innercontents = valcontents = SYMBOL_VALUE (symbol);
+
+ if (BUFFER_OBJFWDP (valcontents))
+ {
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
+ if (idx > 0
+ && !bindflag
+ && !let_shadows_buffer_binding_p (symbol))
+ SET_PER_BUFFER_VALUE_P (buf, idx, 1);
+ }
+ else if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ /* valcontents is a struct Lisp_Buffer_Local_Value. */
+ if (XSYMBOL (symbol)->indirect_variable)
+ symbol = indirect_variable (symbol);
+
+ /* What binding is loaded right now? */
+ current_alist_element
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
/* If the current buffer is not the buffer whose binding is
- currently cached, or if it's a Lisp_Buffer_Local_Value and
- we're looking at the default value, the cache is invalid; we
- need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
- if ((current_buffer
- != XBUFFER (XCONS (XCONS (valcontents)->cdr)->car))
- || (XTYPE (valcontents) == Lisp_Buffer_Local_Value
- && EQ (XCONS (current_alist_element)->car,
+ loaded, or if there may be frame-local bindings and the frame
+ isn't the right one, or if it's a Lisp_Buffer_Local_Value and
+ the default binding is loaded, the loaded binding may be the
+ wrong one. */
+ if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
+ || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
+ || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
+ && !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))
+ || (BUFFER_LOCAL_VALUEP (valcontents)
+ && EQ (XCAR (current_alist_element),
current_alist_element)))
{
- /* Write out the cached value for the old buffer; copy it
- back to its alist element. This works if the current
- buffer only sees the default value, too. */
+ /* The currently loaded binding is not necessarily valid.
+ We need to unload it, and choose a new binding. */
+
+ /* Write out `realvalue' to the old loaded binding. */
Fsetcdr (current_alist_element,
- do_symval_forwarding (XCONS (valcontents)->car));
+ do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
+
+ /* Find the new binding. */
+ tem1 = Fassq (symbol, buf->local_var_alist);
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
- /* Find the new value for CURRENT-ALIST-ELEMENT. */
- tem1 = Fassq (sym, current_buffer->local_var_alist);
if (NILP (tem1))
{
/* This buffer still sees the default value. */
/* If the variable is a Lisp_Some_Buffer_Local_Value,
+ or if this is `let' rather than `set',
make CURRENT-ALIST-ELEMENT point to itself,
- indicating that we're seeing the default value. */
- if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
- tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
+ indicating that we're seeing the default value.
+ Likewise if the variable has been let-bound
+ in the current buffer. */
+ if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents)
+ || let_shadows_buffer_binding_p (symbol))
+ {
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
- /* If it's a Lisp_Buffer_Local_Value, give this buffer a
- new assoc for a local value and set
- CURRENT-ALIST-ELEMENT to point to that. */
+ if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
+ tem1 = Fassq (symbol,
+ XFRAME (selected_frame)->param_alist);
+
+ if (! NILP (tem1))
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
+ else
+ tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
+ }
+ /* If it's a Lisp_Buffer_Local_Value, being set not bound,
+ and we're not within a let that was made for this buffer,
+ create a new buffer-local binding for the variable.
+ That means, give this buffer a new assoc for a local value
+ and load that binding. */
else
{
- tem1 = Fcons (sym, Fcdr (current_alist_element));
- current_buffer->local_var_alist =
- Fcons (tem1, current_buffer->local_var_alist);
+ tem1 = Fcons (symbol, XCDR (current_alist_element));
+ buf->local_var_alist
+ = Fcons (tem1, buf->local_var_alist);
}
}
- /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
- /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
- XSET (XCONS (XCONS (valcontents)->cdr)->car,
- Lisp_Buffer, current_buffer);
+ /* Record which binding is now loaded. */
+ XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr,
+ tem1);
+
+ /* Set `buffer' and `frame' slots for thebinding now loaded. */
+ XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf);
+ XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
}
- valcontents = XCONS (valcontents)->car;
+ innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
/* If storing void (making the symbol void), forward only through
buffer-local indicator, not through Lisp_Objfwd, etc. */
if (voide)
- store_symval_forwarding (sym, Qnil, newval);
+ store_symval_forwarding (symbol, Qnil, newval, buf);
else
- store_symval_forwarding (sym, valcontents, newval);
+ store_symval_forwarding (symbol, innercontents, newval, buf);
+
+ /* If we just set a variable whose current binding is frame-local,
+ store the new value in the frame parameter too. */
+
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ /* What binding is loaded right now? */
+ current_alist_element
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
+
+ /* If the current buffer is not the buffer whose binding is
+ loaded, or if there may be frame-local bindings and the frame
+ isn't the right one, or if it's a Lisp_Buffer_Local_Value and
+ the default binding is loaded, the loaded binding may be the
+ wrong one. */
+ if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame)
+ XSETCDR (current_alist_element, newval);
+ }
return newval;
}
\f
/* Access or set a buffer-local symbol's default value. */
-/* Return the default value of SYM, but don't check for voidness.
- Return Qunbound or a Lisp_Void object if it is void. */
+/* Return the default value of SYMBOL, but don't check for voidness.
+ Return Qunbound if it is void. */
Lisp_Object
-default_value (sym)
- Lisp_Object sym;
+default_value (symbol)
+ Lisp_Object symbol;
{
register Lisp_Object valcontents;
- CHECK_SYMBOL (sym, 0);
- valcontents = XSYMBOL (sym)->value;
+ CHECK_SYMBOL (symbol);
+ valcontents = SYMBOL_VALUE (symbol);
/* For a built-in buffer-local variable, get the default value
rather than letting do_symval_forwarding get the current value. */
- if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
+ if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XUINT (valcontents);
-
- if (*(int *) (idx + (char *) &buffer_local_flags) != 0)
- return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ if (PER_BUFFER_IDX (offset) != 0)
+ return PER_BUFFER_DEFAULT (offset);
}
/* Handle user-created local variables. */
- if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
- || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
/* If var is set up for a buffer that lacks a local value for it,
the current value is nominally the default value.
- But the current value slot may be more up to date, since
+ But the `realvalue' slot may be more up to date, since
ordinary setq stores just that slot. So use that. */
Lisp_Object current_alist_element, alist_element_car;
current_alist_element
- = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
- alist_element_car = XCONS (current_alist_element)->car;
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
+ alist_element_car = XCAR (current_alist_element);
if (EQ (alist_element_car, current_alist_element))
- return do_symval_forwarding (XCONS (valcontents)->car);
+ return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue);
else
- return XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr;
+ return XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
}
/* For other variables, get the current value. */
return do_symval_forwarding (valcontents);
}
DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
- "Return T if SYMBOL has a non-void default value.\n\
-This is the value that is seen in buffers that do not have their own values\n\
-for this variable.")
- (sym)
- Lisp_Object sym;
+ doc: /* Return t if SYMBOL has a non-void default value.
+This is the value that is seen in buffers that do not have their own values
+for this variable. */)
+ (symbol)
+ Lisp_Object symbol;
{
register Lisp_Object value;
- value = default_value (sym);
- return (XTYPE (value) == Lisp_Void || EQ (value, Qunbound)
- ? Qnil : Qt);
+ value = default_value (symbol);
+ return (EQ (value, Qunbound) ? Qnil : Qt);
}
DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
- "Return SYMBOL's default value.\n\
-This is the value that is seen in buffers that do not have their own values\n\
-for this variable. The default value is meaningful for variables with\n\
-local bindings in certain buffers.")
- (sym)
- Lisp_Object sym;
+ doc: /* Return SYMBOL's default value.
+This is the value that is seen in buffers that do not have their own values
+for this variable. The default value is meaningful for variables with
+local bindings in certain buffers. */)
+ (symbol)
+ Lisp_Object symbol;
{
register Lisp_Object value;
- value = default_value (sym);
- if (XTYPE (value) == Lisp_Void || EQ (value, Qunbound))
- return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
- return value;
+ value = default_value (symbol);
+ if (!EQ (value, Qunbound))
+ return value;
+
+ xsignal1 (Qvoid_variable, symbol);
}
DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
- "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
-The default value is seen in buffers that do not have their own values\n\
-for this variable.")
- (sym, value)
- Lisp_Object sym, value;
+ doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
+The default value is seen in buffers that do not have their own values
+for this variable. */)
+ (symbol, value)
+ Lisp_Object symbol, value;
{
register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
- CHECK_SYMBOL (sym, 0);
- valcontents = XSYMBOL (sym)->value;
+ CHECK_SYMBOL (symbol);
+ valcontents = SYMBOL_VALUE (symbol);
/* Handle variables like case-fold-search that have special slots
in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
variables. */
- if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
+ if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XUINT (valcontents);
-#ifndef RTPC_REGISTER_BUG
- register struct buffer *b;
-#else
- struct buffer *b;
-#endif
- register int mask = *(int *) (idx + (char *) &buffer_local_flags);
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
+
+ PER_BUFFER_DEFAULT (offset) = value;
- if (mask > 0)
+ /* If this variable is not always local in all buffers,
+ set it in the buffers that don't nominally have a local value. */
+ if (idx > 0)
{
- *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
+ struct buffer *b;
+
for (b = all_buffers; b; b = b->next)
- if (!(b->local_var_flags & mask))
- *(Lisp_Object *)(idx + (char *) b) = value;
+ if (!PER_BUFFER_VALUE_P (b, idx))
+ PER_BUFFER_VALUE (b, offset) = value;
}
return value;
}
- if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
- XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
- return Fset (sym, value);
+ if (!BUFFER_LOCAL_VALUEP (valcontents)
+ && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ return Fset (symbol, value);
- /* Store new value into the DEFAULT-VALUE slot */
- XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr = value;
+ /* Store new value into the DEFAULT-VALUE slot. */
+ XSETCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, value);
- /* If that slot is current, we must set the REALVALUE slot too */
- current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
+ /* If the default binding is now loaded, set the REALVALUE slot too. */
+ current_alist_element
+ = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
alist_element_buffer = Fcar (current_alist_element);
if (EQ (alist_element_buffer, current_alist_element))
- store_symval_forwarding (sym, XCONS (valcontents)->car, value);
+ store_symval_forwarding (symbol,
+ XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
+ value, NULL);
return value;
}
-DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
- "\
-(setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
-VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
-not have their own values for this variable.")
- (args)
+DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
+ doc: /* Set the default value of variable VAR to VALUE.
+VAR, the variable name, is literal (not evaluated);
+VALUE is an expression: it is evaluated and its value returned.
+The default value of a variable is seen in buffers
+that do not have their own values for the variable.
+
+More generally, you can use multiple variables and values, as in
+ (setq-default VAR VALUE VAR VALUE...)
+This sets each VAR's default value to the corresponding VALUE.
+The VALUE for the Nth VAR can refer to the new default values
+of previous VARs.
+usage: (setq-default [VAR VALUE...]) */)
+ (args)
Lisp_Object args;
{
register Lisp_Object args_left;
- register Lisp_Object val, sym;
+ register Lisp_Object val, symbol;
struct gcpro gcpro1;
if (NILP (args))
do
{
val = Feval (Fcar (Fcdr (args_left)));
- sym = Fcar (args_left);
- Fset_default (sym, val);
- args_left = Fcdr (Fcdr (args_left));
+ symbol = XCAR (args_left);
+ Fset_default (symbol, val);
+ args_left = Fcdr (XCDR (args_left));
}
while (!NILP (args_left));
/* Lisp functions for creating and removing buffer-local variables. */
DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
- 1, 1, "vMake Variable Buffer Local: ",
- "Make VARIABLE have a separate value for each buffer.\n\
-At any time, the value for the current buffer is in effect.\n\
-There is also a default value which is seen in any buffer which has not yet\n\
-set its own value.\n\
-Using `set' or `setq' to set the variable causes it to have a separate value\n\
-for the current buffer if it was previously using the default value.\n\
-The function `default-value' gets the default value and `set-default' sets it.")
- (sym)
- register Lisp_Object sym;
-{
- register Lisp_Object tem, valcontents;
-
- CHECK_SYMBOL (sym, 0);
-
- if (EQ (sym, Qnil) || EQ (sym, Qt))
- error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
-
- valcontents = XSYMBOL (sym)->value;
- if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) ||
- (XTYPE (valcontents) == Lisp_Buffer_Objfwd))
- return sym;
- if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
+ 1, 1, "vMake Variable Buffer Local: ",
+ doc: /* Make VARIABLE become buffer-local whenever it is set.
+At any time, the value for the current buffer is in effect,
+unless the variable has never been set in this buffer,
+in which case the default value is in effect.
+Note that binding the variable with `let', or setting it while
+a `let'-style binding made in this buffer is in effect,
+does not make the variable buffer-local. Return VARIABLE.
+
+In most cases it is better to use `make-local-variable',
+which makes a variable local in just one buffer.
+
+The function `default-value' gets the default value and `set-default' sets it. */)
+ (variable)
+ register Lisp_Object variable;
+{
+ register Lisp_Object tem, valcontents, newval;
+
+ CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
+
+ valcontents = SYMBOL_VALUE (variable);
+ if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
+ error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
+
+ if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
+ return variable;
+ if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
- XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
- return sym;
+ XMISCTYPE (SYMBOL_VALUE (variable)) = Lisp_Misc_Buffer_Local_Value;
+ return variable;
}
if (EQ (valcontents, Qunbound))
- XSYMBOL (sym)->value = Qnil;
- tem = Fcons (Qnil, Fsymbol_value (sym));
- XCONS (tem)->car = tem;
- XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Fcurrent_buffer (), tem));
- XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
- return sym;
+ SET_SYMBOL_VALUE (variable, Qnil);
+ tem = Fcons (Qnil, Fsymbol_value (variable));
+ XSETCAR (tem, tem);
+ newval = allocate_misc ();
+ XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
+ XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable);
+ XBUFFER_LOCAL_VALUE (newval)->buffer = Fcurrent_buffer ();
+ XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
+ SET_SYMBOL_VALUE (variable, newval);
+ return variable;
}
DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
- 1, 1, "vMake Local Variable: ",
- "Make VARIABLE have a separate value in the current buffer.\n\
-Other buffers will continue to share a common default value.\n\
-See also `make-variable-buffer-local'.\n\n\
-If the variable is already arranged to become local when set,\n\
-this function causes a local value to exist for this buffer,\n\
-just as if the variable were set.")
- (sym)
- register Lisp_Object sym;
+ 1, 1, "vMake Local Variable: ",
+ doc: /* Make VARIABLE have a separate value in the current buffer.
+Other buffers will continue to share a common default value.
+\(The buffer-local value of VARIABLE starts out as the same value
+VARIABLE previously had. If VARIABLE was void, it remains void.\)
+Return VARIABLE.
+
+If the variable is already arranged to become local when set,
+this function causes a local value to exist for this buffer,
+just as setting the variable would do.
+
+This function returns VARIABLE, and therefore
+ (set (make-local-variable 'VARIABLE) VALUE-EXP)
+works.
+
+See also `make-variable-buffer-local'.
+
+Do not use `make-local-variable' to make a hook variable buffer-local.
+Instead, use `add-hook' and specify t for the LOCAL argument. */)
+ (variable)
+ register Lisp_Object variable;
{
register Lisp_Object tem, valcontents;
- CHECK_SYMBOL (sym, 0);
+ CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
- if (EQ (sym, Qnil) || EQ (sym, Qt))
- error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
+ valcontents = SYMBOL_VALUE (variable);
+ if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
+ error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
- valcontents = XSYMBOL (sym)->value;
- if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
- || XTYPE (valcontents) == Lisp_Buffer_Objfwd)
+ if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
{
- tem = Fboundp (sym);
-
+ tem = Fboundp (variable);
+
/* Make sure the symbol has a local value in this particular buffer,
by setting it to the same value it already has. */
- Fset (sym, (EQ (tem, Qt) ? Fsymbol_value (sym) : Qunbound));
- return sym;
+ Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
+ return variable;
}
- /* Make sure sym is set up to hold per-buffer values */
- if (XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
+ /* Make sure symbol is set up to hold per-buffer values. */
+ if (!SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
- if (EQ (valcontents, Qunbound))
- XSYMBOL (sym)->value = Qnil;
+ Lisp_Object newval;
tem = Fcons (Qnil, do_symval_forwarding (valcontents));
- XCONS (tem)->car = tem;
- XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Qnil, tem));
- XSETTYPE (XSYMBOL (sym)->value, Lisp_Some_Buffer_Local_Value);
+ XSETCAR (tem, tem);
+ newval = allocate_misc ();
+ XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
+ XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable);
+ XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
+ SET_SYMBOL_VALUE (variable, newval);;
}
- /* Make sure this buffer has its own value of sym */
- tem = Fassq (sym, current_buffer->local_var_alist);
+ /* Make sure this buffer has its own value of symbol. */
+ tem = Fassq (variable, current_buffer->local_var_alist);
if (NILP (tem))
{
+ /* Swap out any local binding for some other buffer, and make
+ sure the current value is permanently recorded, if it's the
+ default value. */
+ find_symbol_value (variable);
+
current_buffer->local_var_alist
- = Fcons (Fcons (sym, XCONS (XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->cdr)->cdr),
+ = Fcons (Fcons (variable, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->cdr)),
current_buffer->local_var_alist);
/* Make sure symbol does not think it is set up for this buffer;
- force it to look once again for this buffer's value */
+ force it to look once again for this buffer's value. */
{
- /* This local variable avoids "expression too complex" on IBM RT. */
- Lisp_Object xs;
-
- xs = XSYMBOL (sym)->value;
- if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car))
- XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil;
+ Lisp_Object *pvalbuf;
+
+ valcontents = SYMBOL_VALUE (variable);
+
+ pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
+ if (current_buffer == XBUFFER (*pvalbuf))
+ *pvalbuf = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
}
}
- /* If the symbol forwards into a C variable, then swap in the
- variable for this buffer immediately. If C code modifies the
- variable before we swap in, then that new value will clobber the
- default value the next time we swap. */
- valcontents = XCONS (XSYMBOL (sym)->value)->car;
- if (XTYPE (valcontents) == Lisp_Intfwd
- || XTYPE (valcontents) == Lisp_Boolfwd
- || XTYPE (valcontents) == Lisp_Objfwd)
- swap_in_symval_forwarding (sym, XSYMBOL (sym)->value);
+ /* If the symbol forwards into a C variable, then load the binding
+ for this buffer now. If C code modifies the variable before we
+ load the binding in, then that new value will clobber the default
+ binding the next time we unload it. */
+ valcontents = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->realvalue;
+ if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
+ swap_in_symval_forwarding (variable, SYMBOL_VALUE (variable));
- return sym;
+ return variable;
}
DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
- 1, 1, "vKill Local Variable: ",
- "Make VARIABLE no longer have a separate value in the current buffer.\n\
-From now on the default value will apply in this buffer.")
- (sym)
- register Lisp_Object sym;
+ 1, 1, "vKill Local Variable: ",
+ doc: /* Make VARIABLE no longer have a separate value in the current buffer.
+From now on the default value will apply in this buffer. Return VARIABLE. */)
+ (variable)
+ register Lisp_Object variable;
{
register Lisp_Object tem, valcontents;
- CHECK_SYMBOL (sym, 0);
+ CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
- valcontents = XSYMBOL (sym)->value;
+ valcontents = SYMBOL_VALUE (variable);
- if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
+ if (BUFFER_OBJFWDP (valcontents))
{
- register int idx = XUINT (valcontents);
- register int mask = *(int *) (idx + (char *) &buffer_local_flags);
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
- if (mask > 0)
+ if (idx > 0)
{
- *(Lisp_Object *)(idx + (char *) current_buffer)
- = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
- current_buffer->local_var_flags &= ~mask;
+ SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
+ PER_BUFFER_VALUE (current_buffer, offset)
+ = PER_BUFFER_DEFAULT (offset);
}
- return sym;
+ return variable;
}
- if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
- XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
- return sym;
+ if (!BUFFER_LOCAL_VALUEP (valcontents)
+ && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ return variable;
- /* Get rid of this buffer's alist element, if any */
+ /* Get rid of this buffer's alist element, if any. */
- tem = Fassq (sym, current_buffer->local_var_alist);
+ tem = Fassq (variable, current_buffer->local_var_alist);
if (!NILP (tem))
- current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist);
+ current_buffer->local_var_alist
+ = Fdelq (tem, current_buffer->local_var_alist);
- /* Make sure symbol does not think it is set up for this buffer;
- force it to look once again for this buffer's value */
+ /* If the symbol is set up with the current buffer's binding
+ loaded, recompute its value. We have to do it now, or else
+ forwarded objects won't work right. */
{
- Lisp_Object sv;
- sv = XSYMBOL (sym)->value;
- if (current_buffer == XBUFFER (XCONS (XCONS (sv)->cdr)->car))
- XCONS (XCONS (sv)->cdr)->car = Qnil;
+ Lisp_Object *pvalbuf, buf;
+ valcontents = SYMBOL_VALUE (variable);
+ pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
+ XSETBUFFER (buf, current_buffer);
+ if (EQ (buf, *pvalbuf))
+ {
+ *pvalbuf = Qnil;
+ XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
+ find_symbol_value (variable);
+ }
}
- return sym;
+ return variable;
+}
+
+/* Lisp functions for creating and removing buffer-local variables. */
+
+DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
+ 1, 1, "vMake Variable Frame Local: ",
+ doc: /* Enable VARIABLE to have frame-local bindings.
+This does not create any frame-local bindings for VARIABLE,
+it just makes them possible.
+
+A frame-local binding is actually a frame parameter value.
+If a frame F has a value for the frame parameter named VARIABLE,
+that also acts as a frame-local binding for VARIABLE in F--
+provided this function has been called to enable VARIABLE
+to have frame-local bindings at all.
+
+The only way to create a frame-local binding for VARIABLE in a frame
+is to set the VARIABLE frame parameter of that frame. See
+`modify-frame-parameters' for how to set frame parameters.
+
+Buffer-local bindings take precedence over frame-local bindings. */)
+ (variable)
+ register Lisp_Object variable;
+{
+ register Lisp_Object tem, valcontents, newval;
+
+ CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
+
+ valcontents = SYMBOL_VALUE (variable);
+ if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)
+ || BUFFER_OBJFWDP (valcontents))
+ error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
+
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ XBUFFER_LOCAL_VALUE (valcontents)->check_frame = 1;
+ return variable;
+ }
+
+ if (EQ (valcontents, Qunbound))
+ SET_SYMBOL_VALUE (variable, Qnil);
+ tem = Fcons (Qnil, Fsymbol_value (variable));
+ XSETCAR (tem, tem);
+ newval = allocate_misc ();
+ XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
+ XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable);
+ XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
+ XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
+ XBUFFER_LOCAL_VALUE (newval)->check_frame = 1;
+ XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
+ SET_SYMBOL_VALUE (variable, newval);
+ return variable;
+}
+
+DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
+ 1, 2, 0,
+ doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
+BUFFER defaults to the current buffer. */)
+ (variable, buffer)
+ register Lisp_Object variable, buffer;
+{
+ Lisp_Object valcontents;
+ register struct buffer *buf;
+
+ if (NILP (buffer))
+ buf = current_buffer;
+ else
+ {
+ CHECK_BUFFER (buffer);
+ buf = XBUFFER (buffer);
+ }
+
+ CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
+
+ valcontents = SYMBOL_VALUE (variable);
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ Lisp_Object tail, elt;
+
+ for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ if (EQ (variable, XCAR (elt)))
+ return Qt;
+ }
+ }
+ if (BUFFER_OBJFWDP (valcontents))
+ {
+ int offset = XBUFFER_OBJFWD (valcontents)->offset;
+ int idx = PER_BUFFER_IDX (offset);
+ if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
+ return Qt;
+ }
+ return Qnil;
+}
+
+DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
+ 1, 2, 0,
+ doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
+More precisely, this means that setting the variable \(with `set' or`setq'),
+while it does not have a `let'-style binding that was made in BUFFER,
+will produce a buffer local binding. See Info node
+`(elisp)Creating Buffer-Local'.
+BUFFER defaults to the current buffer. */)
+ (variable, buffer)
+ register Lisp_Object variable, buffer;
+{
+ Lisp_Object valcontents;
+ register struct buffer *buf;
+
+ if (NILP (buffer))
+ buf = current_buffer;
+ else
+ {
+ CHECK_BUFFER (buffer);
+ buf = XBUFFER (buffer);
+ }
+
+ CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
+
+ valcontents = SYMBOL_VALUE (variable);
+
+ /* This means that make-variable-buffer-local was done. */
+ if (BUFFER_LOCAL_VALUEP (valcontents))
+ return Qt;
+ /* All these slots become local if they are set. */
+ if (BUFFER_OBJFWDP (valcontents))
+ return Qt;
+ if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
+ {
+ Lisp_Object tail, elt;
+ for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ if (EQ (variable, XCAR (elt)))
+ return Qt;
+ }
+ }
+ return Qnil;
+}
+
+DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
+ 1, 1, 0,
+ doc: /* Return a value indicating where VARIABLE's current binding comes from.
+If the current binding is buffer-local, the value is the current buffer.
+If the current binding is frame-local, the value is the selected frame.
+If the current binding is global (the default), the value is nil. */)
+ (variable)
+ register Lisp_Object variable;
+{
+ Lisp_Object valcontents;
+
+ CHECK_SYMBOL (variable);
+ variable = indirect_variable (variable);
+
+ /* Make sure the current binding is actually swapped in. */
+ find_symbol_value (variable);
+
+ valcontents = XSYMBOL (variable)->value;
+
+ if (BUFFER_LOCAL_VALUEP (valcontents)
+ || SOME_BUFFER_LOCAL_VALUEP (valcontents)
+ || BUFFER_OBJFWDP (valcontents))
+ {
+ /* For a local variable, record both the symbol and which
+ buffer's or frame's value we are saving. */
+ if (!NILP (Flocal_variable_p (variable, Qnil)))
+ return Fcurrent_buffer ();
+ else if (!BUFFER_OBJFWDP (valcontents)
+ && XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame)
+ return XBUFFER_LOCAL_VALUE (valcontents)->frame;
+ }
+
+ return Qnil;
}
\f
/* Find the function at the end of a chain of symbol function indirections. */
error if the chain ends up unbound. */
Lisp_Object
indirect_function (object)
- register Lisp_Object object;
+ register Lisp_Object object;
{
Lisp_Object tortoise, hare;
for (;;)
{
- if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
+ if (!SYMBOLP (hare) || EQ (hare, Qunbound))
break;
hare = XSYMBOL (hare)->function;
- if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
+ if (!SYMBOLP (hare) || EQ (hare, Qunbound))
break;
hare = XSYMBOL (hare)->function;
tortoise = XSYMBOL (tortoise)->function;
if (EQ (hare, tortoise))
- Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
+ xsignal1 (Qcyclic_function_indirection, object);
}
return hare;
}
-DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
- "Return the function at the end of OBJECT's function chain.\n\
-If OBJECT is a symbol, follow all function indirections and return the final\n\
-function binding.\n\
-If OBJECT is not a symbol, just return it.\n\
-Signal a void-function error if the final symbol is unbound.\n\
-Signal a cyclic-function-indirection error if there is a loop in the\n\
-function chain of symbols.")
- (object)
- register Lisp_Object object;
+DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
+ doc: /* Return the function at the end of OBJECT's function chain.
+If OBJECT is not a symbol, just return it. Otherwise, follow all
+function indirections to find the final function binding and return it.
+If the final symbol in the chain is unbound, signal a void-function error.
+Optional arg NOERROR non-nil means to return nil instead of signalling.
+Signal a cyclic-function-indirection error if there is a loop in the
+function chain of symbols. */)
+ (object, noerror)
+ register Lisp_Object object;
+ Lisp_Object noerror;
{
Lisp_Object result;
- result = indirect_function (object);
+ /* Optimize for no indirection. */
+ result = object;
+ if (SYMBOLP (result) && !EQ (result, Qunbound)
+ && (result = XSYMBOL (result)->function, SYMBOLP (result)))
+ result = indirect_function (result);
+ if (!EQ (result, Qunbound))
+ return result;
+
+ if (NILP (noerror))
+ xsignal1 (Qvoid_function, object);
- if (EQ (result, Qunbound))
- return Fsignal (Qvoid_function, Fcons (object, Qnil));
- return result;
+ return Qnil;
}
\f
/* Extract and set vector and string elements */
DEFUN ("aref", Faref, Saref, 2, 2, 0,
- "Return the element of ARRAY at index INDEX.\n\
-ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
- (array, idx)
+ doc: /* Return the element of ARRAY at index IDX.
+ARRAY may be a vector, a string, a char-table, a bool-vector,
+or a byte-code object. IDX starts at 0. */)
+ (array, idx)
register Lisp_Object array;
Lisp_Object idx;
{
register int idxval;
- CHECK_NUMBER (idx, 1);
+ CHECK_NUMBER (idx);
idxval = XINT (idx);
- if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String
- && XTYPE (array) != Lisp_Compiled)
- array = wrong_type_argument (Qarrayp, array);
- if (idxval < 0 || idxval >= XVECTOR (array)->size)
- args_out_of_range (array, idx);
- if (XTYPE (array) == Lisp_String)
+ if (STRINGP (array))
+ {
+ int c, idxval_byte;
+
+ if (idxval < 0 || idxval >= SCHARS (array))
+ args_out_of_range (array, idx);
+ if (! STRING_MULTIBYTE (array))
+ return make_number ((unsigned char) SREF (array, idxval));
+ idxval_byte = string_char_to_byte (array, idxval);
+
+ c = STRING_CHAR (SDATA (array) + idxval_byte,
+ SBYTES (array) - idxval_byte);
+ return make_number (c);
+ }
+ else if (BOOL_VECTOR_P (array))
+ {
+ int val;
+
+ if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ args_out_of_range (array, idx);
+
+ val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
+ return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil);
+ }
+ else if (CHAR_TABLE_P (array))
{
Lisp_Object val;
- XFASTINT (val) = (unsigned char) XSTRING (array)->data[idxval];
- return val;
+
+ val = Qnil;
+
+ if (idxval < 0)
+ args_out_of_range (array, idx);
+ if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
+ {
+ if (! SINGLE_BYTE_CHAR_P (idxval))
+ args_out_of_range (array, idx);
+ /* For ASCII and 8-bit European characters, the element is
+ stored in the top table. */
+ val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ {
+ int default_slot
+ = (idxval < 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
+ : idxval < 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
+ : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC);
+ val = XCHAR_TABLE (array)->contents[default_slot];
+ }
+ if (NILP (val))
+ val = XCHAR_TABLE (array)->defalt;
+ while (NILP (val)) /* Follow parents until we find some value. */
+ {
+ array = XCHAR_TABLE (array)->parent;
+ if (NILP (array))
+ return Qnil;
+ val = XCHAR_TABLE (array)->contents[idxval];
+ if (NILP (val))
+ val = XCHAR_TABLE (array)->defalt;
+ }
+ return val;
+ }
+ else
+ {
+ int code[4], i;
+ Lisp_Object sub_table;
+ Lisp_Object current_default;
+
+ SPLIT_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
+
+ /* Here, the possible range of CODE[0] (== charset ID) is
+ 128..MAX_CHARSET. Since the top level char table contains
+ data for multibyte characters after 256th element, we must
+ increment CODE[0] by 128 to get a correct index. */
+ code[0] += 128;
+ code[3] = -1; /* anchor */
+
+ try_parent_char_table:
+ current_default = XCHAR_TABLE (array)->defalt;
+ sub_table = array;
+ for (i = 0; code[i] >= 0; i++)
+ {
+ val = XCHAR_TABLE (sub_table)->contents[code[i]];
+ if (SUB_CHAR_TABLE_P (val))
+ {
+ sub_table = val;
+ if (! NILP (XCHAR_TABLE (sub_table)->defalt))
+ current_default = XCHAR_TABLE (sub_table)->defalt;
+ }
+ else
+ {
+ if (NILP (val))
+ val = current_default;
+ if (NILP (val))
+ {
+ array = XCHAR_TABLE (array)->parent;
+ if (!NILP (array))
+ goto try_parent_char_table;
+ }
+ return val;
+ }
+ }
+ /* Reaching here means IDXVAL is a generic character in
+ which each character or a group has independent value.
+ Essentially it's nonsense to get a value for such a
+ generic character, but for backward compatibility, we try
+ the default value and parent. */
+ val = current_default;
+ if (NILP (val))
+ {
+ array = XCHAR_TABLE (array)->parent;
+ if (!NILP (array))
+ goto try_parent_char_table;
+ }
+ return val;
+ }
}
else
- return XVECTOR (array)->contents[idxval];
+ {
+ int size = 0;
+ if (VECTORP (array))
+ size = XVECTOR (array)->size;
+ else if (COMPILEDP (array))
+ size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
+ else
+ wrong_type_argument (Qarrayp, array);
+
+ if (idxval < 0 || idxval >= size)
+ args_out_of_range (array, idx);
+ return XVECTOR (array)->contents[idxval];
+ }
}
DEFUN ("aset", Faset, Saset, 3, 3, 0,
- "Store into the element of ARRAY at index IDX the value NEWELT.\n\
-ARRAY may be a vector or a string. IDX starts at 0.")
- (array, idx, newelt)
+ doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
+Return NEWELT. ARRAY may be a vector, a string, a char-table or a
+bool-vector. IDX starts at 0. */)
+ (array, idx, newelt)
register Lisp_Object array;
Lisp_Object idx, newelt;
{
register int idxval;
- CHECK_NUMBER (idx, 1);
+ CHECK_NUMBER (idx);
idxval = XINT (idx);
- if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String)
- array = wrong_type_argument (Qarrayp, array);
- if (idxval < 0 || idxval >= XVECTOR (array)->size)
- args_out_of_range (array, idx);
+ CHECK_ARRAY (array, Qarrayp);
CHECK_IMPURE (array);
- if (XTYPE (array) == Lisp_Vector)
- XVECTOR (array)->contents[idxval] = newelt;
+ if (VECTORP (array))
+ {
+ if (idxval < 0 || idxval >= XVECTOR (array)->size)
+ args_out_of_range (array, idx);
+ XVECTOR (array)->contents[idxval] = newelt;
+ }
+ else if (BOOL_VECTOR_P (array))
+ {
+ int val;
+
+ if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ args_out_of_range (array, idx);
+
+ val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
+
+ if (! NILP (newelt))
+ val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR);
+ else
+ val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR));
+ XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val;
+ }
+ else if (CHAR_TABLE_P (array))
+ {
+ if (idxval < 0)
+ args_out_of_range (array, idx);
+ if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
+ {
+ if (! SINGLE_BYTE_CHAR_P (idxval))
+ args_out_of_range (array, idx);
+ XCHAR_TABLE (array)->contents[idxval] = newelt;
+ }
+ else
+ {
+ int code[4], i;
+ Lisp_Object val;
+
+ SPLIT_CHAR (idxval, code[0], code[1], code[2]);
+ if (code[1] < 32) code[1] = -1;
+ else if (code[2] < 32) code[2] = -1;
+
+ /* See the comment of the corresponding part in Faref. */
+ code[0] += 128;
+ code[3] = -1; /* anchor */
+ for (i = 0; code[i + 1] >= 0; i++)
+ {
+ val = XCHAR_TABLE (array)->contents[code[i]];
+ if (SUB_CHAR_TABLE_P (val))
+ array = val;
+ else
+ {
+ Lisp_Object temp;
+
+ /* VAL is a leaf. Create a sub char table with the
+ initial value VAL and look into it. */
+
+ temp = make_sub_char_table (val);
+ XCHAR_TABLE (array)->contents[code[i]] = temp;
+ array = temp;
+ }
+ }
+ XCHAR_TABLE (array)->contents[code[i]] = newelt;
+ }
+ }
+ else if (STRING_MULTIBYTE (array))
+ {
+ int idxval_byte, prev_bytes, new_bytes, nbytes;
+ unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
+
+ if (idxval < 0 || idxval >= SCHARS (array))
+ args_out_of_range (array, idx);
+ CHECK_NUMBER (newelt);
+
+ nbytes = SBYTES (array);
+
+ idxval_byte = string_char_to_byte (array, idxval);
+ p1 = SDATA (array) + idxval_byte;
+ PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes);
+ new_bytes = CHAR_STRING (XINT (newelt), p0);
+ if (prev_bytes != new_bytes)
+ {
+ /* We must relocate the string data. */
+ int nchars = SCHARS (array);
+ unsigned char *str;
+ USE_SAFE_ALLOCA;
+
+ SAFE_ALLOCA (str, unsigned char *, nbytes);
+ bcopy (SDATA (array), str, nbytes);
+ allocate_string_data (XSTRING (array), nchars,
+ nbytes + new_bytes - prev_bytes);
+ bcopy (str, SDATA (array), idxval_byte);
+ p1 = SDATA (array) + idxval_byte;
+ bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
+ nbytes - (idxval_byte + prev_bytes));
+ SAFE_FREE ();
+ clear_string_char_byte_cache ();
+ }
+ while (new_bytes--)
+ *p1++ = *p0++;
+ }
else
{
- CHECK_NUMBER (newelt, 2);
- XSTRING (array)->data[idxval] = XINT (newelt);
+ if (idxval < 0 || idxval >= SCHARS (array))
+ args_out_of_range (array, idx);
+ CHECK_NUMBER (newelt);
+
+ if (XINT (newelt) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt)))
+ SSET (array, idxval, XINT (newelt));
+ else
+ {
+ /* We must relocate the string data while converting it to
+ multibyte. */
+ int idxval_byte, prev_bytes, new_bytes;
+ unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
+ unsigned char *origstr = SDATA (array), *str;
+ int nchars, nbytes;
+ USE_SAFE_ALLOCA;
+
+ nchars = SCHARS (array);
+ nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval);
+ nbytes += count_size_as_multibyte (origstr + idxval,
+ nchars - idxval);
+ SAFE_ALLOCA (str, unsigned char *, nbytes);
+ copy_text (SDATA (array), str, nchars, 0, 1);
+ PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte,
+ prev_bytes);
+ new_bytes = CHAR_STRING (XINT (newelt), p0);
+ allocate_string_data (XSTRING (array), nchars,
+ nbytes + new_bytes - prev_bytes);
+ bcopy (str, SDATA (array), idxval_byte);
+ p1 = SDATA (array) + idxval_byte;
+ while (new_bytes--)
+ *p1++ = *p0++;
+ bcopy (str + idxval_byte + prev_bytes, p1,
+ nbytes - (idxval_byte + prev_bytes));
+ SAFE_FREE ();
+ clear_string_char_byte_cache ();
+ }
}
return newelt;
}
-
-Lisp_Object
-Farray_length (array)
- register Lisp_Object array;
-{
- register Lisp_Object size;
- if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String
- && XTYPE (array) != Lisp_Compiled)
- array = wrong_type_argument (Qarrayp, array);
- XFASTINT (size) = XVECTOR (array)->size;
- return size;
-}
\f
/* Arithmetic functions */
Lisp_Object num1, num2;
enum comparison comparison;
{
- double f1, f2;
+ double f1 = 0, f2 = 0;
int floatp = 0;
-#ifdef LISP_FLOAT_TYPE
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
- if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float)
+ if (FLOATP (num1) || FLOATP (num2))
{
floatp = 1;
- f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1);
- f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2);
+ f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
+ f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
}
-#else
- CHECK_NUMBER_COERCE_MARKER (num1, 0);
- CHECK_NUMBER_COERCE_MARKER (num2, 0);
-#endif /* LISP_FLOAT_TYPE */
switch (comparison)
{
}
DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
- "T if two args, both numbers or markers, are equal.")
- (num1, num2)
+ doc: /* Return t if two args, both numbers or markers, are equal. */)
+ (num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, equal);
}
DEFUN ("<", Flss, Slss, 2, 2, 0,
- "T if first arg is less than second arg. Both must be numbers or markers.")
- (num1, num2)
+ doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
+ (num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, less);
}
DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
- "T if first arg is greater than second arg. Both must be numbers or markers.")
- (num1, num2)
+ doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
+ (num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, grtr);
}
DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
- "T if first arg is less than or equal to second arg.\n\
-Both must be numbers or markers.")
- (num1, num2)
+ doc: /* Return t if first arg is less than or equal to second arg.
+Both must be numbers or markers. */)
+ (num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, less_or_equal);
}
DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
- "T if first arg is greater than or equal to second arg.\n\
-Both must be numbers or markers.")
- (num1, num2)
+ doc: /* Return t if first arg is greater than or equal to second arg.
+Both must be numbers or markers. */)
+ (num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, grtr_or_equal);
}
DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
- "T if first arg is not equal to second arg. Both must be numbers or markers.")
- (num1, num2)
+ doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
+ (num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, notequal);
}
-DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
- (num)
- register Lisp_Object num;
+DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
+ doc: /* Return t if NUMBER is zero. */)
+ (number)
+ register Lisp_Object number;
{
-#ifdef LISP_FLOAT_TYPE
- CHECK_NUMBER_OR_FLOAT (num, 0);
+ CHECK_NUMBER_OR_FLOAT (number);
- if (XTYPE(num) == Lisp_Float)
+ if (FLOATP (number))
{
- if (XFLOAT(num)->data == 0.0)
+ if (XFLOAT_DATA (number) == 0.0)
return Qt;
return Qnil;
}
-#else
- CHECK_NUMBER (num, 0);
-#endif /* LISP_FLOAT_TYPE */
- if (!XINT (num))
+ if (!XINT (number))
return Qt;
return Qnil;
}
\f
-/* Convert between 32-bit values and pairs of lispy 24-bit values. */
+/* Convert between long values and pairs of Lisp integers. */
Lisp_Object
long_to_cons (i)
unsigned long i;
{
- unsigned int top = i >> 16;
+ unsigned long top = i >> 16;
unsigned int bot = i & 0xFFFF;
if (top == 0)
return make_number (bot);
- if (top == 0xFFFF)
+ if (top == (unsigned long)-1 >> 16)
return Fcons (make_number (-1), make_number (bot));
return Fcons (make_number (top), make_number (bot));
}
Lisp_Object top, bot;
if (INTEGERP (c))
return XINT (c);
- top = XCONS (c)->car;
- bot = XCONS (c)->cdr;
+ top = XCAR (c);
+ bot = XCDR (c);
if (CONSP (bot))
- bot = XCONS (bot)->car;
+ bot = XCAR (bot);
return ((XINT (top) << 16) | XINT (bot));
}
\f
DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
- "Convert NUM to a string by printing it in decimal.\n\
-Uses a minus sign if negative.\n\
-NUM may be an integer or a floating point number.")
- (num)
- Lisp_Object num;
+ doc: /* Return the decimal representation of NUMBER as a string.
+Uses a minus sign if negative.
+NUMBER may be an integer or a floating point number. */)
+ (number)
+ Lisp_Object number;
{
- char buffer[20];
+ char buffer[VALBITS];
-#ifndef LISP_FLOAT_TYPE
- CHECK_NUMBER (num, 0);
-#else
- CHECK_NUMBER_OR_FLOAT (num, 0);
+ CHECK_NUMBER_OR_FLOAT (number);
- if (XTYPE(num) == Lisp_Float)
+ if (FLOATP (number))
{
char pigbuf[350]; /* see comments in float_to_string */
- float_to_string (pigbuf, XFLOAT(num)->data);
- return build_string (pigbuf);
+ float_to_string (pigbuf, XFLOAT_DATA (number));
+ return build_string (pigbuf);
}
-#endif /* LISP_FLOAT_TYPE */
- sprintf (buffer, "%d", XINT (num));
+ if (sizeof (int) == sizeof (EMACS_INT))
+ sprintf (buffer, "%d", XINT (number));
+ else if (sizeof (long) == sizeof (EMACS_INT))
+ sprintf (buffer, "%ld", (long) XINT (number));
+ else
+ abort ();
return build_string (buffer);
}
-DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
- "Convert STRING to a number by parsing it as a decimal number.\n\
-This parses both integers and floating point numbers.")
- (str)
- register Lisp_Object str;
+INLINE static int
+digit_to_number (character, base)
+ int character, base;
+{
+ int digit;
+
+ if (character >= '0' && character <= '9')
+ digit = character - '0';
+ else if (character >= 'a' && character <= 'z')
+ digit = character - 'a' + 10;
+ else if (character >= 'A' && character <= 'Z')
+ digit = character - 'A' + 10;
+ else
+ return -1;
+
+ if (digit >= base)
+ return -1;
+ else
+ return digit;
+}
+
+DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
+ doc: /* Parse STRING as a decimal number and return the number.
+This parses both integers and floating point numbers.
+It ignores leading spaces and tabs.
+
+If BASE, interpret STRING as a number in that base. If BASE isn't
+present, base 10 is used. BASE must be between 2 and 16 (inclusive).
+If the base used is not 10, floating point is not recognized. */)
+ (string, base)
+ register Lisp_Object string, base;
{
- unsigned char *p;
+ register unsigned char *p;
+ register int b;
+ int sign = 1;
+ Lisp_Object val;
- CHECK_STRING (str, 0);
+ CHECK_STRING (string);
- p = XSTRING (str)->data;
+ if (NILP (base))
+ b = 10;
+ else
+ {
+ CHECK_NUMBER (base);
+ b = XINT (base);
+ if (b < 2 || b > 16)
+ xsignal1 (Qargs_out_of_range, base);
+ }
/* Skip any whitespace at the front of the number. Some versions of
atoi do this anyway, so we might as well make Emacs lisp consistent. */
+ p = SDATA (string);
while (*p == ' ' || *p == '\t')
p++;
-#ifdef LISP_FLOAT_TYPE
- if (isfloat_string (p))
- return make_float (atof (p));
-#endif /* LISP_FLOAT_TYPE */
+ if (*p == '-')
+ {
+ sign = -1;
+ p++;
+ }
+ else if (*p == '+')
+ p++;
+
+ if (isfloat_string (p) && b == 10)
+ val = make_float (sign * atof (p));
+ else
+ {
+ double v = 0;
+
+ while (1)
+ {
+ int digit = digit_to_number (*p++, b);
+ if (digit < 0)
+ break;
+ v = v * b + digit;
+ }
+
+ val = make_fixnum_or_float (sign * v);
+ }
- return make_number (atoi (p));
+ return val;
}
-\f
-enum arithop
- { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
-extern Lisp_Object float_arith_driver ();
+\f
+enum arithop
+ {
+ Aadd,
+ Asub,
+ Amult,
+ Adiv,
+ Alogand,
+ Alogior,
+ Alogxor,
+ Amax,
+ Amin
+ };
+
+static Lisp_Object float_arith_driver P_ ((double, int, enum arithop,
+ int, Lisp_Object *));
+extern Lisp_Object fmod_float ();
Lisp_Object
arith_driver (code, nargs, args)
{
register Lisp_Object val;
register int argnum;
- register int accum;
- register int next;
+ register EMACS_INT accum = 0;
+ register EMACS_INT next;
-#ifdef SWITCH_ENUM_BUG
- switch ((int) code)
-#else
- switch (code)
-#endif
+ switch (SWITCH_ENUM_CAST (code))
{
case Alogior:
case Alogxor:
case Aadd:
case Asub:
- accum = 0; break;
+ accum = 0;
+ break;
case Amult:
- accum = 1; break;
+ accum = 1;
+ break;
case Alogand:
- accum = -1; break;
+ accum = -1;
+ break;
+ default:
+ break;
}
for (argnum = 0; argnum < nargs; argnum++)
{
- val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
-#ifdef LISP_FLOAT_TYPE
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
-
- if (XTYPE (val) == Lisp_Float) /* time to do serious math */
- return (float_arith_driver ((double) accum, argnum, code,
- nargs, args));
-#else
- CHECK_NUMBER_COERCE_MARKER (val, argnum);
-#endif /* LISP_FLOAT_TYPE */
- args[argnum] = val; /* runs into a compiler bug. */
+ /* Using args[argnum] as argument to CHECK_NUMBER_... */
+ val = args[argnum];
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
+
+ if (FLOATP (val))
+ return float_arith_driver ((double) accum, argnum, code,
+ nargs, args);
+ args[argnum] = val;
next = XINT (args[argnum]);
-#ifdef SWITCH_ENUM_BUG
- switch ((int) code)
-#else
- switch (code)
-#endif
+ switch (SWITCH_ENUM_CAST (code))
{
- case Aadd: accum += next; break;
+ case Aadd:
+ accum += next;
+ break;
case Asub:
- if (!argnum && nargs != 1)
- next = - next;
- accum -= next;
+ accum = argnum ? accum - next : nargs == 1 ? - next : next;
+ break;
+ case Amult:
+ accum *= next;
break;
- case Amult: accum *= next; break;
case Adiv:
- if (!argnum) accum = next;
+ if (!argnum)
+ accum = next;
else
{
if (next == 0)
- Fsignal (Qarith_error, Qnil);
+ xsignal0 (Qarith_error);
accum /= next;
}
break;
- case Alogand: accum &= next; break;
- case Alogior: accum |= next; break;
- case Alogxor: accum ^= next; break;
- case Amax: if (!argnum || next > accum) accum = next; break;
- case Amin: if (!argnum || next < accum) accum = next; break;
+ case Alogand:
+ accum &= next;
+ break;
+ case Alogior:
+ accum |= next;
+ break;
+ case Alogxor:
+ accum ^= next;
+ break;
+ case Amax:
+ if (!argnum || next > accum)
+ accum = next;
+ break;
+ case Amin:
+ if (!argnum || next < accum)
+ accum = next;
+ break;
}
}
- XSET (val, Lisp_Int, accum);
+ XSETINT (val, accum);
return val;
}
-#ifdef LISP_FLOAT_TYPE
-Lisp_Object
+#undef isnan
+#define isnan(x) ((x) != (x))
+
+static Lisp_Object
float_arith_driver (accum, argnum, code, nargs, args)
double accum;
register int argnum;
{
register Lisp_Object val;
double next;
-
+
for (; argnum < nargs; argnum++)
{
val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
- if (XTYPE (val) == Lisp_Float)
+ if (FLOATP (val))
{
- next = XFLOAT (val)->data;
+ next = XFLOAT_DATA (val);
}
else
{
args[argnum] = val; /* runs into a compiler bug. */
next = XINT (args[argnum]);
}
-#ifdef SWITCH_ENUM_BUG
- switch ((int) code)
-#else
- switch (code)
-#endif
+ switch (SWITCH_ENUM_CAST (code))
{
case Aadd:
accum += next;
break;
case Asub:
- if (!argnum && nargs != 1)
- next = - next;
- accum -= next;
+ accum = argnum ? accum - next : nargs == 1 ? - next : next;
break;
case Amult:
accum *= next;
accum = next;
else
{
- if (next == 0)
- Fsignal (Qarith_error, Qnil);
+ if (! IEEE_FLOATING_POINT && next == 0)
+ xsignal0 (Qarith_error);
accum /= next;
}
break;
case Alogxor:
return wrong_type_argument (Qinteger_or_marker_p, val);
case Amax:
- if (!argnum || next > accum)
+ if (!argnum || isnan (next) || next > accum)
accum = next;
break;
case Amin:
- if (!argnum || next < accum)
+ if (!argnum || isnan (next) || next < accum)
accum = next;
break;
}
return make_float (accum);
}
-#endif /* LISP_FLOAT_TYPE */
+
DEFUN ("+", Fplus, Splus, 0, MANY, 0,
- "Return sum of any number of arguments, which are numbers or markers.")
- (nargs, args)
+ doc: /* Return sum of any number of arguments, which are numbers or markers.
+usage: (+ &rest NUMBERS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
- "Negate number or subtract numbers or markers.\n\
-With one arg, negates it. With more than one arg,\n\
-subtracts all but the first from the first.")
- (nargs, args)
+ doc: /* Negate number or subtract numbers or markers and return the result.
+With one arg, negates it. With more than one arg,
+subtracts all but the first from the first.
+usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
- "Returns product of any number of arguments, which are numbers or markers.")
- (nargs, args)
+ doc: /* Return product of any number of arguments, which are numbers or markers.
+usage: (* &rest NUMBERS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("/", Fquo, Squo, 2, MANY, 0,
- "Returns first argument divided by all the remaining arguments.\n\
-The arguments must be numbers or markers.")
- (nargs, args)
+ doc: /* Return first argument divided by all the remaining arguments.
+The arguments must be numbers or markers.
+usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
+ int argnum;
+ for (argnum = 2; argnum < nargs; argnum++)
+ if (FLOATP (args[argnum]))
+ return float_arith_driver (0, 0, Adiv, nargs, args);
return arith_driver (Adiv, nargs, args);
}
DEFUN ("%", Frem, Srem, 2, 2, 0,
- "Returns remainder of first arg divided by second.\n\
-Both must be integers or markers.")
- (num1, num2)
- register Lisp_Object num1, num2;
+ doc: /* Return remainder of X divided by Y.
+Both must be integers or markers. */)
+ (x, y)
+ register Lisp_Object x, y;
{
Lisp_Object val;
- CHECK_NUMBER_COERCE_MARKER (num1, 0);
- CHECK_NUMBER_COERCE_MARKER (num2, 1);
+ CHECK_NUMBER_COERCE_MARKER (x);
+ CHECK_NUMBER_COERCE_MARKER (y);
- if (XFASTINT (num2) == 0)
- Fsignal (Qarith_error, Qnil);
+ if (XFASTINT (y) == 0)
+ xsignal0 (Qarith_error);
- XSET (val, Lisp_Int, XINT (num1) % XINT (num2));
+ XSETINT (val, XINT (x) % XINT (y));
return val;
}
-DEFUN ("mod", Fmod, Smod, 2, 2, 0,
- "Returns X modulo Y.\n\
-The result falls between zero (inclusive) and Y (exclusive).\n\
-Both X and Y must be numbers or markers.")
- (num1, num2)
- register Lisp_Object num1, num2;
+#ifndef HAVE_FMOD
+double
+fmod (f1, f2)
+ double f1, f2;
{
- Lisp_Object val;
- int i1, i2;
+ double r = f1;
-#ifdef LISP_FLOAT_TYPE
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 1);
+ if (f2 < 0.0)
+ f2 = -f2;
- if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float)
- {
- double f1, f2;
+ /* If the magnitude of the result exceeds that of the divisor, or
+ the sign of the result does not agree with that of the dividend,
+ iterate with the reduced value. This does not yield a
+ particularly accurate result, but at least it will be in the
+ range promised by fmod. */
+ do
+ r -= f2 * floor (r / f2);
+ while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
+
+ return r;
+}
+#endif /* ! HAVE_FMOD */
+
+DEFUN ("mod", Fmod, Smod, 2, 2, 0,
+ doc: /* Return X modulo Y.
+The result falls between zero (inclusive) and Y (exclusive).
+Both X and Y must be numbers or markers. */)
+ (x, y)
+ register Lisp_Object x, y;
+{
+ Lisp_Object val;
+ EMACS_INT i1, i2;
- f1 = XTYPE (num1) == Lisp_Float ? XFLOAT (num1)->data : XINT (num1);
- f2 = XTYPE (num2) == Lisp_Float ? XFLOAT (num2)->data : XINT (num2);
- if (f2 == 0)
- Fsignal (Qarith_error, Qnil);
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
-#if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux) || defined (MSDOS)
- f1 = fmod (f1, f2);
-#else
- f1 = drem (f1, f2);
-#endif
- /* If the "remainder" comes out with the wrong sign, fix it. */
- if ((f1 < 0) != (f2 < 0))
- f1 += f2;
- return (make_float (f1));
- }
-#else /* not LISP_FLOAT_TYPE */
- CHECK_NUMBER_COERCE_MARKER (num1, 0);
- CHECK_NUMBER_COERCE_MARKER (num2, 1);
-#endif /* not LISP_FLOAT_TYPE */
+ if (FLOATP (x) || FLOATP (y))
+ return fmod_float (x, y);
- i1 = XINT (num1);
- i2 = XINT (num2);
+ i1 = XINT (x);
+ i2 = XINT (y);
if (i2 == 0)
- Fsignal (Qarith_error, Qnil);
-
+ xsignal0 (Qarith_error);
+
i1 %= i2;
/* If the "remainder" comes out with the wrong sign, fix it. */
- if ((i1 < 0) != (i2 < 0))
+ if (i2 < 0 ? i1 > 0 : i1 < 0)
i1 += i2;
- XSET (val, Lisp_Int, i1);
+ XSETINT (val, i1);
return val;
}
DEFUN ("max", Fmax, Smax, 1, MANY, 0,
- "Return largest of all the arguments (which must be numbers or markers).\n\
-The value is always a number; markers are converted to numbers.")
- (nargs, args)
+ doc: /* Return largest of all the arguments (which must be numbers or markers).
+The value is always a number; markers are converted to numbers.
+usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("min", Fmin, Smin, 1, MANY, 0,
- "Return smallest of all the arguments (which must be numbers or markers).\n\
-The value is always a number; markers are converted to numbers.")
- (nargs, args)
+ doc: /* Return smallest of all the arguments (which must be numbers or markers).
+The value is always a number; markers are converted to numbers.
+usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
- "Return bitwise-and of all the arguments.\n\
-Arguments may be integers, or markers converted to integers.")
- (nargs, args)
+ doc: /* Return bitwise-and of all the arguments.
+Arguments may be integers, or markers converted to integers.
+usage: (logand &rest INTS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
- "Return bitwise-or of all the arguments.\n\
-Arguments may be integers, or markers converted to integers.")
- (nargs, args)
+ doc: /* Return bitwise-or of all the arguments.
+Arguments may be integers, or markers converted to integers.
+usage: (logior &rest INTS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
- "Return bitwise-exclusive-or of all the arguments.\n\
-Arguments may be integers, or markers converted to integers.")
- (nargs, args)
+ doc: /* Return bitwise-exclusive-or of all the arguments.
+Arguments may be integers, or markers converted to integers.
+usage: (logxor &rest INTS-OR-MARKERS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("ash", Fash, Sash, 2, 2, 0,
- "Return VALUE with its bits shifted left by COUNT.\n\
-If COUNT is negative, shifting is actually to the right.\n\
-In this case, the sign bit is duplicated.")
- (num1, num2)
- register Lisp_Object num1, num2;
+ doc: /* Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, the sign bit is duplicated. */)
+ (value, count)
+ register Lisp_Object value, count;
{
register Lisp_Object val;
- CHECK_NUMBER (num1, 0);
- CHECK_NUMBER (num2, 1);
+ CHECK_NUMBER (value);
+ CHECK_NUMBER (count);
- if (XINT (num2) > 0)
- XSET (val, Lisp_Int, XINT (num1) << XFASTINT (num2));
+ if (XINT (count) >= BITS_PER_EMACS_INT)
+ XSETINT (val, 0);
+ else if (XINT (count) > 0)
+ XSETINT (val, XINT (value) << XFASTINT (count));
+ else if (XINT (count) <= -BITS_PER_EMACS_INT)
+ XSETINT (val, XINT (value) < 0 ? -1 : 0);
else
- XSET (val, Lisp_Int, XINT (num1) >> -XINT (num2));
+ XSETINT (val, XINT (value) >> -XINT (count));
return val;
}
DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
- "Return VALUE with its bits shifted left by COUNT.\n\
-If COUNT is negative, shifting is actually to the right.\n\
-In this case, zeros are shifted in on the left.")
- (num1, num2)
- register Lisp_Object num1, num2;
+ doc: /* Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, zeros are shifted in on the left. */)
+ (value, count)
+ register Lisp_Object value, count;
{
register Lisp_Object val;
- CHECK_NUMBER (num1, 0);
- CHECK_NUMBER (num2, 1);
+ CHECK_NUMBER (value);
+ CHECK_NUMBER (count);
- if (XINT (num2) > 0)
- XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) << XFASTINT (num2));
+ if (XINT (count) >= BITS_PER_EMACS_INT)
+ XSETINT (val, 0);
+ else if (XINT (count) > 0)
+ XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
+ else if (XINT (count) <= -BITS_PER_EMACS_INT)
+ XSETINT (val, 0);
else
- XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) >> -XINT (num2));
+ XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
return val;
}
DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
- "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
-Markers are converted to integers.")
- (num)
- register Lisp_Object num;
+ doc: /* Return NUMBER plus one. NUMBER may be a number or a marker.
+Markers are converted to integers. */)
+ (number)
+ register Lisp_Object number;
{
-#ifdef LISP_FLOAT_TYPE
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0);
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
- if (XTYPE (num) == Lisp_Float)
- return (make_float (1.0 + XFLOAT (num)->data));
-#else
- CHECK_NUMBER_COERCE_MARKER (num, 0);
-#endif /* LISP_FLOAT_TYPE */
+ if (FLOATP (number))
+ return (make_float (1.0 + XFLOAT_DATA (number)));
- XSETINT (num, XFASTINT (num) + 1);
- return num;
+ XSETINT (number, XINT (number) + 1);
+ return number;
}
DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
- "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
-Markers are converted to integers.")
- (num)
- register Lisp_Object num;
+ doc: /* Return NUMBER minus one. NUMBER may be a number or a marker.
+Markers are converted to integers. */)
+ (number)
+ register Lisp_Object number;
{
-#ifdef LISP_FLOAT_TYPE
- CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0);
+ CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
- if (XTYPE (num) == Lisp_Float)
- return (make_float (-1.0 + XFLOAT (num)->data));
-#else
- CHECK_NUMBER_COERCE_MARKER (num, 0);
-#endif /* LISP_FLOAT_TYPE */
+ if (FLOATP (number))
+ return (make_float (-1.0 + XFLOAT_DATA (number)));
- XSETINT (num, XFASTINT (num) - 1);
- return num;
+ XSETINT (number, XINT (number) - 1);
+ return number;
}
DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
- "Return the bitwise complement of ARG. ARG must be an integer.")
- (num)
- register Lisp_Object num;
+ doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
+ (number)
+ register Lisp_Object number;
+{
+ CHECK_NUMBER (number);
+ XSETINT (number, ~XINT (number));
+ return number;
+}
+
+DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
+ doc: /* Return the byteorder for the machine.
+Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
+lowercase l) for small endian machines. */)
+ ()
{
- CHECK_NUMBER (num, 0);
- XSETINT (num, ~XFASTINT (num));
- return num;
+ unsigned i = 0x04030201;
+ int order = *(char *)&i == 1 ? 108 : 66;
+
+ return make_number (order);
}
+
+
\f
void
syms_of_data ()
Qargs_out_of_range = intern ("args-out-of-range");
Qvoid_function = intern ("void-function");
Qcyclic_function_indirection = intern ("cyclic-function-indirection");
+ Qcyclic_variable_indirection = intern ("cyclic-variable-indirection");
Qvoid_variable = intern ("void-variable");
Qsetting_constant = intern ("setting-constant");
Qinvalid_read_syntax = intern ("invalid-read-syntax");
Qbeginning_of_buffer = intern ("beginning-of-buffer");
Qend_of_buffer = intern ("end-of-buffer");
Qbuffer_read_only = intern ("buffer-read-only");
+ Qtext_read_only = intern ("text-read-only");
Qmark_inactive = intern ("mark-inactive");
Qlistp = intern ("listp");
Qconsp = intern ("consp");
Qsymbolp = intern ("symbolp");
+ Qkeywordp = intern ("keywordp");
Qintegerp = intern ("integerp");
Qnatnump = intern ("natnump");
+ Qwholenump = intern ("wholenump");
Qstringp = intern ("stringp");
Qarrayp = intern ("arrayp");
Qsequencep = intern ("sequencep");
Qboundp = intern ("boundp");
Qfboundp = intern ("fboundp");
-#ifdef LISP_FLOAT_TYPE
Qfloatp = intern ("floatp");
Qnumberp = intern ("numberp");
Qnumber_or_marker_p = intern ("number-or-marker-p");
-#endif /* LISP_FLOAT_TYPE */
+
+ Qchar_table_p = intern ("char-table-p");
+ Qvector_or_char_table_p = intern ("vector-or-char-table-p");
+
+ Qsubrp = intern ("subrp");
+ Qunevalled = intern ("unevalled");
+ Qmany = intern ("many");
Qcdr = intern ("cdr");
+ /* Handle automatic advice activation */
+ Qad_advice_info = intern ("ad-advice-info");
+ Qad_activate_internal = intern ("ad-activate-internal");
+
error_tail = Fcons (Qerror, Qnil);
/* ERROR is used as a signaler for random errors for which nothing else is right */
Fput (Qcyclic_function_indirection, Qerror_message,
build_string ("Symbol's chain of function indirections contains a loop"));
+ Fput (Qcyclic_variable_indirection, Qerror_conditions,
+ Fcons (Qcyclic_variable_indirection, error_tail));
+ Fput (Qcyclic_variable_indirection, Qerror_message,
+ build_string ("Symbol's chain of variable indirections contains a loop"));
+
+ Qcircular_list = intern ("circular-list");
+ staticpro (&Qcircular_list);
+ Fput (Qcircular_list, Qerror_conditions,
+ Fcons (Qcircular_list, error_tail));
+ Fput (Qcircular_list, Qerror_message,
+ build_string ("List contains a loop"));
+
Fput (Qvoid_variable, Qerror_conditions,
Fcons (Qvoid_variable, error_tail));
Fput (Qvoid_variable, Qerror_message,
Fput (Qbuffer_read_only, Qerror_message,
build_string ("Buffer is read-only"));
-#ifdef LISP_FLOAT_TYPE
+ Fput (Qtext_read_only, Qerror_conditions,
+ Fcons (Qtext_read_only, error_tail));
+ Fput (Qtext_read_only, Qerror_message,
+ build_string ("Text is read-only"));
+
Qrange_error = intern ("range-error");
Qdomain_error = intern ("domain-error");
Qsingularity_error = intern ("singularity-error");
staticpro (&Qsingularity_error);
staticpro (&Qoverflow_error);
staticpro (&Qunderflow_error);
-#endif /* LISP_FLOAT_TYPE */
staticpro (&Qnil);
staticpro (&Qt);
staticpro (&Qargs_out_of_range);
staticpro (&Qvoid_function);
staticpro (&Qcyclic_function_indirection);
+ staticpro (&Qcyclic_variable_indirection);
staticpro (&Qvoid_variable);
staticpro (&Qsetting_constant);
staticpro (&Qinvalid_read_syntax);
staticpro (&Qbeginning_of_buffer);
staticpro (&Qend_of_buffer);
staticpro (&Qbuffer_read_only);
+ staticpro (&Qtext_read_only);
staticpro (&Qmark_inactive);
staticpro (&Qlistp);
staticpro (&Qconsp);
staticpro (&Qsymbolp);
+ staticpro (&Qkeywordp);
staticpro (&Qintegerp);
staticpro (&Qnatnump);
+ staticpro (&Qwholenump);
staticpro (&Qstringp);
staticpro (&Qarrayp);
staticpro (&Qsequencep);
staticpro (&Qmarkerp);
staticpro (&Qbuffer_or_string_p);
staticpro (&Qinteger_or_marker_p);
-#ifdef LISP_FLOAT_TYPE
staticpro (&Qfloatp);
staticpro (&Qnumberp);
staticpro (&Qnumber_or_marker_p);
-#endif /* LISP_FLOAT_TYPE */
+ staticpro (&Qchar_table_p);
+ staticpro (&Qvector_or_char_table_p);
+ staticpro (&Qsubrp);
+ staticpro (&Qmany);
+ staticpro (&Qunevalled);
staticpro (&Qboundp);
staticpro (&Qfboundp);
staticpro (&Qcdr);
-
+ staticpro (&Qad_advice_info);
+ staticpro (&Qad_activate_internal);
+
+ /* Types that type-of returns. */
+ Qinteger = intern ("integer");
+ Qsymbol = intern ("symbol");
+ Qstring = intern ("string");
+ Qcons = intern ("cons");
+ Qmarker = intern ("marker");
+ Qoverlay = intern ("overlay");
+ Qfloat = intern ("float");
+ Qwindow_configuration = intern ("window-configuration");
+ Qprocess = intern ("process");
+ Qwindow = intern ("window");
+ /* Qsubr = intern ("subr"); */
+ Qcompiled_function = intern ("compiled-function");
+ Qbuffer = intern ("buffer");
+ Qframe = intern ("frame");
+ Qvector = intern ("vector");
+ Qchar_table = intern ("char-table");
+ Qbool_vector = intern ("bool-vector");
+ Qhash_table = intern ("hash-table");
+
+ staticpro (&Qinteger);
+ staticpro (&Qsymbol);
+ staticpro (&Qstring);
+ staticpro (&Qcons);
+ staticpro (&Qmarker);
+ staticpro (&Qoverlay);
+ staticpro (&Qfloat);
+ staticpro (&Qwindow_configuration);
+ staticpro (&Qprocess);
+ staticpro (&Qwindow);
+ /* staticpro (&Qsubr); */
+ staticpro (&Qcompiled_function);
+ staticpro (&Qbuffer);
+ staticpro (&Qframe);
+ staticpro (&Qvector);
+ staticpro (&Qchar_table);
+ staticpro (&Qbool_vector);
+ staticpro (&Qhash_table);
+
+ defsubr (&Sindirect_variable);
+ defsubr (&Sinteractive_form);
defsubr (&Seq);
defsubr (&Snull);
+ defsubr (&Stype_of);
defsubr (&Slistp);
defsubr (&Snlistp);
defsubr (&Sconsp);
defsubr (&Sinteger_or_marker_p);
defsubr (&Snumberp);
defsubr (&Snumber_or_marker_p);
-#ifdef LISP_FLOAT_TYPE
defsubr (&Sfloatp);
-#endif /* LISP_FLOAT_TYPE */
defsubr (&Snatnump);
defsubr (&Ssymbolp);
+ defsubr (&Skeywordp);
defsubr (&Sstringp);
+ defsubr (&Smultibyte_string_p);
defsubr (&Svectorp);
+ defsubr (&Schar_table_p);
+ defsubr (&Svector_or_char_table_p);
+ defsubr (&Sbool_vector_p);
defsubr (&Sarrayp);
defsubr (&Ssequencep);
defsubr (&Sbufferp);
defsubr (&Sfboundp);
defsubr (&Sfset);
defsubr (&Sdefalias);
- defsubr (&Sdefine_function);
defsubr (&Ssetplist);
defsubr (&Ssymbol_value);
defsubr (&Sset);
defsubr (&Smake_variable_buffer_local);
defsubr (&Smake_local_variable);
defsubr (&Skill_local_variable);
+ defsubr (&Smake_variable_frame_local);
+ defsubr (&Slocal_variable_p);
+ defsubr (&Slocal_variable_if_set_p);
+ defsubr (&Svariable_binding_locus);
defsubr (&Saref);
defsubr (&Saset);
defsubr (&Snumber_to_string);
defsubr (&Sadd1);
defsubr (&Ssub1);
defsubr (&Slognot);
+ defsubr (&Sbyteorder);
+ defsubr (&Ssubr_arity);
+ defsubr (&Ssubr_name);
+
+ XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
+
+ DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum,
+ doc: /* The largest value that is representable in a Lisp integer. */);
+ Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
+
+ DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum,
+ doc: /* The smallest value that is representable in a Lisp integer. */);
+ Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
}
SIGTYPE
arith_error (signo)
int signo;
{
-#ifdef USG
+#if defined(USG) && !defined(POSIX_SIGNALS)
/* USG systems forget handlers when they are used;
must reestablish each time */
signal (signo, arith_error);
sigsetmask (SIGEMPTYMASK);
#endif /* not BSD4_1 */
- Fsignal (Qarith_error, Qnil);
+ SIGNAL_THREAD_CHECK (signo);
+ xsignal0 (Qarith_error);
}
+void
init_data ()
{
/* Don't do this if just dumping out.
return;
#endif /* CANNOT_DUMP */
signal (SIGFPE, arith_error);
-
+
#ifdef uts
signal (SIGEMT, arith_error);
#endif /* uts */
}
+
+/* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
+ (do not change this comment) */