#include <config.h>
#include <signal.h>
#include <stdio.h>
#include "lisp.h"
#include "puresize.h"
#include "charset.h"
#include "buffer.h"
#include "keyboard.h"
#include "frame.h"
#include "syssignal.h"
#ifdef STDC_HEADERS
#include <float.h>
#endif
#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
#if defined (HPUX) && !defined (HPUX8)
#define _MAXLDBL data_c_maxldbl
#define _NMAXLDBL data_c_nmaxldbl
#endif
#include <math.h>
#if !defined (atof)
extern double atof ();
#endif
Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
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 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, 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;
Lisp_Object Qfloatp;
Lisp_Object Qnumberp, Qnumber_or_marker_p;
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;
{
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");
}
void
args_out_of_range (a1, a2)
Lisp_Object a1, a2;
{
xsignal2 (Qargs_out_of_range, a1, a2);
}
void
args_out_of_range_3 (a1, a2, a3)
Lisp_Object a1, a2, a3;
{
xsignal3 (Qargs_out_of_range, a1, a2, a3);
}
int sign_extend_temp;
int
sign_extend_lisp_int (num)
EMACS_INT num;
{
if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
return num | (((EMACS_INT) (-1)) << VALBITS);
else
return num & ((((EMACS_INT) 1) << VALBITS) - 1);
}
DEFUN ("eq", Feq, Seq, 2, 2, 0,
doc: )
(obj1, obj2)
Lisp_Object obj1, obj2;
{
if (EQ (obj1, obj2))
return Qt;
return Qnil;
}
DEFUN ("null", Fnull, Snull, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (NILP (object))
return Qt;
return Qnil;
}
DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
doc: )
(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: )
(object)
Lisp_Object object;
{
if (CONSP (object))
return Qt;
return Qnil;
}
DEFUN ("atom", Fatom, Satom, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (CONSP (object))
return Qnil;
return Qt;
}
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (CONSP (object) || NILP (object))
return Qt;
return Qnil;
}
DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (CONSP (object) || NILP (object))
return Qnil;
return Qt;
}
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (SYMBOLP (object))
return Qt;
return Qnil;
}
DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
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,
doc: )
(object)
Lisp_Object object;
{
if (VECTORP (object))
return Qt;
return Qnil;
}
DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (STRINGP (object))
return Qt;
return Qnil;
}
DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (STRINGP (object) && STRING_MULTIBYTE (object))
return Qt;
return Qnil;
}
DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
doc: )
(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: )
(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: )
(object)
Lisp_Object object;
{
if (BOOL_VECTOR_P (object))
return Qt;
return Qnil;
}
DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (ARRAYP (object))
return Qt;
return Qnil;
}
DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
doc: )
(object)
register Lisp_Object object;
{
if (CONSP (object) || NILP (object) || ARRAYP (object))
return Qt;
return Qnil;
}
DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (BUFFERP (object))
return Qt;
return Qnil;
}
DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (MARKERP (object))
return Qt;
return Qnil;
}
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (SUBRP (object))
return Qt;
return Qnil;
}
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (COMPILEDP (object))
return Qt;
return Qnil;
}
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
doc: )
(object)
register Lisp_Object object;
{
if (INTEGERP (object) || STRINGP (object))
return Qt;
return Qnil;
}
DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (INTEGERP (object))
return Qt;
return Qnil;
}
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
doc: )
(object)
register Lisp_Object object;
{
if (MARKERP (object) || INTEGERP (object))
return Qt;
return Qnil;
}
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (NATNUMP (object))
return Qt;
return Qnil;
}
DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (NUMBERP (object))
return Qt;
else
return Qnil;
}
DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
Snumber_or_marker_p, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (NUMBERP (object) || MARKERP (object))
return Qt;
return Qnil;
}
DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
if (FLOATP (object))
return Qt;
return Qnil;
}
DEFUN ("car", Fcar, Scar, 1, 1, 0,
doc: )
(list)
register Lisp_Object list;
{
return CAR (list);
}
DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
return CAR_SAFE (object);
}
DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
doc: )
(list)
register Lisp_Object list;
{
return CDR (list);
}
DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
doc: )
(object)
Lisp_Object object;
{
return CDR_SAFE (object);
}
DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
doc: )
(cell, newcar)
register Lisp_Object cell, newcar;
{
CHECK_CONS (cell);
CHECK_IMPURE (cell);
XSETCAR (cell, newcar);
return newcar;
}
DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
doc: )
(cell, newcdr)
register Lisp_Object cell, newcdr;
{
CHECK_CONS (cell);
CHECK_IMPURE (cell);
XSETCDR (cell, newcdr);
return newcdr;
}
DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
doc: )
(symbol)
register Lisp_Object symbol;
{
Lisp_Object valcontents;
CHECK_SYMBOL (symbol);
valcontents = SYMBOL_VALUE (symbol);
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
valcontents = swap_in_symval_forwarding (symbol, valcontents);
return (EQ (valcontents, Qunbound) ? Qnil : Qt);
}
DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
doc: )
(symbol)
register Lisp_Object symbol;
{
CHECK_SYMBOL (symbol);
return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
}
DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
doc: )
(symbol)
register Lisp_Object symbol;
{
CHECK_SYMBOL (symbol);
if (SYMBOL_CONSTANT_P (symbol))
xsignal1 (Qsetting_constant, symbol);
Fset (symbol, Qunbound);
return symbol;
}
DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
doc: )
(symbol)
register Lisp_Object symbol;
{
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,
doc: )
(symbol)
register Lisp_Object symbol;
{
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,
doc: )
(symbol)
register Lisp_Object symbol;
{
CHECK_SYMBOL (symbol);
return XSYMBOL (symbol)->plist;
}
DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
doc: )
(symbol)
register Lisp_Object symbol;
{
register Lisp_Object name;
CHECK_SYMBOL (symbol);
name = SYMBOL_NAME (symbol);
return name;
}
DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
doc: )
(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 (symbol)->function = definition;
if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
{
call2 (Qad_activate_internal, symbol, Qnil);
definition = XSYMBOL (symbol)->function;
}
return definition;
}
extern Lisp_Object Qfunction_documentation;
DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
doc: )
(symbol, definition, docstring)
register Lisp_Object symbol, definition, docstring;
{
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 ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
doc: )
(symbol, newplist)
register Lisp_Object symbol, newplist;
{
CHECK_SYMBOL (symbol);
XSYMBOL (symbol)->plist = newplist;
return newplist;
}
DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
doc: )
(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: )
(subr)
Lisp_Object subr;
{
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: )
(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;
}
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: )
(object)
Lisp_Object object;
{
if (SYMBOLP (object))
object = indirect_variable (object);
return object;
}
Lisp_Object
do_symval_forwarding (valcontents)
register Lisp_Object valcontents;
{
register Lisp_Object val;
int offset;
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_Misc_Objfwd:
return *XOBJFWD (valcontents)->objvar;
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;
}
void
store_symval_forwarding (symbol, valcontents, newval, buf)
Lisp_Object symbol;
register Lisp_Object valcontents, newval;
struct buffer *buf;
{
switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
{
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_Misc_Boolfwd:
*XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1;
break;
case Lisp_Misc_Objfwd:
*XOBJFWD (valcontents)->objvar = newval;
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:
def:
valcontents = SYMBOL_VALUE (symbol);
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval;
else
SET_SYMBOL_VALUE (symbol, newval);
}
}
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;
Fsetcdr (XCAR (cdr),
do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
XSETCAR (cdr, cdr);
store_symval_forwarding (symbol, valcontents, XCDR (cdr), NULL);
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;
}
static Lisp_Object
swap_in_symval_forwarding (symbol, valcontents)
Lisp_Object symbol, valcontents;
{
register Lisp_Object 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)))
{
if (XSYMBOL (symbol)->indirect_variable)
symbol = indirect_variable (symbol);
tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
Fsetcdr (tem1,
do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
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))
{
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;
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 XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
Lisp_Object
find_symbol_value (symbol)
Lisp_Object symbol;
{
register Lisp_Object valcontents;
register Lisp_Object val;
CHECK_SYMBOL (symbol);
valcontents = SYMBOL_VALUE (symbol);
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
valcontents = swap_in_symval_forwarding (symbol, valcontents);
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_Misc_Objfwd:
return *XOBJFWD (valcontents)->objvar;
case Lisp_Misc_Buffer_Objfwd:
return PER_BUFFER_VALUE (current_buffer,
XBUFFER_OBJFWD (valcontents)->offset);
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,
doc: )
(symbol)
Lisp_Object symbol;
{
Lisp_Object val;
val = find_symbol_value (symbol);
if (!EQ (val, Qunbound))
return val;
xsignal1 (Qvoid_variable, symbol);
}
DEFUN ("set", Fset, Sset, 2, 2, 0,
doc: )
(symbol, newval)
register Lisp_Object symbol, newval;
{
return set_internal (symbol, newval, current_buffer, 0);
}
static int
let_shadows_buffer_binding_p (symbol)
Lisp_Object symbol;
{
volatile struct specbinding *p;
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;
}
return p >= specpdl;
}
Lisp_Object
set_internal (symbol, newval, buf, bindflag)
register Lisp_Object symbol, newval;
struct buffer *buf;
int bindflag;
{
int voide = EQ (newval, Qunbound);
register Lisp_Object valcontents, innercontents, tem1, current_alist_element;
if (buf == 0)
buf = current_buffer;
if (NILP (buf->name))
return newval;
CHECK_SYMBOL (symbol);
if (SYMBOL_CONSTANT_P (symbol)
&& (NILP (Fkeywordp (symbol))
|| !EQ (newval, SYMBOL_VALUE (symbol))))
xsignal1 (Qsetting_constant, symbol);
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))
{
if (XSYMBOL (symbol)->indirect_variable)
symbol = indirect_variable (symbol);
current_alist_element
= XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
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)))
{
Fsetcdr (current_alist_element,
do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
tem1 = Fassq (symbol, buf->local_var_alist);
XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
if (NILP (tem1))
{
if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents)
|| let_shadows_buffer_binding_p (symbol))
{
XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
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;
}
else
{
tem1 = Fcons (symbol, XCDR (current_alist_element));
buf->local_var_alist
= Fcons (tem1, buf->local_var_alist);
}
}
XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr,
tem1);
XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf);
XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
}
innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
}
if (voide)
store_symval_forwarding (symbol, Qnil, newval, buf);
else
store_symval_forwarding (symbol, innercontents, newval, buf);
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
current_alist_element
= XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame)
XSETCDR (current_alist_element, newval);
}
return newval;
}
Lisp_Object
default_value (symbol)
Lisp_Object symbol;
{
register Lisp_Object valcontents;
CHECK_SYMBOL (symbol);
valcontents = SYMBOL_VALUE (symbol);
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
if (PER_BUFFER_IDX (offset) != 0)
return PER_BUFFER_DEFAULT (offset);
}
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
Lisp_Object current_alist_element, alist_element_car;
current_alist_element
= 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 (XBUFFER_LOCAL_VALUE (valcontents)->realvalue);
else
return XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
}
return do_symval_forwarding (valcontents);
}
DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
doc: )
(symbol)
Lisp_Object symbol;
{
register Lisp_Object value;
value = default_value (symbol);
return (EQ (value, Qunbound) ? Qnil : Qt);
}
DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
doc: )
(symbol)
Lisp_Object symbol;
{
register Lisp_Object 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,
doc: )
(symbol, value)
Lisp_Object symbol, value;
{
register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
CHECK_SYMBOL (symbol);
valcontents = SYMBOL_VALUE (symbol);
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
int idx = PER_BUFFER_IDX (offset);
PER_BUFFER_DEFAULT (offset) = value;
if (idx > 0)
{
struct buffer *b;
for (b = all_buffers; b; b = b->next)
if (!PER_BUFFER_VALUE_P (b, idx))
PER_BUFFER_VALUE (b, offset) = value;
}
return value;
}
if (!BUFFER_LOCAL_VALUEP (valcontents)
&& !SOME_BUFFER_LOCAL_VALUEP (valcontents))
return Fset (symbol, value);
XSETCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, value);
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 (symbol,
XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
value, NULL);
return value;
}
DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
doc: )
(args)
Lisp_Object args;
{
register Lisp_Object args_left;
register Lisp_Object val, symbol;
struct gcpro gcpro1;
if (NILP (args))
return Qnil;
args_left = args;
GCPRO1 (args);
do
{
val = Feval (Fcar (Fcdr (args_left)));
symbol = XCAR (args_left);
Fset_default (symbol, val);
args_left = Fcdr (XCDR (args_left));
}
while (!NILP (args_left));
UNGCPRO;
return val;
}
DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1, 1, "vMake Variable Buffer Local: ",
doc: )
(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))
{
XMISCTYPE (SYMBOL_VALUE (variable)) = Lisp_Misc_Buffer_Local_Value;
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_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: ",
doc: )
(variable)
register Lisp_Object variable;
{
register Lisp_Object tem, valcontents;
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))
{
tem = Fboundp (variable);
Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
return variable;
}
if (!SOME_BUFFER_LOCAL_VALUEP (valcontents))
{
Lisp_Object newval;
tem = Fcons (Qnil, do_symval_forwarding (valcontents));
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);;
}
tem = Fassq (variable, current_buffer->local_var_alist);
if (NILP (tem))
{
find_symbol_value (variable);
current_buffer->local_var_alist
= Fcons (Fcons (variable, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->cdr)),
current_buffer->local_var_alist);
{
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;
}
}
valcontents = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->realvalue;
if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
swap_in_symval_forwarding (variable, SYMBOL_VALUE (variable));
return variable;
}
DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1, 1, "vKill Local Variable: ",
doc: )
(variable)
register Lisp_Object variable;
{
register Lisp_Object tem, valcontents;
CHECK_SYMBOL (variable);
variable = indirect_variable (variable);
valcontents = SYMBOL_VALUE (variable);
if (BUFFER_OBJFWDP (valcontents))
{
int offset = XBUFFER_OBJFWD (valcontents)->offset;
int idx = PER_BUFFER_IDX (offset);
if (idx > 0)
{
SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
PER_BUFFER_VALUE (current_buffer, offset)
= PER_BUFFER_DEFAULT (offset);
}
return variable;
}
if (!BUFFER_LOCAL_VALUEP (valcontents)
&& !SOME_BUFFER_LOCAL_VALUEP (valcontents))
return variable;
tem = Fassq (variable, current_buffer->local_var_alist);
if (!NILP (tem))
current_buffer->local_var_alist
= Fdelq (tem, current_buffer->local_var_alist);
{
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 variable;
}
DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1, 1, "vMake Variable Frame Local: ",
doc: )
(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: )
(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: )
(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))
return Qt;
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: )
(variable)
register Lisp_Object variable;
{
Lisp_Object valcontents;
CHECK_SYMBOL (variable);
variable = indirect_variable (variable);
find_symbol_value (variable);
valcontents = XSYMBOL (variable)->value;
if (BUFFER_LOCAL_VALUEP (valcontents)
|| SOME_BUFFER_LOCAL_VALUEP (valcontents)
|| BUFFER_OBJFWDP (valcontents))
{
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;
}
Lisp_Object
indirect_function (object)
register Lisp_Object object;
{
Lisp_Object tortoise, hare;
hare = tortoise = object;
for (;;)
{
if (!SYMBOLP (hare) || EQ (hare, Qunbound))
break;
hare = XSYMBOL (hare)->function;
if (!SYMBOLP (hare) || EQ (hare, Qunbound))
break;
hare = XSYMBOL (hare)->function;
tortoise = XSYMBOL (tortoise)->function;
if (EQ (hare, tortoise))
xsignal1 (Qcyclic_function_indirection, object);
}
return hare;
}
DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
doc: )
(object, noerror)
register Lisp_Object object;
Lisp_Object noerror;
{
Lisp_Object result;
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);
return Qnil;
}
DEFUN ("aref", Faref, Saref, 2, 2, 0,
doc: )
(array, idx)
register Lisp_Object array;
Lisp_Object idx;
{
register int idxval;
CHECK_NUMBER (idx);
idxval = XINT (idx);
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;
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);
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))
{
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;
code[0] += 128;
code[3] = -1;
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;
}
}
val = current_default;
if (NILP (val))
{
array = XCHAR_TABLE (array)->parent;
if (!NILP (array))
goto try_parent_char_table;
}
return val;
}
}
else
{
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,
doc: )
(array, idx, newelt)
register Lisp_Object array;
Lisp_Object idx, newelt;
{
register int idxval;
CHECK_NUMBER (idx);
idxval = XINT (idx);
CHECK_ARRAY (array, Qarrayp);
CHECK_IMPURE (array);
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;
code[0] += 128;
code[3] = -1;
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;
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)
{
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
{
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
{
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;
}
enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
Lisp_Object
arithcompare (num1, num2, comparison)
Lisp_Object num1, num2;
enum comparison comparison;
{
double f1 = 0, f2 = 0;
int floatp = 0;
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
if (FLOATP (num1) || FLOATP (num2))
{
floatp = 1;
f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
}
switch (comparison)
{
case equal:
if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
return Qt;
return Qnil;
case notequal:
if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
return Qt;
return Qnil;
case less:
if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
return Qt;
return Qnil;
case less_or_equal:
if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
return Qt;
return Qnil;
case grtr:
if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
return Qt;
return Qnil;
case grtr_or_equal:
if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
return Qt;
return Qnil;
default:
abort ();
}
}
DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
doc: )
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, equal);
}
DEFUN ("<", Flss, Slss, 2, 2, 0,
doc: )
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, less);
}
DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
doc: )
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, grtr);
}
DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
doc: )
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, less_or_equal);
}
DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
doc: )
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, grtr_or_equal);
}
DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
doc: )
(num1, num2)
register Lisp_Object num1, num2;
{
return arithcompare (num1, num2, notequal);
}
DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
doc: )
(number)
register Lisp_Object number;
{
CHECK_NUMBER_OR_FLOAT (number);
if (FLOATP (number))
{
if (XFLOAT_DATA (number) == 0.0)
return Qt;
return Qnil;
}
if (!XINT (number))
return Qt;
return Qnil;
}
Lisp_Object
long_to_cons (i)
unsigned long i;
{
unsigned long top = i >> 16;
unsigned int bot = i & 0xFFFF;
if (top == 0)
return make_number (bot);
if (top == (unsigned long)-1 >> 16)
return Fcons (make_number (-1), make_number (bot));
return Fcons (make_number (top), make_number (bot));
}
unsigned long
cons_to_long (c)
Lisp_Object c;
{
Lisp_Object top, bot;
if (INTEGERP (c))
return XINT (c);
top = XCAR (c);
bot = XCDR (c);
if (CONSP (bot))
bot = XCAR (bot);
return ((XINT (top) << 16) | XINT (bot));
}
DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
doc: )
(number)
Lisp_Object number;
{
char buffer[VALBITS];
CHECK_NUMBER_OR_FLOAT (number);
if (FLOATP (number))
{
char pigbuf[350];
float_to_string (pigbuf, XFLOAT_DATA (number));
return build_string (pigbuf);
}
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);
}
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: )
(string, base)
register Lisp_Object string, base;
{
register unsigned char *p;
register int b;
int sign = 1;
Lisp_Object val;
CHECK_STRING (string);
if (NILP (base))
b = 10;
else
{
CHECK_NUMBER (base);
b = XINT (base);
if (b < 2 || b > 16)
xsignal1 (Qargs_out_of_range, base);
}
p = SDATA (string);
while (*p == ' ' || *p == '\t')
p++;
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 val;
}
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)
enum arithop code;
int nargs;
register Lisp_Object *args;
{
register Lisp_Object val;
register int argnum;
register EMACS_INT accum = 0;
register EMACS_INT next;
switch (SWITCH_ENUM_CAST (code))
{
case Alogior:
case Alogxor:
case Aadd:
case Asub:
accum = 0;
break;
case Amult:
accum = 1;
break;
case Alogand:
accum = -1;
break;
default:
break;
}
for (argnum = 0; argnum < nargs; argnum++)
{
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]);
switch (SWITCH_ENUM_CAST (code))
{
case Aadd:
accum += next;
break;
case Asub:
accum = argnum ? accum - next : nargs == 1 ? - next : next;
break;
case Amult:
accum *= next;
break;
case Adiv:
if (!argnum)
accum = next;
else
{
if (next == 0)
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;
}
}
XSETINT (val, accum);
return val;
}
#undef isnan
#define isnan(x) ((x) != (x))
static Lisp_Object
float_arith_driver (accum, argnum, code, nargs, args)
double accum;
register int argnum;
enum arithop code;
int nargs;
register Lisp_Object *args;
{
register Lisp_Object val;
double next;
for (; argnum < nargs; argnum++)
{
val = args[argnum];
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
if (FLOATP (val))
{
next = XFLOAT_DATA (val);
}
else
{
args[argnum] = val;
next = XINT (args[argnum]);
}
switch (SWITCH_ENUM_CAST (code))
{
case Aadd:
accum += next;
break;
case Asub:
accum = argnum ? accum - next : nargs == 1 ? - next : next;
break;
case Amult:
accum *= next;
break;
case Adiv:
if (!argnum)
accum = next;
else
{
if (! IEEE_FLOATING_POINT && next == 0)
xsignal0 (Qarith_error);
accum /= next;
}
break;
case Alogand:
case Alogior:
case Alogxor:
return wrong_type_argument (Qinteger_or_marker_p, val);
case Amax:
if (!argnum || isnan (next) || next > accum)
accum = next;
break;
case Amin:
if (!argnum || isnan (next) || next < accum)
accum = next;
break;
}
}
return make_float (accum);
}
DEFUN ("+", Fplus, Splus, 0, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Aadd, nargs, args);
}
DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Asub, nargs, args);
}
DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Amult, nargs, args);
}
DEFUN ("/", Fquo, Squo, 2, MANY, 0,
doc: )
(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,
doc: )
(x, y)
register Lisp_Object x, y;
{
Lisp_Object val;
CHECK_NUMBER_COERCE_MARKER (x);
CHECK_NUMBER_COERCE_MARKER (y);
if (XFASTINT (y) == 0)
xsignal0 (Qarith_error);
XSETINT (val, XINT (x) % XINT (y));
return val;
}
#ifndef HAVE_FMOD
double
fmod (f1, f2)
double f1, f2;
{
double r = f1;
if (f2 < 0.0)
f2 = -f2;
do
r -= f2 * floor (r / f2);
while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
return r;
}
#endif
DEFUN ("mod", Fmod, Smod, 2, 2, 0,
doc: )
(x, y)
register Lisp_Object x, y;
{
Lisp_Object val;
EMACS_INT i1, i2;
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
if (FLOATP (x) || FLOATP (y))
return fmod_float (x, y);
i1 = XINT (x);
i2 = XINT (y);
if (i2 == 0)
xsignal0 (Qarith_error);
i1 %= i2;
if (i2 < 0 ? i1 > 0 : i1 < 0)
i1 += i2;
XSETINT (val, i1);
return val;
}
DEFUN ("max", Fmax, Smax, 1, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Amax, nargs, args);
}
DEFUN ("min", Fmin, Smin, 1, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Amin, nargs, args);
}
DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Alogand, nargs, args);
}
DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Alogior, nargs, args);
}
DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
doc: )
(nargs, args)
int nargs;
Lisp_Object *args;
{
return arith_driver (Alogxor, nargs, args);
}
DEFUN ("ash", Fash, Sash, 2, 2, 0,
doc: )
(value, count)
register Lisp_Object value, count;
{
register Lisp_Object val;
CHECK_NUMBER (value);
CHECK_NUMBER (count);
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
XSETINT (val, XINT (value) >> -XINT (count));
return val;
}
DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
doc: )
(value, count)
register Lisp_Object value, count;
{
register Lisp_Object val;
CHECK_NUMBER (value);
CHECK_NUMBER (count);
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
XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
return val;
}
DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
doc: )
(number)
register Lisp_Object number;
{
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
if (FLOATP (number))
return (make_float (1.0 + XFLOAT_DATA (number)));
XSETINT (number, XINT (number) + 1);
return number;
}
DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
doc: )
(number)
register Lisp_Object number;
{
CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
if (FLOATP (number))
return (make_float (-1.0 + XFLOAT_DATA (number)));
XSETINT (number, XINT (number) - 1);
return number;
}
DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
doc: )
(number)
register Lisp_Object number;
{
CHECK_NUMBER (number);
XSETINT (number, ~XINT (number));
return number;
}
DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
doc: )
()
{
unsigned i = 0x04030201;
int order = *(char *)&i == 1 ? 108 : 66;
return make_number (order);
}
void
syms_of_data ()
{
Lisp_Object error_tail, arith_tail;
Qquote = intern ("quote");
Qlambda = intern ("lambda");
Qsubr = intern ("subr");
Qerror_conditions = intern ("error-conditions");
Qerror_message = intern ("error-message");
Qtop_level = intern ("top-level");
Qerror = intern ("error");
Qquit = intern ("quit");
Qwrong_type_argument = intern ("wrong-type-argument");
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");
Qinvalid_function = intern ("invalid-function");
Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
Qno_catch = intern ("no-catch");
Qend_of_file = intern ("end-of-file");
Qarith_error = intern ("arith-error");
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");
Qbufferp = intern ("bufferp");
Qvectorp = intern ("vectorp");
Qchar_or_string_p = intern ("char-or-string-p");
Qmarkerp = intern ("markerp");
Qbuffer_or_string_p = intern ("buffer-or-string-p");
Qinteger_or_marker_p = intern ("integer-or-marker-p");
Qboundp = intern ("boundp");
Qfboundp = intern ("fboundp");
Qfloatp = intern ("floatp");
Qnumberp = intern ("numberp");
Qnumber_or_marker_p = intern ("number-or-marker-p");
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");
Qad_advice_info = intern ("ad-advice-info");
Qad_activate_internal = intern ("ad-activate-internal");
error_tail = Fcons (Qerror, Qnil);
Fput (Qerror, Qerror_conditions,
error_tail);
Fput (Qerror, Qerror_message,
build_string ("error"));
Fput (Qquit, Qerror_conditions,
Fcons (Qquit, Qnil));
Fput (Qquit, Qerror_message,
build_string ("Quit"));
Fput (Qwrong_type_argument, Qerror_conditions,
Fcons (Qwrong_type_argument, error_tail));
Fput (Qwrong_type_argument, Qerror_message,
build_string ("Wrong type argument"));
Fput (Qargs_out_of_range, Qerror_conditions,
Fcons (Qargs_out_of_range, error_tail));
Fput (Qargs_out_of_range, Qerror_message,
build_string ("Args out of range"));
Fput (Qvoid_function, Qerror_conditions,
Fcons (Qvoid_function, error_tail));
Fput (Qvoid_function, Qerror_message,
build_string ("Symbol's function definition is void"));
Fput (Qcyclic_function_indirection, Qerror_conditions,
Fcons (Qcyclic_function_indirection, error_tail));
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,
build_string ("Symbol's value as variable is void"));
Fput (Qsetting_constant, Qerror_conditions,
Fcons (Qsetting_constant, error_tail));
Fput (Qsetting_constant, Qerror_message,
build_string ("Attempt to set a constant symbol"));
Fput (Qinvalid_read_syntax, Qerror_conditions,
Fcons (Qinvalid_read_syntax, error_tail));
Fput (Qinvalid_read_syntax, Qerror_message,
build_string ("Invalid read syntax"));
Fput (Qinvalid_function, Qerror_conditions,
Fcons (Qinvalid_function, error_tail));
Fput (Qinvalid_function, Qerror_message,
build_string ("Invalid function"));
Fput (Qwrong_number_of_arguments, Qerror_conditions,
Fcons (Qwrong_number_of_arguments, error_tail));
Fput (Qwrong_number_of_arguments, Qerror_message,
build_string ("Wrong number of arguments"));
Fput (Qno_catch, Qerror_conditions,
Fcons (Qno_catch, error_tail));
Fput (Qno_catch, Qerror_message,
build_string ("No catch for tag"));
Fput (Qend_of_file, Qerror_conditions,
Fcons (Qend_of_file, error_tail));
Fput (Qend_of_file, Qerror_message,
build_string ("End of file during parsing"));
arith_tail = Fcons (Qarith_error, error_tail);
Fput (Qarith_error, Qerror_conditions,
arith_tail);
Fput (Qarith_error, Qerror_message,
build_string ("Arithmetic error"));
Fput (Qbeginning_of_buffer, Qerror_conditions,
Fcons (Qbeginning_of_buffer, error_tail));
Fput (Qbeginning_of_buffer, Qerror_message,
build_string ("Beginning of buffer"));
Fput (Qend_of_buffer, Qerror_conditions,
Fcons (Qend_of_buffer, error_tail));
Fput (Qend_of_buffer, Qerror_message,
build_string ("End of buffer"));
Fput (Qbuffer_read_only, Qerror_conditions,
Fcons (Qbuffer_read_only, error_tail));
Fput (Qbuffer_read_only, Qerror_message,
build_string ("Buffer is read-only"));
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");
Qoverflow_error = intern ("overflow-error");
Qunderflow_error = intern ("underflow-error");
Fput (Qdomain_error, Qerror_conditions,
Fcons (Qdomain_error, arith_tail));
Fput (Qdomain_error, Qerror_message,
build_string ("Arithmetic domain error"));
Fput (Qrange_error, Qerror_conditions,
Fcons (Qrange_error, arith_tail));
Fput (Qrange_error, Qerror_message,
build_string ("Arithmetic range error"));
Fput (Qsingularity_error, Qerror_conditions,
Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
Fput (Qsingularity_error, Qerror_message,
build_string ("Arithmetic singularity error"));
Fput (Qoverflow_error, Qerror_conditions,
Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
Fput (Qoverflow_error, Qerror_message,
build_string ("Arithmetic overflow error"));
Fput (Qunderflow_error, Qerror_conditions,
Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
Fput (Qunderflow_error, Qerror_message,
build_string ("Arithmetic underflow error"));
staticpro (&Qrange_error);
staticpro (&Qdomain_error);
staticpro (&Qsingularity_error);
staticpro (&Qoverflow_error);
staticpro (&Qunderflow_error);
staticpro (&Qnil);
staticpro (&Qt);
staticpro (&Qquote);
staticpro (&Qlambda);
staticpro (&Qsubr);
staticpro (&Qunbound);
staticpro (&Qerror_conditions);
staticpro (&Qerror_message);
staticpro (&Qtop_level);
staticpro (&Qerror);
staticpro (&Qquit);
staticpro (&Qwrong_type_argument);
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 (&Qwrong_number_of_arguments);
staticpro (&Qinvalid_function);
staticpro (&Qno_catch);
staticpro (&Qend_of_file);
staticpro (&Qarith_error);
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 (&Qbufferp);
staticpro (&Qvectorp);
staticpro (&Qchar_or_string_p);
staticpro (&Qmarkerp);
staticpro (&Qbuffer_or_string_p);
staticpro (&Qinteger_or_marker_p);
staticpro (&Qfloatp);
staticpro (&Qnumberp);
staticpro (&Qnumber_or_marker_p);
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);
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");
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 (&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 (&Satom);
defsubr (&Sintegerp);
defsubr (&Sinteger_or_marker_p);
defsubr (&Snumberp);
defsubr (&Snumber_or_marker_p);
defsubr (&Sfloatp);
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 (&Smarkerp);
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
defsubr (&Schar_or_string_p);
defsubr (&Scar);
defsubr (&Scdr);
defsubr (&Scar_safe);
defsubr (&Scdr_safe);
defsubr (&Ssetcar);
defsubr (&Ssetcdr);
defsubr (&Ssymbol_function);
defsubr (&Sindirect_function);
defsubr (&Ssymbol_plist);
defsubr (&Ssymbol_name);
defsubr (&Smakunbound);
defsubr (&Sfmakunbound);
defsubr (&Sboundp);
defsubr (&Sfboundp);
defsubr (&Sfset);
defsubr (&Sdefalias);
defsubr (&Ssetplist);
defsubr (&Ssymbol_value);
defsubr (&Sset);
defsubr (&Sdefault_boundp);
defsubr (&Sdefault_value);
defsubr (&Sset_default);
defsubr (&Ssetq_default);
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 (&Sstring_to_number);
defsubr (&Seqlsign);
defsubr (&Slss);
defsubr (&Sgtr);
defsubr (&Sleq);
defsubr (&Sgeq);
defsubr (&Sneq);
defsubr (&Szerop);
defsubr (&Splus);
defsubr (&Sminus);
defsubr (&Stimes);
defsubr (&Squo);
defsubr (&Srem);
defsubr (&Smod);
defsubr (&Smax);
defsubr (&Smin);
defsubr (&Slogand);
defsubr (&Slogior);
defsubr (&Slogxor);
defsubr (&Slsh);
defsubr (&Sash);
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: );
Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum,
doc: );
Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
}
SIGTYPE
arith_error (signo)
int signo;
{
#if defined(USG) && !defined(POSIX_SIGNALS)
signal (signo, arith_error);
#endif
#ifdef VMS
signal (signo, arith_error);
#endif
#ifdef BSD4_1
sigrelse (SIGFPE);
#else
sigsetmask (SIGEMPTYMASK);
#endif
SIGNAL_THREAD_CHECK (signo);
xsignal0 (Qarith_error);
}
void
init_data ()
{
#ifndef CANNOT_DUMP
if (!initialized)
return;
#endif
signal (SIGFPE, arith_error);
#ifdef uts
signal (SIGEMT, arith_error);
#endif
}