#include "keymap.h"
Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
+Lisp_Object Qnil_, Qt_;
static Lisp_Object Qsubr;
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
Lisp_Object Qerror, Quser_error, Qquit, Qargs_out_of_range;
Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
static Lisp_Object Qdefun;
+Lisp_Object Qspecial_operator;
Lisp_Object Qinteractive_form;
static Lisp_Object Qdefalias_fset_function;
-static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
+static void swap_in_symval_forwarding (sym_t, struct Lisp_Buffer_Local_Value *);
static bool
BOOLFWDP (union Lisp_Fwd *a)
static void
CHECK_SUBR (Lisp_Object x)
{
- CHECK_TYPE (SUBRP (x), Qsubrp, x);
+ CHECK_TYPE (! NILP (Fsubrp (x)), Qsubrp, x);
}
static void
return Qprocess;
if (WINDOWP (object))
return Qwindow;
- if (SUBRP (object))
- return Qsubr;
if (COMPILEDP (object))
return Qcompiled_function;
if (BUFFERP (object))
}
else if (FLOATP (object))
return Qfloat;
+ else if (! NILP (Fsubrp (object)))
+ return Qsubr;
else
return Qt;
}
doc: /* Return t if OBJECT is a built-in function. */)
(Lisp_Object object)
{
- if (SUBRP (object))
+ if (CONSP (object) && EQ (XCAR (object), Qspecial_operator))
+ object = XCDR (object);
+ if (SCM_PRIMITIVE_P (object))
return Qt;
return Qnil;
}
(register Lisp_Object symbol)
{
Lisp_Object valcontents;
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
return (EQ (valcontents, Qunbound) ? Qnil : Qt);
}
-/* FIXME: Make it an alias for function-symbol! */
-DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
- doc: /* Return t if SYMBOL's function definition is not void. */)
- (register Lisp_Object symbol)
-{
- CHECK_SYMBOL (symbol);
- return NILP (SYMBOL_FUNCTION (symbol)) ? Qnil : Qt;
-}
-
-DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
- doc: /* Make SYMBOL's value be void.
-Return 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: /* Make SYMBOL's function definition be nil.
-Return SYMBOL. */)
- (register Lisp_Object symbol)
-{
- CHECK_SYMBOL (symbol);
- if (NILP (symbol) || EQ (symbol, Qt))
- xsignal1 (Qsetting_constant, symbol);
- set_symbol_function (symbol, Qnil);
- return symbol;
-}
-
-DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
- doc: /* Return SYMBOL's function definition, or nil if that is void. */)
- (register Lisp_Object symbol)
-{
- CHECK_SYMBOL (symbol);
- return SYMBOL_FUNCTION (symbol);
-}
+WRAP1 (Ffboundp, "fboundp")
+WRAP1 (Fmakunbound, "makunbound")
+WRAP1 (Ffmakunbound, "fmakunbound")
+WRAP1 (Fsymbol_function, "symbol-function")
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
doc: /* Return SYMBOL's property list. */)
return name;
}
-DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
- doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
- (register Lisp_Object symbol, Lisp_Object definition)
-{
- register Lisp_Object function;
- CHECK_SYMBOL (symbol);
-
- function = SYMBOL_FUNCTION (symbol);
-
- if (!NILP (Vautoload_queue) && !NILP (function))
- Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
-
- if (AUTOLOADP (function))
- Fput (symbol, Qautoload, XCDR (function));
-
- /* Convert to eassert or remove after GC bug is found. In the
- meantime, check unconditionally, at a slight perf hit. */
- if (valid_lisp_object_p (definition) < 1)
- emacs_abort ();
-
- set_symbol_function (symbol, definition);
-
- return definition;
-}
+WRAP2 (Ffset, "fset")
DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
doc: /* Set SYMBOL's function definition to DEFINITION.
function with `&rest' args, or `unevalled' for a special form. */)
(Lisp_Object subr)
{
- short minargs, maxargs;
+ Lisp_Object min, max;
+ Lisp_Object arity;
+ bool special = false;
+
CHECK_SUBR (subr);
- minargs = XSUBR (subr)->min_args;
- maxargs = XSUBR (subr)->max_args;
- return Fcons (make_number (minargs),
- maxargs == MANY ? Qmany
- : maxargs == UNEVALLED ? Qunevalled
- : make_number (maxargs));
+ if (CONSP (subr) && EQ (XCAR (subr), Qspecial_operator))
+ {
+ subr = XCDR (subr);
+ special = true;
+ }
+ arity = scm_procedure_minimum_arity (subr);
+ if (scm_is_false (arity))
+ return Qnil;
+ min = XCAR (arity);
+ if (special)
+ max = Qunevalled;
+ else if (scm_is_true (XCAR (XCDR (XCDR (arity)))))
+ max = Qmany;
+ else
+ max = scm_sum (min, XCAR (XCDR (arity)));
+ return Fcons (min, max);
}
DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
SUBR must be a built-in function. */)
(Lisp_Object subr)
{
- const char *name;
CHECK_SUBR (subr);
- name = XSUBR (subr)->symbol_name;
- return build_string (name);
+ if (CONSP (subr) && EQ (XCAR (subr), Qspecial_operator))
+ subr = XCDR (subr);
+ return Fsymbol_name (SCM_SUBR_NAME (subr));
}
DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
fun = Fsymbol_function (fun);
}
- if (SUBRP (fun))
- {
- const char *spec = XSUBR (fun)->intspec;
- if (spec)
- return list2 (Qinteractive,
- (*spec != '(') ? build_string (spec) :
- Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
- }
- else if (COMPILEDP (fun))
+ if (COMPILEDP (fun))
{
if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
}
+ else if (scm_is_true (scm_procedure_p (fun)))
+ {
+ Lisp_Object tem = scm_assq (Qinteractive_form,
+ scm_procedure_properties (fun));
+ if (scm_is_pair (tem))
+ return list2 (Qinteractive, scm_cdr (tem));
+ }
else if (AUTOLOADP (fun))
return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil));
else if (CONSP (fun))
`cyclic-variable-indirection' if SYMBOL's chain of variable
indirections contains a loop. */
-struct Lisp_Symbol *
-indirect_variable (struct Lisp_Symbol *symbol)
+sym_t
+indirect_variable (sym_t symbol)
{
- struct Lisp_Symbol *tortoise, *hare;
+ sym_t tortoise, hare;
hare = tortoise = symbol;
- while (hare->redirect == SYMBOL_VARALIAS)
+ while (SYMBOL_REDIRECT (hare) == SYMBOL_VARALIAS)
{
hare = SYMBOL_ALIAS (hare);
- if (hare->redirect != SYMBOL_VARALIAS)
+ if (SYMBOL_REDIRECT (hare) != SYMBOL_VARALIAS)
break;
hare = SYMBOL_ALIAS (hare);
{
if (SYMBOLP (object))
{
- struct Lisp_Symbol *sym = indirect_variable (XSYMBOL (object));
+ sym_t sym = indirect_variable (XSYMBOL (object));
XSETSYMBOL (object, sym);
}
return object;
of BLV are marked after this function has changed them. */
void
-swap_in_global_binding (struct Lisp_Symbol *symbol)
+swap_in_global_binding (sym_t symbol)
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
This could be another forwarding pointer. */
static void
-swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_Value *blv)
+swap_in_symval_forwarding (sym_t symbol, struct Lisp_Buffer_Local_Value *blv)
{
register Lisp_Object tem1;
Lisp_Object
find_symbol_value (Lisp_Object symbol)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
bool bindflag)
{
bool voide = EQ (newval, Qunbound);
- struct Lisp_Symbol *sym;
+ sym_t sym;
Lisp_Object tem1;
/* If restoring in a dead buffer, do nothing. */
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
if (voide)
{ /* If storing void (making the symbol void), forward only through
buffer-local indicator, not through Lisp_Objfwd, etc. */
- sym->redirect = SYMBOL_PLAINVAL;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_PLAINVAL);
SET_SYMBOL_VAL (sym, newval);
}
else
static Lisp_Object
default_value (Lisp_Object symbol)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
for this variable. */)
(Lisp_Object symbol, Lisp_Object value)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
if (SYMBOL_CONSTANT_P (symbol))
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Fset (symbol, value);
default: emacs_abort ();
}
}
-
-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]...) */)
- (Lisp_Object args)
-{
- Lisp_Object args_left, symbol, val;
- struct gcpro gcpro1;
-
- args_left = val = args;
- GCPRO1 (args);
-
- while (CONSP (args_left))
- {
- val = eval_sub (Fcar (XCDR (args_left)));
- symbol = XCAR (args_left);
- Fset_default (symbol, val);
- args_left = Fcdr (XCDR (args_left));
- }
-
- UNGCPRO;
- return val;
-}
\f
/* Lisp functions for creating and removing buffer-local variables. */
};
static struct Lisp_Buffer_Local_Value *
-make_blv (struct Lisp_Symbol *sym, bool forwarded,
+make_blv (sym_t sym, bool forwarded,
union Lisp_Val_Fwd valcontents)
{
struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
The function `default-value' gets the default value and `set-default' sets it. */)
(register Lisp_Object variable)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
bool forwarded IF_LINT (= 0);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL:
default: emacs_abort ();
}
- if (sym->constant)
+ if (SYMBOL_CONSTANT (sym))
error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
if (!blv)
{
blv = make_blv (sym, forwarded, valcontents);
- sym->redirect = SYMBOL_LOCALIZED;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_LOCALIZED);
SET_SYMBOL_BLV (sym, blv);
{
Lisp_Object symbol;
Lisp_Object tem;
bool forwarded IF_LINT (= 0);
union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
- struct Lisp_Symbol *sym;
+ sym_t sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL:
default: emacs_abort ();
}
- if (sym->constant)
+ if (SYMBOL_CONSTANT (sym))
error ("Symbol %s may not be buffer-local",
SDATA (SYMBOL_NAME (variable)));
if (!blv)
{
blv = make_blv (sym, forwarded, valcontents);
- sym->redirect = SYMBOL_LOCALIZED;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_LOCALIZED);
SET_SYMBOL_BLV (sym, blv);
{
Lisp_Object symbol;
{
register Lisp_Object tem;
struct Lisp_Buffer_Local_Value *blv;
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return variable;
{
bool forwarded;
union Lisp_Val_Fwd valcontents;
- struct Lisp_Symbol *sym;
+ sym_t sym;
struct Lisp_Buffer_Local_Value *blv = NULL;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL:
default: emacs_abort ();
}
- if (sym->constant)
+ if (SYMBOL_CONSTANT (sym))
error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
blv = make_blv (sym, forwarded, valcontents);
blv->frame_local = 1;
- sym->redirect = SYMBOL_LOCALIZED;
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_LOCALIZED);
SET_SYMBOL_BLV (sym, blv);
{
Lisp_Object symbol;
(register Lisp_Object variable, Lisp_Object buffer)
{
register struct buffer *buf;
- struct Lisp_Symbol *sym;
+ sym_t sym;
if (NILP (buffer))
buf = current_buffer;
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
`make-variable-buffer-local'). */)
(register Lisp_Object variable, Lisp_Object buffer)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
If the current binding is global (the default), the value is nil. */)
(register Lisp_Object variable)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (variable);
sym = XSYMBOL (variable);
find_symbol_value (variable);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
buffer's or frame's value we are saving. */
if (!NILP (Flocal_variable_p (variable, Qnil)))
return Fcurrent_buffer ();
- else if (sym->redirect == SYMBOL_LOCALIZED
+ else if (SYMBOL_REDIRECT (sym) == SYMBOL_LOCALIZED
&& blv_found (SYMBOL_BLV (sym)))
return SYMBOL_BLV (sym)->where;
else
unsigned char *str = SAFE_ALLOCA (nbytes);
memcpy (str, SDATA (array), nbytes);
- allocate_string_data (XSTRING (array), nchars,
+ allocate_string_data (array, nchars,
nbytes + new_bytes - prev_bytes);
memcpy (SDATA (array), str, idxval_byte);
p1 = SDATA (array) + idxval_byte;
}
\f
+DEFUN ("bind-symbol", Fbind_symbol, Sbind_symbol, 3, 3, 0,
+ doc: /* Bind symbol. */)
+ (Lisp_Object symbol, Lisp_Object value, Lisp_Object thunk)
+{
+ Lisp_Object val;
+ dynwind_begin ();
+ specbind (symbol, value);
+ val = call0 (thunk);
+ dynwind_end ();
+ return val;
+}
+\f
void
syms_of_data (void)
{
Lisp_Object error_tail, arith_tail;
+ /* Used by defsubr. */
+ DEFSYM (Qspecial_operator, "special-operator");
+ DEFSYM (Qinteractive_form, "interactive-form");
+
#include "data.x"
DEFSYM (Qquote, "quote");
DEFSYM (Qfont_entity, "font-entity");
DEFSYM (Qfont_object, "font-object");
- DEFSYM (Qinteractive_form, "interactive-form");
DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
set_symbol_function (Qwholenump, SYMBOL_FUNCTION (Qnatnump));
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);
- XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1;
+ SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-positive-fixnum")), 1);
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);
- XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1;
+ SET_SYMBOL_CONSTANT (XSYMBOL (intern_c_string ("most-negative-fixnum")), 1);
}
HCoop / bpt / emacs.git / blobdiff