/* eval1.c Copyright (C) 1989-2002 Codemist Ltd */
/*
* Interpreter (part 1).
*/
/*
* This code may be used and modified, and redistributed in binary
* or source form, subject to the "CCL Public License", which should
* accompany it. This license is a variant on the BSD license, and thus
* permits use of code derived from this in either open and commercial
* projects: but it does require that updates to this code be made
* available back to the originators of the package.
* Before merging other code in with this or linking this code
* with other packages or libraries please check that the license terms
* of the other material are compatible with those of this.
*/
/* Signature: 7b09cda9 10-Oct-2002 */
#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#include "machine.h"
#include "tags.h"
#include "cslerror.h"
#include "externs.h"
#include "entries.h"
#ifdef TIMEOUT
#include "timeout.h"
#endif
Lisp_Object nreverse(Lisp_Object a)
{
Lisp_Object nil = C_nil;
Lisp_Object b = nil;
while (consp(a))
{ Lisp_Object c = a;
a = qcdr(a);
qcdr(c) = b;
b = c;
}
return b;
}
/*
* Environments are represented as association lists, and have to cope
* with several sorts of things. The items in an environment can be
* in one of the following forms:
*
* (a) (symbol . value) normal lexical variable binding
* (b) (symbol . ~magic~) given symbol is (locally) special
* (c) (0 . tag) (block tag ...) marker
* (d) (1 . (tag ...)) (tagbody ... tag ...) marker
* (e) (2 . <anything>) case (c) or (d) but now invalidated
* (f) (def . symbol) (flet ...) or (macrolet ...) binding,
* where the def is non-atomic.
*
* Format for def in case (f)
*
* (1) (funarg env bvl ...) flet and labels
* (2) (bvl ...) macrolet
* Note that 'funarg is not valid as a bvl
* and indeed in this case bvl is a list
*/
/*
* In CSL mode flet, macrolet and local declarations are not supported.
*/
Lisp_Object Ceval(Lisp_Object u, Lisp_Object env)
{
Lisp_Object nil = C_nil;
#ifdef COMMON
int t;
#ifdef CHECK_STACK
if (check_stack(__FILE__,__LINE__)) return aerror("deep stack in eval");
#endif
restart:
t = (int)u & TAG_BITS;
/*
* The first case considered is of symbols - lexical and special bindings
* have to be sorted out.
*/
if (t == TAG_SYMBOL)
{
Header h = qheader(u);
if (h & SYM_SPECIAL_VAR)
{ Lisp_Object v = qvalue(u);
if (v == unset_var) return error(1, err_unset_var, u);
else return onevalue(v);
}
else
{
while (env != nil)
{ Lisp_Object p = qcar(env);
if (qcar(p) == u)
{ Lisp_Object v =qcdr(p);
/*
* If a variable is lexically bound to the value work_symbol that means
* that the symbol has been (lexically) declared to be special, so its
* value cell should be inspected.
*/
if (v == work_symbol)
{ v = qvalue(u);
if (v == unset_var) return error(1, err_unset_var, u);
}
return onevalue(v);
}
env = qcdr(env);
}
#ifdef ARTHURS_ORIGINAL_INTERPRETATION
return error(1, err_unbound_lexical, u);
#else
{ Lisp_Object v = qvalue(u);
if (v == unset_var) return error(1, err_unset_var, u);
else return onevalue(v);
}
#endif
}
}
/*
* Things that are neither symbols nor lists evaluate to themselves,
* e.g. numbers and vectors.
*/
else if (t != TAG_CONS) return onevalue(u);
else
#endif /* COMMON */
{
/*
* The final case is that of a list (fn ...), and one case that has to
* be checked is if fn is lexically bound.
*/
Lisp_Object fn, args;
#ifdef COMMON
/*
* The test for nil here is because although nil is a symbol the tagging
* structure tested here marks it as a list.
*/
if (u == nil) return onevalue(nil);
#endif
stackcheck2(0, u, env);
fn = qcar(u);
args = qcdr(u);
#ifdef COMMON
/*
* Local function bindings must be looked for first.
*/
{ Lisp_Object p;
for (p=env; p!=nil; p=qcdr(p))
{ Lisp_Object w = qcar(p);
/*
* The form (<list> . sym) is used in an environment to indicate a local
* binding of a function, either as a regular function or as a macro
* (i.e. flet or macrolet). The structure of the list distinguishes
* between these two cases.
*/
if (qcdr(w) == fn && is_cons(w = qcar(w)) && w!=nil)
{
p = qcar(w);
if (p == funarg) /* ordinary function */
{ fn = w; /* (funarg ...) is OK to apply */
goto ordinary_function;
}
/*
* Here it is a local macro. Observe that the macroexpansion is done
* with respect to an empty environment. Macros that are defined at the same
* time may seem to be mutually recursive but there is a sense in which they
* are not (as well as a sense in which they are) - self and cross references
* only happen AFTER an expansion and can not happen during one.
*/
push2(u, env);
w = cons(lambda, w);
nil = C_nil;
if (!exception_pending())
p = Lfuncalln(nil, 4, qvalue(macroexpand_hook),
w, u, nil);
pop2(env, u);
nil = C_nil;
if (exception_pending())
{ flip_exception();
if ((exit_reason & UNWIND_ERROR) != 0)
{ err_printf("\nMacroexpanding: ");
loop_print_error(u);
nil = C_nil;
if (exception_pending()) flip_exception();
}
flip_exception();
return nil;
}
u = p;
goto restart;
}
}
}
#endif
if (is_symbol(fn))
{
/*
* Special forms and macros are checked for next. Special forms
* take precedence over macros.
*/
Header h = qheader(fn);
if (h & SYM_SPECIAL_FORM)
{ Lisp_Object v;
#ifdef DEBUG
if (qfn1(fn) == NULL)
{ term_printf("Illegal special form\n");
my_exit(EXIT_FAILURE);
}
#endif
v = ((Special_Form *)qfn1(fn))(args, env);
return v;
}
else if (h & SYM_MACRO)
{
push2(u, env);
/*
* the environment passed to macroexpand should only be needed to cope
* with macrolet, I think. Since I use just one datastructure for the
* whole environment I also pass along lexical bindings etc, but I hope that
* they will never be accessed. I do not think that macrolet is important
* enough to call for complication and slow-down in the interpreter this
* way - but then I am not exactly what you would call a Common Lisp Fan!
*/
fn = macroexpand(u, env);
pop2(env, u);
nil = C_nil;
if (exception_pending())
{ flip_exception();
if ((exit_reason & UNWIND_ERROR) != 0)
{ err_printf("\nMacroexpanding: ");
loop_print_error(u);
nil = C_nil;
if (exception_pending()) flip_exception();
}
flip_exception();
return nil;
}
return eval(fn, env);
}
}
/*
* Otherwise we have a regular function call. I prepare the args and
* call APPLY.
*/
#ifdef COMMON
ordinary_function:
#endif
{ int nargs = 0;
Lisp_Object *save_stack = stack;
/*
* Args are built up on the stack here...
*/
while (consp(args))
{ Lisp_Object w;
push3(fn, args, env);
w = qcar(args);
w = eval(w, env);
pop3(env, args, fn);
/*
* nil having its mark bit set indicates that a special sort of exit
* is in progress. Multiple values can be ignored in this case.
*/
nil = C_nil;
if (exception_pending())
{ flip_exception();
stack = save_stack;
if ((exit_reason & UNWIND_ERROR) != 0)
{ err_printf("\nEvaluating: ");
loop_print_error(qcar(args));
nil = C_nil;
if (exception_pending()) flip_exception();
}
flip_exception();
return nil;
}
push(w); /* args build up on the Lisp stack */
nargs++;
args = qcdr(args);
}
/*
* I pass the environment down to apply() because it will be used if the
* function was a simple lambda expression. If the function is a symbol
* or a closure, env will be irrelevant. The arguments are on the Lisp
* stack, and it is the responsibility of apply() to pop them.
*/
return apply(fn, nargs, env, fn);
}
}
}
#ifdef COMMON
/*
* Keyword arguments are not supported in CSL mode - but &optional
* and &rest and &aux will be (at least for now). Removal of
* support for keywords will save a little space and an even smaller
* amount of time.
*/
static CSLbool check_no_unwanted_keys(Lisp_Object restarg, Lisp_Object ok_keys)
/*
* verify that there were no unwanted keys in the actual arg list
*/
{
Lisp_Object nil = C_nil;
CSLbool odd_key_found = NO;
while (restarg!=nil)
{ Lisp_Object k = qcar(restarg);
Lisp_Object w;
for (w=ok_keys; w!=nil; w=qcdr(w))
if (k == qcar(w)) goto is_ok;
odd_key_found = YES;
is_ok:
restarg = qcdr(restarg);
if (restarg==nil) return YES; /* odd length list */
if (k == allow_key_key && qcar(restarg) != nil) return NO; /* OK */
restarg = qcdr(restarg);
}
return odd_key_found;
}
static CSLbool check_keyargs_even(Lisp_Object restarg)
/*
* check that list is even length with alternate items symbols in
* the keyword package.
*/
{
Lisp_Object nil = C_nil;
while (restarg!=nil)
{ Lisp_Object q = qcar(restarg);
if (!is_symbol(q) || qpackage(q) != qvalue(keyword_package)) return YES;
restarg = qcdr(restarg);
if (restarg==nil) return YES; /* Odd length is wrong */
restarg = qcdr(restarg);
}
return NO; /* OK */
}
static Lisp_Object keywordify(Lisp_Object v)
{
/*
* arg is a non-nil symbol. Should nil be permitted - I think not
* since there seems too much chance of confusion.
*/
Lisp_Object nil, name = get_pname(v);
errexit();
return Lintern_2(nil, name, qvalue(keyword_package));
}
static Lisp_Object key_lookup(Lisp_Object keyname, Lisp_Object args)
{
Lisp_Object nil = C_nil;
while (args!=nil)
{ Lisp_Object next = qcdr(args);
if (next==nil) return nil;
if (qcar(args) == keyname) return next;
else args = qcdr(next);
}
return nil;
}
#endif
Lisp_Object apply_lambda(Lisp_Object def, int nargs,
Lisp_Object env, Lisp_Object name)
/*
* Here def is a lambda expression (sans the initial lambda) that is to
* be applied. Much horrible messing about is needed so that I can cope
* with &optional and &rest args (including initialisers and supplied-p
* variables, also &key, &allow-other-keys and &aux). Note the need to find
* any special declarations at the head of the body of the lambda-form.
* Must pop (nargs) items from the stack at exit.
*/
{
/*
* lambda-lists are parsed using a finite state engine with the
* following states, plus an exit state.
*/
#define STATE_NULL 0 /* at start and during regular args */
#define STATE_OPT 1 /* after &optional */
#define STATE_OPT1 2 /* after &optional + at least one var */
#define STATE_REST 3 /* immediately after &rest */
#define STATE_REST1 4 /* after &rest vv */
#ifdef COMMON
#define STATE_KEY 5 /* &key with no &rest */
#define STATE_ALLOW 6 /* &allow-other-keys */
#endif
#define STATE_AUX 7 /* &aux */
Lisp_Object nil = C_nil;
int opt_rest_state = STATE_NULL;
Lisp_Object *next_arg;
int args_left = nargs;
Lisp_Object w;
if (!consp(def))
{ popv(nargs);
return onevalue(nil); /* Should never happen */
}
stackcheck3(0, def, env, name);
w = qcar(def);
next_arg = &stack[1-nargs]; /* Points to arg1 */
push4(w, /* bvl */
qcdr(def), /* body */
env, name);
/*
* Here I need to macroexpand the first few items in body and
* look for declare/special items. I will only bother with SPECIAL decls.
* Note that args have been pushed onto the stack first to avoid corruption
* while the interpreter performs macroexpansion. This is the sort of place
* where I feel that Common Lisp has built in causes of inefficiency.
* Well oh well!!! The Common Lisp standardisation group thought so too,
* and have now indicated that DECLARE forms can not be hidden away as
* the result of macros, so some of this is unnecessary.
*/
push5(nil, nil, /* local_decs, ok_keys */
nil, nil, nil); /* restarg, specenv, val1 */
push5(nil, nil, /* arg, v1 */
nil, nil, nil); /* v, p, w */
/*
* On computers which have unsigned offsets in indexed memory reference
* instructions the negative indexes off the stack suggested here might
* be more expensive than I would like - maybe on such machines the stack
* pointer should be kept offset by 64 bytes (say). Doing so in general
* would be to the disadvantage of machines with auto-index address modes
* that might be used when pushing/popping single items on the stack.
*/
#define w stack[0]
#define p stack[-1]
#define v stack[-2]
#define v1 stack[-3]
#define arg stack[-4]
#define val1 stack[-5]
#define specenv stack[-6]
#define restarg stack[-7]
#ifdef COMMON
#define ok_keys stack[-8]
#define local_decs stack[-9]
#endif
#define name stack[-10]
#define env stack[-11]
#define body stack[-12]
#define bvl stack[-13]
#define arg1 stack[-14]
#define stack_used ((int)(nargs + 14))
#ifdef COMMON
for (;;)
{ if (!consp(body)) break;
p = macroexpand(qcar(body), env);
nil = C_nil;
if (exception_pending())
{ Lisp_Object qname = name;
popv(stack_used);
return qname;
}
body = qcdr(body);
if (!consp(p))
{ if (stringp(p) && consp(body)) continue;
body = cons(p, body);
break;
}
if (qcar(p) != declare_symbol)
{ body = cons(p, body);
break;
}
for (v = qcdr(v); consp(v); v = qcdr(v))
{ v1 = qcar(v);
if (!consp(v1) || qcar(v1) != special_symbol) continue;
/* here v1 says (special ...) */
for (v1=qcdr(v1); consp(v1); v1 = qcdr(v1))
{ local_decs = cons(qcar(v1), local_decs);
if (exception_pending()) break;
}
}
}
nil = C_nil;
if (exception_pending())
{ Lisp_Object qname = name;
popv(stack_used);
return qname;
}
#endif
/*
* Parse the BVL
*/
for (p = bvl; consp(p); p=qcdr(p))
{ v = qcar(p);
v1 = nil;
arg = nil;
val1 = nil;
/*
* I can break from this switch statement with v a variable to bind
* and arg the value to bind to it, also v1 (if not nil) is a second
* variable to be bound (a supplied-p value) and val1 the value to bind it to.
* If I see &rest or &key the remaining actual args get collected into
* restarg, which takes the place of arg in some respects.
*/
switch (opt_rest_state)
{
case STATE_NULL:
if (v == opt_key)
{ opt_rest_state = STATE_OPT;
continue;
}
#define BAD1(msg) { error(0, msg); goto unwind_special_bindings; }
#define BAD2(msg, a) { error(1, msg, a); goto unwind_special_bindings; }
#define collect_rest_arg() \
while (args_left-- != 0) \
{ if (!exception_pending()) \
restarg = cons(next_arg[args_left], restarg); \
nil = C_nil; \
}
if (v == rest_key)
{ collect_rest_arg();
if (exception_pending()) goto unwind_special_bindings;
opt_rest_state = STATE_REST;
continue;
}
#ifdef COMMON
if (v == key_key)
{ collect_rest_arg();
if (exception_pending()) goto unwind_special_bindings;
if (check_keyargs_even(restarg)) BAD2(err_bad_keyargs, restarg);
opt_rest_state = STATE_KEY;
continue;
}
if (v == aux_key)
{ if (args_left != 0) BAD1(err_excess_args);
opt_rest_state = STATE_AUX;
continue;
}
if (v == allow_other_keys) BAD2(err_bad_bvl, v);
#endif
if (args_left == 0) BAD1(err_insufficient_args);
arg = *next_arg++;
args_left--;
v1 = nil; /* no suppliedp mess here, I'm glad to say */
break;
case STATE_OPT:
if (v == opt_key
|| v == rest_key
#ifdef COMMON
|| v == key_key
|| v == allow_other_keys
|| v == aux_key
#endif
) BAD2(err_bad_bvl, v);
/*
* Here v may be a simple variable, or a list (var init suppliedp)
*/
opt_rest_state = STATE_OPT1;
process_optional_parameter:
if (args_left != 0)
{ arg = *next_arg++;
args_left--;
val1 = lisp_true;
}
else
{ arg = nil;
val1 = nil;
}
v1 = nil;
if (!consp(v)) break; /* Simple case */
{ w = qcdr(v);
v = qcar(v);
if (!consp(w)) break; /* (var) */
if (val1 == nil) /* use the init form */
{ arg = qcar(w);
arg = eval(arg, env);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
}
w = qcdr(w);
if (consp(w)) v1 = qcar(w); /* suppliedp name */
break;
}
case STATE_OPT1:
if (v == rest_key)
{ collect_rest_arg();
if (exception_pending()) goto unwind_special_bindings;
opt_rest_state = STATE_REST;
continue;
}
#ifdef COMMON
if (v == key_key)
{ collect_rest_arg();
if (exception_pending()) goto unwind_special_bindings;
if (check_keyargs_even(restarg)) BAD2(err_bad_keyargs, restarg);
opt_rest_state = STATE_KEY;
continue;
}
if (v == aux_key)
{ if (args_left != 0) BAD1(err_excess_args);
opt_rest_state = STATE_AUX;
continue;
}
#endif
if (v == opt_key
#ifdef COMMON
|| v == allow_other_keys
#endif
) BAD2(err_bad_bvl, v);
goto process_optional_parameter;
case STATE_REST:
if (v == opt_key
|| v == rest_key
#ifdef COMMON
|| v == key_key
|| v == allow_other_keys
|| v == aux_key
#endif
) BAD2(err_bad_bvl, v);
opt_rest_state = STATE_REST1;
arg = restarg;
break;
case STATE_REST1:
#ifdef COMMON
if (v == key_key)
{ if (check_keyargs_even(restarg)) BAD2(err_bad_keyargs, restarg);
opt_rest_state = STATE_KEY;
continue;
}
if (v == aux_key)
{
opt_rest_state = STATE_AUX;
continue;
}
#endif
BAD2(err_bad_bvl, rest_key);
#ifdef COMMON
case STATE_KEY:
if (v == allow_other_keys)
{ opt_rest_state = STATE_ALLOW;
continue;
}
if (v == aux_key)
{ if (check_no_unwanted_keys(restarg, ok_keys))
BAD2(err_bad_keyargs, restarg);
opt_rest_state = STATE_AUX;
continue;
}
if (v == opt_key || v == rest_key || v == key_key)
BAD2(err_bad_bvl, v);
process_keyword_parameter:
/*
* v needs to expand to ((:kv v) init svar) in effect here.
*/
{ Lisp_Object keyname = nil;
w = nil;
if (!consp(v))
{ if (!is_symbol(v)) BAD2(err_bad_bvl, v);
keyname = keywordify(v);
}
else
{ w = qcdr(v);
v = qcar(v);
if (!consp(v))
{ if (!is_symbol(v)) BAD2(err_bad_bvl, v);
keyname = keywordify(v);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
}
else
{ keyname = qcar(v);
if (!is_symbol(keyname)) BAD2(err_bad_bvl, v);
keyname = keywordify(keyname);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
v = qcdr(v);
if (consp(v)) v = qcar(v);
else BAD2(err_bad_bvl, v);
}
}
ok_keys = cons(keyname, ok_keys);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
arg = key_lookup(qcar(ok_keys), restarg);
if (arg == nil) val1 = nil;
else
{ arg = qcar(arg);
val1 = lisp_true;
}
v1 = nil;
if (!consp(w)) break; /* (var) */
if (val1 == nil) /* use the init form */
{ arg = qcar(w);
arg = eval(arg, env);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
}
w = qcdr(w);
if (consp(w)) v1 = qcar(w); /* suppliedp name */
break;
}
case STATE_ALLOW:
if (v == aux_key)
{ opt_rest_state = STATE_AUX;
continue;
}
if (v == opt_key || v == rest_key || v == key_key ||
v == allow_other_keys) BAD2(err_bad_bvl, v);
goto process_keyword_parameter;
case STATE_AUX:
if (v == opt_key || v == rest_key ||
v == key_key || v == allow_other_keys ||
v == aux_key) BAD2(err_bad_bvl, v);
if (consp(v))
{ w = qcdr(v);
v = qcar(v);
if (consp(w))
{ arg = qcar(w);
arg = eval(arg, env);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
}
}
else arg = nil;
v1 = nil;
break;
#endif
}
/*
* This is where I get when I have one or two vars to bind.
*/
#ifndef COMMON
/*
* CSL mode does not have to mess about looking for local special bindings
* and so is MUCH shorter and neater. I always shallow bind
*/
#define instate_binding(var, val, local_decs1, lab) \
{ if (!is_symbol(var)) BAD2(err_bad_bvl, var); \
w = acons(var, qvalue(var), specenv); \
nil = C_nil; \
if (exception_pending()) goto unwind_special_bindings; \
specenv = w; \
qvalue(var) = val; \
}
#else
#define instate_binding(var, val, local_decs1, lab) \
{ Header h; \
if (!is_symbol(var)) BAD2(err_bad_bvl, var); \
h = qheader(var); \
if ((h & SYM_SPECIAL_VAR) != 0) \
{ w = acons(var, qvalue(var), specenv); \
nil = C_nil; \
if (exception_pending()) goto unwind_special_bindings; \
specenv = w; \
qvalue(var) = val; \
} \
else \
{ for (w = local_decs1; w!=nil; w = qcdr(w)) \
{ if (qcar(w) == var) \
{ qcar(w) = fixnum_of_int(0);/* decl is used up */\
w = acons(var, work_symbol, env); \
nil = C_nil; \
if (exception_pending()) \
goto unwind_special_bindings; \
env = w; \
w = acons(var, qvalue(var), specenv); \
nil = C_nil; \
if (exception_pending()) \
goto unwind_special_bindings; \
specenv = w; \
qvalue(var) = val; \
goto lab; \
} \
} \
w = acons(var, val, env); \
nil = C_nil; \
if (exception_pending()) goto unwind_special_bindings; \
env = w; \
lab: ; \
} \
}
#endif
#ifdef COMMON
/*
* Must check about local special declarations here...
*/
#endif
instate_binding(v, arg, local_decs, label1);
if (v1 != nil) instate_binding(v1, val1, local_decs, label2);
} /* End of for loop that scans BVL */
#ifdef COMMON
/*
* As well as local special declarations that have applied to bindings here
* there can be some that apply just to variable references within the body.
*/
while (local_decs!=nil)
{ Lisp_Object q = qcar(local_decs);
local_decs=qcdr(local_decs);
if (!is_symbol(q)) continue;
w = acons(q, work_symbol, env);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
env = w;
}
#endif
switch (opt_rest_state)
{
case STATE_NULL:
case STATE_OPT1: /* Ensure there had not been too many args */
if (args_left != 0) BAD1(err_excess_args);
break;
case STATE_OPT: /* error if bvl finishes here */
case STATE_REST:
BAD2(err_bad_bvl, opt_rest_state == STATE_OPT ? opt_key : rest_key);
#ifdef COMMON
case STATE_KEY: /* ensure only valid keys were given */
if (check_no_unwanted_keys(restarg, ok_keys))
BAD2(err_bad_keyargs, restarg);
break;
#endif
default:
/* in the following cases all is known to be well
case STATE_REST1:
case STATE_ALLOW:
case STATE_AUX:
*/
break;
}
/*
* Now all the argument bindings have been performed - it remains to
* process the body of the lambda-expression.
*/
if (specenv == nil)
{ Lisp_Object bodyx = body, envx = env;
Lisp_Object qname = name;
popv(stack_used);
push(qname);
bodyx = progn_fn(bodyx, envx);
pop(qname);
nil = C_nil;
if (exception_pending()) return qname;
return bodyx;
}
{ body = progn_fn(body, env);
nil = C_nil;
if (exception_pending()) goto unwind_special_bindings;
while (specenv != nil)
{
Lisp_Object bv = qcar(specenv);
qvalue(qcar(bv)) = qcdr(bv);
specenv = qcdr(specenv);
}
{ Lisp_Object bodyx = body;
popv(stack_used);
/*
* note that exit_count has not been disturbed since I called progn_fn,
* so the numbert of values that will be returned remains correctly
* established (in Common Lisp mode where it is needed.
*/
return bodyx;
}
}
unwind_special_bindings:
/*
* I gete here ONLY if nil has its mark bit set, which means that (for
* one reason or another) I am having to unwind the stack, restoring
* special bindings as I go.
*/
nil = C_nil;
flip_exception();
while (specenv != nil)
{ Lisp_Object bv = qcar(specenv);
qvalue(qcar(bv)) = qcdr(bv);
specenv = qcdr(specenv);
}
flip_exception();
{ Lisp_Object qname = name;
popv(stack_used);
return qname;
}
#undef w
#undef p
#undef v
#undef v1
#undef arg
#undef val1
#undef specenv
#undef restarg
#undef ok_keys
#undef local_decs
#undef name
#undef env
#undef body
#undef bvl
#undef stack_used
}
Lisp_Object Leval(Lisp_Object nil, Lisp_Object a)
{
return eval(a, nil); /* Multiple values may be returned */
}
Lisp_Object Levlis(Lisp_Object nil, Lisp_Object a)
{
Lisp_Object r;
stackcheck1(0, a);
r = nil;
while (consp(a))
{ push2(qcdr(a), r);
a = qcar(a);
a = eval(a, nil);
errexitn(2);
pop(r);
r = cons(a, r);
pop(a);
errexit();
}
return onevalue(nreverse(r));
}
Lisp_Object MS_CDECL Lapply_n(Lisp_Object nil, int nargs, ...)
{
va_list a;
int i;
Lisp_Object *stack_save = stack, last, fn = nil;
if (nargs == 0) return aerror("apply");
else if (nargs > 1)
{ va_start(a, nargs);
fn = va_arg(a, Lisp_Object);
push_args_1(a, nargs);
pop(last);
i = nargs-2;
while (consp(last))
{ push(qcar(last));
last = qcdr(last);
i++;
}
}
else i = 0;
stackcheck1(stack-stack_save, fn);
return apply(fn, i, nil, fn);
}
Lisp_Object Lapply_1(Lisp_Object nil, Lisp_Object fn)
{
return Lapply_n(nil, 1, fn);
}
Lisp_Object Lapply_2(Lisp_Object nil, Lisp_Object fn, Lisp_Object a1)
{
return Lapply_n(nil, 2, fn, a1);
}
Lisp_Object Lapply0(Lisp_Object nil, Lisp_Object fn)
{
if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 0);
stackcheck1(0, fn);
return apply(fn, 0, C_nil, fn);
}
Lisp_Object Lapply1(Lisp_Object nil, Lisp_Object fn, Lisp_Object a)
{
if (is_symbol(fn)) return (*qfn1(fn))(qenv(fn), a);
push(a);
stackcheck1(1, fn);
return apply(fn, 1, C_nil, fn);
}
Lisp_Object MS_CDECL Lapply2(Lisp_Object nil, int nargs, ...)
{
va_list aa;
Lisp_Object fn, a, b;
argcheck(nargs, 3, "apply2");
va_start(aa, nargs);
fn = va_arg(aa, Lisp_Object);
a = va_arg(aa, Lisp_Object);
b = va_arg(aa, Lisp_Object);
va_end(aa);
if (is_symbol(fn)) return (*qfn2(fn))(qenv(fn), a, b);
push2(a, b);
stackcheck1(2, fn);
return apply(fn, 2, C_nil, fn);
}
Lisp_Object MS_CDECL Lapply3(Lisp_Object nil, int nargs, ...)
{
va_list aa;
Lisp_Object fn, a, b, c;
argcheck(nargs, 4, "apply3");
va_start(aa, nargs);
fn = va_arg(aa, Lisp_Object);
a = va_arg(aa, Lisp_Object);
b = va_arg(aa, Lisp_Object);
c = va_arg(aa, Lisp_Object);
va_end(aa);
if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 3, a, b, c);
push3(a, b, c);
stackcheck1(3, fn);
return apply(fn, 3, C_nil, fn);
}
Lisp_Object Lfuncall1(Lisp_Object nil, Lisp_Object fn)
{
if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 0);
stackcheck1(0, fn);
return apply(fn, 0, nil, fn);
}
Lisp_Object Lfuncall2(Lisp_Object nil, Lisp_Object fn, Lisp_Object a1)
{
if (is_symbol(fn)) return (*qfn1(fn))(qenv(fn), a1);
push(a1);
stackcheck1(1, fn);
return apply(fn, 1, nil, fn);
}
static Lisp_Object MS_CDECL Lfuncalln_sub(Lisp_Object nil, int nargs, va_list a)
{
Lisp_Object *stack_save = stack, fn;
fn = va_arg(a, Lisp_Object);
push_args_1(a, nargs);
stackcheck1(stack-stack_save, fn);
return apply(fn, nargs-1, nil, fn);
}
Lisp_Object MS_CDECL Lfuncalln(Lisp_Object nil, int nargs, ...)
{
va_list a;
Lisp_Object fn, a1, a2, a3, a4;
va_start(a, nargs);
switch (nargs)
{
case 0: return aerror("funcall");
case 1: /* cases 1 and 2 should go through Lfuncall1,2 not here */
case 2: return aerror("funcall wrong call");
case 3: fn = va_arg(a, Lisp_Object);
a1 = va_arg(a, Lisp_Object);
a2 = va_arg(a, Lisp_Object);
if (is_symbol(fn)) return (*qfn2(fn))(qenv(fn), a1, a2);
push2(a1, a2);
return apply(fn, 2, nil, fn);
case 4: fn = va_arg(a, Lisp_Object);
a1 = va_arg(a, Lisp_Object);
a2 = va_arg(a, Lisp_Object);
a3 = va_arg(a, Lisp_Object);
if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 3, a1, a2, a3);
push3(a1, a2, a3);
return apply(fn, 3, nil, fn);
case 5: fn = va_arg(a, Lisp_Object);
a1 = va_arg(a, Lisp_Object);
a2 = va_arg(a, Lisp_Object);
a3 = va_arg(a, Lisp_Object);
a4 = va_arg(a, Lisp_Object);
if (is_symbol(fn)) return (*qfnn(fn))(qenv(fn), 4, a1, a2, a3, a4);
push4(a1, a2, a3, a4);
return apply(fn, 4, nil, fn);
default:
return Lfuncalln_sub(nil, nargs, a);
}
}
#ifdef COMMON
Lisp_Object MS_CDECL Lvalues(Lisp_Object nil, int nargs, ...)
{
va_list a;
Lisp_Object *p = &mv_2, w;
int i;
/*
* Because multiple-values get passed back in static storage there is
* a fixed upper limit to how many I can handle - truncate here to allow
* for that.
*/
if (nargs > 50) nargs = 50;
if (nargs == 0) return nvalues(nil, 0);
va_start(a, nargs);
push_args(a, nargs);
for (i=1; i<nargs; i++)
{ pop(w);
p[nargs-i-1] = w;
}
pop(w);
return nvalues(w, nargs);
}
Lisp_Object Lvalues_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
return Lvalues(nil, 2, a, b);
}
Lisp_Object Lvalues_1(Lisp_Object nil, Lisp_Object a)
{
return Lvalues(nil, 1, a);
}
Lisp_Object mv_call_fn(Lisp_Object args, Lisp_Object env)
/*
* here with the rest of the interpreter rather than in specforms.c
*/
{
Lisp_Object nil = C_nil;
Lisp_Object fn, *stack_save = stack;
int i=0, j=0;
if (!consp(args)) return nil; /* (multiple-value-call) => nil */
stackcheck2(0, args, env);
push2(args, env);
fn = qcar(args);
fn = eval(fn, env);
pop2(env, args);
errexit();
args = qcdr(args);
while (consp(args))
{ Lisp_Object r1;
push2(args, env);
r1 = qcar(args);
r1 = eval(r1, env);
nil = C_nil;
if (exception_pending())
{ stack = stack_save;
return nil;
}
/*
* It is critical here that push does not check for stack overflow and
* thus can not call the garbage collector, or otherwise lead to calculation
* that could possibly clobber the multiple results that I am working with
* here.
*/
pop2(env, args);
push(r1);
i++;
for (j = 2; j<=exit_count; j++)
{ push((&work_0)[j]);
i++;
}
args = qcdr(args);
}
stackcheck2(stack-stack_save, fn, env);
return apply(fn, i, env, fn);
}
#endif
Lisp_Object interpreted1(Lisp_Object def, Lisp_Object a1)
{
Lisp_Object nil = C_nil;
push(a1);
stackcheck1(1, def);
return apply_lambda(def, 1, nil, def);
}
Lisp_Object interpreted2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
{
Lisp_Object nil = C_nil;
push2(a1, a2);
stackcheck1(2, def);
return apply_lambda(def, 2, nil, def);
}
Lisp_Object MS_CDECL interpretedn(Lisp_Object def, int nargs, ...)
{
/*
* The messing about here is to get the (unknown number of) args
* into a nice neat vector so that they can be indexed into. If I knew
* that the args were in consecutive locations on the stack I could
* probably save a copying operation.
*/
Lisp_Object nil = C_nil;
Lisp_Object *stack_save = stack;
va_list a;
if (nargs != 0)
{ va_start(a, nargs);
push_args(a, nargs);
}
stackcheck1(stack-stack_save, def);
return apply_lambda(def, nargs, nil, def);
}
Lisp_Object funarged1(Lisp_Object def, Lisp_Object a1)
{
Lisp_Object nil = C_nil;
push(a1);
stackcheck1(1, def);
return apply_lambda(qcdr(def), 1, qcar(def), qcdr(def));
}
Lisp_Object funarged2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
{
Lisp_Object nil = C_nil;
push2(a1, a2);
stackcheck1(2, def);
return apply_lambda(qcdr(def), 2, qcar(def), qcdr(def));
}
Lisp_Object MS_CDECL funargedn(Lisp_Object def, int nargs, ...)
{
Lisp_Object nil = C_nil;
Lisp_Object *stack_save = stack;
va_list a;
if (nargs != 0)
{ va_start(a, nargs);
push_args(a, nargs);
}
stackcheck1(stack-stack_save, def);
return apply_lambda(qcdr(def), nargs, qcar(def), qcdr(def));
}
/*
* Now some execution-doubling versions...
*/
Lisp_Object double_interpreted1(Lisp_Object def, Lisp_Object a1)
{
Lisp_Object nil = C_nil;
push(a1);
stackcheck1(1, def);
return apply_lambda(def, 1, nil, def);
}
Lisp_Object double_interpreted2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
{
Lisp_Object nil = C_nil;
push2(a1, a2);
stackcheck1(2, def);
return apply_lambda(def, 2, nil, def);
}
Lisp_Object MS_CDECL double_interpretedn(Lisp_Object def, int nargs, ...)
{
/*
* The messing about here is to get the (unknown number of) args
* into a nice neat vector so that they can be indexed into. If I knew
* that the args were in consecutive locations on the stack I could
* probably save a copying operation.
*/
Lisp_Object nil = C_nil;
Lisp_Object *stack_save = stack;
va_list a;
if (nargs != 0)
{ va_start(a, nargs);
push_args(a, nargs);
}
stackcheck1(stack-stack_save, def);
return apply_lambda(def, nargs, nil, def);
}
Lisp_Object double_funarged1(Lisp_Object def, Lisp_Object a1)
{
Lisp_Object nil = C_nil;
push(a1);
stackcheck1(1, def);
return apply_lambda(qcdr(def), 1, qcar(def), qcdr(def));
}
Lisp_Object double_funarged2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
{
Lisp_Object nil = C_nil;
push2(a1, a2);
stackcheck1(2, def);
return apply_lambda(qcdr(def), 2, qcar(def), qcdr(def));
}
Lisp_Object MS_CDECL double_funargedn(Lisp_Object def, int nargs, ...)
{
Lisp_Object nil = C_nil;
Lisp_Object *stack_save = stack;
va_list a;
if (nargs != 0)
{ va_start(a, nargs);
push_args(a, nargs);
}
stackcheck1(stack-stack_save, def);
return apply_lambda(qcdr(def), nargs, qcar(def), qcdr(def));
}
Lisp_Object traceinterpreted1(Lisp_Object def, Lisp_Object a1)
/*
* Like interpreted() but the definition has the fn name consed on the front
*/
{
Lisp_Object nil = C_nil, r;
push(a1);
stackcheck1(1, def);
freshline_trace();
trace_printf("Entering ");
loop_print_trace(qcar(def));
trace_printf(" (1 arg)\n");
trace_printf("Arg1: ");
loop_print_trace(stack[0]);
trace_printf("\n");
r = apply_lambda(qcdr(def), 1, nil, def);
errexit();
push(r);
trace_printf("Value = ");
loop_print_trace(r);
trace_printf("\n");
pop(r);
return r;
}
Lisp_Object traceinterpreted2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
/*
* Like interpreted() but the definition has the fn name consed on the front
*/
{
Lisp_Object nil = C_nil, r;
int i;
push2(a1, a2);
stackcheck1(2, def);
freshline_trace();
trace_printf("Entering ");
loop_print_trace(qcar(def));
trace_printf(" (2 args)\n");
for (i=1; i<=2; i++)
{ trace_printf("Arg%d: ", i);
loop_print_trace(stack[i-2]);
trace_printf("\n");
}
r = apply_lambda(qcdr(def), 2, nil, def);
errexit();
push(r);
trace_printf("Value = ");
loop_print_trace(r);
trace_printf("\n");
pop(r);
return r;
}
Lisp_Object MS_CDECL traceinterpretedn(Lisp_Object def, int nargs, ...)
/*
* Like interpreted() but the definition has the fn name consed on the front
*/
{
int i;
Lisp_Object nil = C_nil, r;
Lisp_Object *stack_save = stack;
va_list a;
if (nargs != 0)
{ va_start(a, nargs);
push_args(a, nargs);
}
stackcheck1(stack-stack_save, def);
freshline_trace();
trace_printf("Entering ");
loop_print_trace(qcar(def));
trace_printf(" (%d args)\n", nargs);
for (i=1; i<=nargs; i++)
{ trace_printf("Arg%d: ", i);
loop_print_trace(stack[i-nargs]);
trace_printf("\n");
}
r = apply_lambda(qcdr(def), nargs, nil, def);
errexit();
push(r);
trace_printf("Value = ");
loop_print_trace(r);
trace_printf("\n");
pop(r);
return r;
}
Lisp_Object tracefunarged1(Lisp_Object def, Lisp_Object a1)
/*
* Like funarged() but with some printing
*/
{
Lisp_Object nil = C_nil, r;
push(a1);
stackcheck1(1, def);
freshline_trace();
trace_printf("Entering funarg ");
loop_print_trace(qcar(def));
trace_printf(" (1 arg)\n");
def = qcdr(def);
r = apply_lambda(qcdr(def), 1, qcar(def), qcdr(def));
errexit();
push(r);
trace_printf("Value = ");
loop_print_trace(r);
trace_printf("\n");
pop(r);
return r;
}
Lisp_Object tracefunarged2(Lisp_Object def, Lisp_Object a1, Lisp_Object a2)
/*
* Like funarged() but with some printing
*/
{
Lisp_Object nil = C_nil, r;
push2(a1, a2);
stackcheck1(2, def);
freshline_trace();
trace_printf("Entering funarg ");
loop_print_trace(qcar(def));
trace_printf(" (2 args)\n");
def = qcdr(def);
r = apply_lambda(qcdr(def), 2, qcar(def), qcdr(def));
errexit();
push(r);
trace_printf("Value = ");
loop_print_trace(r);
trace_printf("\n");
pop(r);
return r;
}
Lisp_Object MS_CDECL tracefunargedn(Lisp_Object def, int nargs, ...)
/*
* Like funarged() but with some printing
*/
{
Lisp_Object nil = C_nil, r;
Lisp_Object *stack_save = stack;
va_list a;
if (nargs != 0)
{ va_start(a, nargs);
push_args(a, nargs);
}
stackcheck1(stack-stack_save, def);
freshline_trace();
trace_printf("Entering funarg ");
loop_print_trace(qcar(def));
trace_printf(" (%d args)\n", nargs);
def = qcdr(def);
r = apply_lambda(qcdr(def), nargs, qcar(def), qcdr(def));
errexit();
push(r);
trace_printf("Value = ");
loop_print_trace(r);
trace_printf("\n");
pop(r);
return r;
}
static Lisp_Object macroexpand_1(Lisp_Object form, Lisp_Object env)
{ /* The environment here seems only necessary for macrolet */
Lisp_Object done;
Lisp_Object f, nil;
nil = C_nil;
stackcheck2(0, form, env);
done = nil;
if (consp(form))
{ f = qcar(form);
#ifdef COMMON
/*
* look for local macro definitions
*/
{ Lisp_Object p;
for (p=env; p!=nil; p=qcdr(p))
{ Lisp_Object w = qcar(p);
if (qcdr(w) == f && is_cons(w = qcar(w)) && w!=nil)
{
p = qcar(w);
if (p == funarg) /* ordinary function */
{ mv_2 = nil;
return nvalues(form, 2);
}
push2(form, done);
w = cons(lambda, w);
errexitn(1);
p = Lfuncalln(nil, 4, qvalue(macroexpand_hook),
w, stack[-1], nil);
pop2(done, form);
nil = C_nil;
if (exception_pending())
{ flip_exception();
if ((exit_reason & UNWIND_ERROR) != 0)
{ err_printf("\nMacroexpanding: ");
loop_print_error(form);
nil = C_nil;
if (exception_pending()) flip_exception();
}
flip_exception();
return nil;
}
mv_2 = lisp_true;
return nvalues(p, 2);
}
}
}
/*
* If there is no local macro definition I need to look for a global one
*/
#endif
if (symbolp(f) && (qheader(f) & SYM_MACRO) != 0)
{
done = qvalue(macroexpand_hook);
if (done == unset_var)
return error(1, err_macroex_hook, macroexpand_hook);
push3(form, env, done);
f = cons(lambda, qenv(f));
pop3(done, env, form);
nil = C_nil;
if (!exception_pending())
{
#ifndef COMMON
/* CSL does not pass an environment down here, so does not demand &opt arg */
form = Lfuncalln(nil, 3, done, f, form);
#else
form = Lfuncalln(nil, 4, done, f, form, env);
#endif
nil = C_nil;
}
if (exception_pending()) return nil;
done = lisp_true;
}
}
mv_2 = done;
return nvalues(form, 2); /* Multiple values handed back */
}
Lisp_Object macroexpand(Lisp_Object form, Lisp_Object env)
{ /* The environment here seems only necessary for macrolet */
Lisp_Object done, nil;
nil = C_nil;
stackcheck2(0, form, env);
done = nil;
for (;;)
{ push2(env, done);
form = macroexpand_1(form, env);
pop2(done, env);
errexit();
if (mv_2 == nil) break;
done = lisp_true;
}
mv_2 = done;
return nvalues(form, 2); /* Multiple values handed back */
}
Lisp_Object Lmacroexpand(Lisp_Object nil, Lisp_Object a)
{
return macroexpand(a, nil);
}
#ifdef COMMON
Lisp_Object Lmacroexpand_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
CSL_IGNORE(nil);
return macroexpand(a, b);
}
#endif
Lisp_Object Lmacroexpand_1(Lisp_Object nil, Lisp_Object a)
{
return macroexpand_1(a, nil);
}
#ifdef COMMON
Lisp_Object Lmacroexpand_1_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
{
CSL_IGNORE(nil);
return macroexpand_1(a, b);
}
#endif
/*
* To make something autoloadable I should set the environment cell to
* (name-of-self module-name-1 module-name-2 ...)
* and when invoked the function will do a load-module on each of the
* modules specified and then re-attempt to call. Loading the
* modules is expected to establish a proper definition for the
* function involved.
*/
Lisp_Object autoload1(Lisp_Object fname, Lisp_Object a1)
{
Lisp_Object nil = C_nil;
push2(a1, qcar(fname));
set_fns(qcar(fname), undefined1, undefined2, undefinedn);
qenv(qcar(fname)) = qcar(fname);
fname = qcdr(fname);
while (consp(fname))
{ push(qcdr(fname));
Lload_module(nil, qcar(fname));
errexitn(3);
pop(fname);
}
pop(fname);
return apply(fname, 1, nil, fname);
}
Lisp_Object autoload2(Lisp_Object fname, Lisp_Object a1, Lisp_Object a2)
{
Lisp_Object nil = C_nil;
push3(a1, a2, qcar(fname));
set_fns(qcar(fname), undefined1, undefined2, undefinedn);
qenv(qcar(fname)) = qcar(fname);
fname = qcdr(fname);
while (consp(fname))
{ push(qcdr(fname));
Lload_module(nil, qcar(fname));
errexitn(4);
pop(fname);
}
pop(fname);
return apply(fname, 2, nil, fname);
}
Lisp_Object MS_CDECL autoloadn(Lisp_Object fname, int nargs, ...)
{
Lisp_Object nil = C_nil;
va_list a;
va_start(a, nargs);
push_args(a, nargs);
push(qcar(fname));
set_fns(qcar(fname), undefined1, undefined2, undefinedn);
qenv(qcar(fname)) = qcar(fname);
fname = qcdr(fname);
while (consp(fname))
{ push(qcdr(fname));
Lload_module(nil, qcar(fname));
errexitn(nargs+2);
pop(fname);
}
pop(fname);
return apply(fname, nargs, nil, fname);
}
Lisp_Object undefined1(Lisp_Object fname, Lisp_Object a1)
{
/*
* It would be perfectly possible to grab and save the args here, and retry
* the function call after error has patched things up. Again
* this entrypoint is for compiled code calling something that is undefined,
* and so no lexical environment is needed.
*/
CSL_IGNORE(a1);
return error(1, err_undefined_function_1, fname);
}
Lisp_Object undefined2(Lisp_Object fname, Lisp_Object a1, Lisp_Object a2)
{
CSL_IGNORE(a1);
CSL_IGNORE(a2);
return error(1, err_undefined_function_2, fname);
}
Lisp_Object MS_CDECL undefinedn(Lisp_Object fname, int nargs, ...)
{
CSL_IGNORE(nargs);
return error(1, err_undefined_function_n, fname);
}
/*
* The next few functions allow me to create variants on things! The
* entrypoint fX_as_Y goes in the function cell of a symbol, and the name
* of a function with Y arguments goes in is environment cell. The result will
* be a function that accepts X arguments and discards all but the first Y of
* them, then chains to the other function. The purpose is to support goo
* compilation of things like
* (de funny_equal (a b c) (equal a b))
*/
Lisp_Object MS_CDECL f0_as_0(Lisp_Object env, int nargs, ...)
{
if (nargs != 0) return aerror1("wrong number of args (0->0)", env);
return (*qfnn(env))(qenv(env), 0);
}
Lisp_Object f1_as_0(Lisp_Object env, Lisp_Object a)
{
CSL_IGNORE(a);
return (*qfnn(env))(qenv(env), 0);
}
Lisp_Object f2_as_0(Lisp_Object env, Lisp_Object a, Lisp_Object b)
{
CSL_IGNORE(a);
CSL_IGNORE(b);
return (*qfnn(env))(qenv(env), 0);
}
Lisp_Object MS_CDECL f3_as_0(Lisp_Object env, int nargs, ...)
{
if (nargs != 3) return aerror1("wrong number of args (3->0)", env);
return (*qfnn(env))(qenv(env), 0);
}
Lisp_Object f1_as_1(Lisp_Object env, Lisp_Object a)
{
return (*qfn1(env))(qenv(env), a);
}
Lisp_Object f2_as_1(Lisp_Object env, Lisp_Object a, Lisp_Object b)
{
CSL_IGNORE(b);
return (*qfn1(env))(qenv(env), a);
}
Lisp_Object MS_CDECL f3_as_1(Lisp_Object env, int nargs, ...)
{
va_list a;
Lisp_Object a1;
if (nargs != 3) return aerror1("wrong number of args (3->1)", env);
va_start(a, nargs);
a1 = va_arg(a, Lisp_Object);
va_end(a);
return (*qfn1(env))(qenv(env), a1);
}
Lisp_Object f2_as_2(Lisp_Object env, Lisp_Object a, Lisp_Object b)
{
return (*qfn2(env))(qenv(env), a, b);
}
Lisp_Object MS_CDECL f3_as_2(Lisp_Object env, int nargs, ...)
{
va_list a;
Lisp_Object a1, a2;
if (nargs != 3) return aerror1("wrong number of args (3->2)", env);
va_start(a, nargs);
a1 = va_arg(a, Lisp_Object);
a2 = va_arg(a, Lisp_Object);
va_end(a);
return (*qfn2(env))(qenv(env), a1, a2);
}
Lisp_Object MS_CDECL f3_as_3(Lisp_Object env, int nargs, ...)
{
va_list a;
Lisp_Object a1, a2, a3;
if (nargs != 3) return aerror1("wrong number of args (3->3)", env);
va_start(a, nargs);
a1 = va_arg(a, Lisp_Object);
a2 = va_arg(a, Lisp_Object);
a3 = va_arg(a, Lisp_Object);
va_end(a);
return (*qfnn(env))(qenv(env), 3, a1, a2, a3);
}
setup_type const eval1_setup[] =
{
{"bytecounts", wrong_no_na, wrong_no_nb, bytecounts},
{"apply", Lapply_1, Lapply_2, Lapply_n},
{"apply0", Lapply0, too_many_1, wrong_no_1},
{"apply1", too_few_2, Lapply1, wrong_no_2},
{"apply2", wrong_no_na, wrong_no_nb, Lapply2},
{"apply3", wrong_no_na, wrong_no_nb, Lapply3},
{"evlis", Levlis, too_many_1, wrong_no_1},
{"funcall", Lfuncall1, Lfuncall2, Lfuncalln},
{"funcall*", Lfuncall1, Lfuncall2, Lfuncalln},
#ifdef COMMON
{"values", Lvalues_1, Lvalues_2, Lvalues},
{"macroexpand", Lmacroexpand, Lmacroexpand_2, wrong_no_1},
{"macroexpand-1", Lmacroexpand_1, Lmacroexpand_1_2, wrong_no_1},
#else
{"macroexpand", Lmacroexpand, too_many_1, wrong_no_1},
{"macroexpand-1", Lmacroexpand_1, too_many_1, wrong_no_1},
#endif
{NULL, 0, 0, 0}
};
/* end of eval1.c */