/* xleval - xlisp evaluator */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

#include "xlisp.h"
#include <string.h>

/* macro to check for lambda list keywords */
#define iskey(s) ((s) == lk_optional \
			   || (s) == lk_rest \
			   || (s) == lk_key \
			   || (s) == lk_aux \
			   || (s) == lk_allow_other_keys)

/* macros to handle tracing */
#define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
#define trexit(sym,val) {if (sym) doexit(sym,val);}

/* external variables */
extern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
extern LVAL s_evalhook,s_applyhook,s_tracelist;
extern LVAL s_lambda,s_macro;
extern LVAL s_unbound;
extern int xlsample;
extern char buf[];

/* local forward declarations */
#ifdef ANSI
VOID badarglist(void);
VOID doenter(LVAL sym, int argc, LVAL *argv);
VOID doexit(LVAL sym, LVAL val);
LVAL evalhook(LVAL expr);
LVAL evform(LVAL form);
LVAL evfun(LVAL fun, int argc, LVAL *argv);
int  evpushargs(LVAL fun,LVAL args);
int  member(LVAL x, LVAL list);
#ifdef APPLYHOOK
LVAL applyhook(LVAL fun, LVAL args);
#endif
#else
FORWARD VOID badarglist();
FORWARD VOID doenter();
FORWARD VOID doexit();
FORWARD LVAL evalhook();
FORWARD LVAL evform();
FORWARD LVAL evfun();
#ifdef APPLYHOOK
FORWARD LVAL applyhook();
#endif
#endif

#ifdef ANSI
static LVAL xlbadfunction(LVAL arg)
#else
LOCAL LVAL xlbadfunction(arg)
LVAL arg;
#endif
{
		return xlerror("bad function",arg);
}

/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
LVAL xleval(expr)
  LVAL expr;
{
	/* check for control codes */
	if (--xlsample <= 0) {
		xlsample = SAMPLE;
		oscheck();
	}

	/* check for *evalhook* */
	if (getvalue(s_evalhook))
		return (evalhook(expr));

	/* check for nil */
	if (null(expr))
		return (NIL);

	/* dispatch on the node type */
	switch (ntype(expr)) {
	case CONS:
		return (evform(expr));
	case SYMBOL:
		return (xlgetvalue(expr));
	default:
		return (expr);
	}
}

/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
LVAL xlxeval(expr)
  LVAL expr;
{
	/* check for nil */
	if (null(expr))
		return (NIL);

	/* dispatch on node type */
	switch (ntype(expr)) {
	case CONS:
		return (evform(expr));
	case SYMBOL:
		return (xlgetvalue(expr));
	default:
		return (expr);
	}
}

/* xlapply - apply a function to arguments (already on the stack) */
LVAL xlapply(argc)
  int argc;
{
	LVAL fun,val;
	
	/* get the function */
	fun = xlfp[1];

	/* get the functional value of symbols */
	if (symbolp(fun)) {
		while ((val = getfunction(fun)) == s_unbound)
			xlfunbound(fun);
		fun = xlfp[1] = val;
	}

	/* check for nil */
	if (null(fun))
		xlbadfunction(fun);

	/* dispatch on node type */
	switch (ntype(fun)) {
	case SUBR: { 
				LVAL *oldargv;
				int oldargc;
				oldargc = xlargc;
				oldargv = xlargv;
				xlargc = argc;
				xlargv = xlfp + 3;
				val = (*getsubr(fun))();
				xlargc = oldargc;
				xlargv = oldargv;
				break;
		}
	case CONS:
		if (!consp(cdr(fun)))
			xlbadfunction(fun);
		if (car(fun) == s_lambda)
			fun =   xlfp[1]			/* TAA fix (vanNiekerk) */
				=	xlclose(NIL,
						  s_lambda,
						  car(cdr(fun)),
						  cdr(cdr(fun)),
						  xlenv,xlfenv);
		else
			xlbadfunction(fun);
		/**** fall through into the next case ****/
	case CLOSURE:
		if (gettype(fun) != s_lambda)
			xlbadfunction(fun);
		val = evfun(fun,argc,xlfp+3);
		break;
	default:
		xlbadfunction(fun);
	}

	/* remove the call frame */
	xlsp = xlfp;
	xlfp = xlfp - (int)getfixnum(*xlfp);

	/* return the function value */
	return (val);
}

/* evform - evaluate a form */
LOCAL LVAL evform(form)
  LVAL form;
{
	LVAL fun,args,val;
	LVAL tracing=NIL;
	LVAL *argv;
	int argc;


	/* protect some pointers */
	xlstkcheck(2);
	xlsave(fun);
	xlsave(args);

	/* get the function and the argument list */
	fun = car(form);
	args = cdr(form);

	/* get the functional value of symbols */
	if (symbolp(fun)) {
		if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
			tracing = fun;
		fun = xlgetfunction(fun);
	}

	/* check for nil */
	if (null(fun))
		xlbadfunction(NIL);


	/* dispatch on node type */
	switch (ntype(fun)) {
	case SUBR:
#ifdef APPLYHOOK
		/* check for *applyhook* */
		if (getvalue(s_applyhook)) {
			val = (applyhook(fun,args));
			break;
		}
#endif
		argv = xlargv;
		argc = xlargc;
		xlargc = evpushargs(fun,args);
		xlargv = xlfp + 3;
		trenter(tracing,xlargc,xlargv);
		val = (*getsubr(fun))();
		trexit(tracing,val);
		xlsp = xlfp;
		xlfp = xlfp - (int)getfixnum(*xlfp);
		xlargv = argv;
		xlargc = argc;
		break;
	case FSUBR:
		argv = xlargv;
		argc = xlargc;
		xlargc = pushargs(fun,args);
		xlargv = xlfp + 3;
		val = (*getsubr(fun))();
		xlsp = xlfp;
		xlfp = xlfp - (int)getfixnum(*xlfp);
		xlargv = argv;
		xlargc = argc;
		break;
	case CONS:
		if (!consp(cdr(fun)))
			xlbadfunction(fun);
		if ((/* type = */ car(fun)) == s_lambda)
			fun = xlclose(NIL,
						  s_lambda,
						  car(cdr(fun)),
						  cdr(cdr(fun)),
						  xlenv,xlfenv);
		else
			xlbadfunction(fun);
		/**** fall through into the next case ****/
	case CLOSURE:
		if (gettype(fun) == s_lambda) {
#ifdef APPLYHOOK
			/* check for *applyhook* */
			if (getvalue(s_applyhook)) {
				val = (applyhook(fun,args));
				break;
			}
#endif
			argc = evpushargs(fun,args);
			argv = xlfp + 3;
			trenter(tracing,argc,argv);
			val = evfun(fun,argc,argv);
			trexit(tracing,val);
			xlsp = xlfp;
			xlfp = xlfp - (int)getfixnum(*xlfp);
		}
		else {
			macroexpand(fun,args,&fun);
			val = xleval(fun);
		}
		break;
	default:
		xlbadfunction(fun);
	}

	/* restore the stack */
	xlpopn(2);

	/* return the result value */
	return (val);
}

/* xlexpandmacros - expand macros in a form */
LVAL xlexpandmacros(form)
  LVAL form;
{
	LVAL fun,args;
	
	/* protect some pointers */
	xlstkcheck(3);
	xlprotect(form);
	xlsave(fun);
	xlsave(args);

	/* expand until the form isn't a macro call */
	while (consp(form)) {
		fun = car(form);				/* get the macro name */
		args = cdr(form);				/* get the arguments */
		if (!symbolp(fun) || !fboundp(fun))
			break;
		fun = xlgetfunction(fun);		/* get the expansion function */
		if (!macroexpand(fun,args,&form))
			break;
	}

	/* restore the stack and return the expansion */
	xlpopn(3);
	return (form);
}

/* macroexpand - expand a macro call */
int macroexpand(fun,args,pval)
  LVAL fun,args,*pval;
{
	LVAL *argv;
	int argc;
	
	/* make sure it's really a macro call */
	if (!closurep(fun) || gettype(fun) != s_macro)
		return (FALSE);
		
	/* call the expansion function */
	argc = pushargs(fun,args);
	argv = xlfp + 3;
	*pval = evfun(fun,argc,argv);
	xlsp = xlfp;
	xlfp = xlfp - (int)getfixnum(*xlfp);
	return (TRUE);
}

/* evalhook - call the evalhook function */
LOCAL LVAL evalhook(expr)
  LVAL expr;
{
	LVAL *newfp,olddenv,val;

	/* create the new call frame */
	newfp = xlsp;
	pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
	pusharg(getvalue(s_evalhook));
	pusharg(cvfixnum((FIXTYPE)2));
	pusharg(expr);
	pusharg(cons(xlenv,xlfenv));
	xlfp = newfp;

	/* rebind the hook functions to nil */
	olddenv = xldenv;
	xldbind(s_evalhook,NIL);
	xldbind(s_applyhook,NIL);

	/* call the hook function */
	val = xlapply(2);

	/* unbind the symbols */
	xlunbind(olddenv);

	/* return the value */
	return (val);
}

#ifdef APPLYHOOK
/* applyhook - call the applyhook function */
LOCAL LVAL applyhook(fun,args)
  LVAL fun,args;
{
	LVAL *newfp,olddenv,val,last,next;

	xlsave1(val);	/* protect against GC */

	if (consp(args)) { /* build argument list -- if there are any */
		/* we will pass evaluated arguments, with hooks enabled */
		/* so argument evaluation will be hooked too */
		val = last = consa(xleval(car(args)));
		args = cdr(args);
		while (consp(args)) { /* handle any more in loop */
			next = consa(xleval(car(args)));
			rplacd(last,next);
			last = next;
			args = cdr(args);
		}
	}

	/* create the new call frame */
	newfp = xlsp;
	pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
	pusharg(getvalue(s_applyhook));
	pusharg(cvfixnum((FIXTYPE)2));
	pusharg(fun);
	pusharg(val);
	xlfp = newfp;

	/* rebind hook functions to NIL */

	olddenv = xldenv;
	xldbind(s_evalhook,NIL);
	xldbind(s_applyhook,NIL);


	/* call the hook function */
	val = xlapply(2);

	/* unbind the symbols */
	xlunbind(olddenv);

	/* return the value */
	return (val);
}
#endif

/* evpushargs - evaluate and push a list of arguments */
LOCAL int evpushargs(fun,args)
  LVAL fun,args;
{
	LVAL *newfp;
	int argc;
	
	/* protect the argument list */
	xlprot1(args);

	/* build a new argument stack frame */
	newfp = xlsp;

	pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
	pusharg(fun);
	pusharg(NIL); /* will be argc */

	/* evaluate and push each argument */
	for (argc = 0; consp(args); args = cdr(args), ++argc)
		pusharg(xleval(car(args)));

	/* establish the new stack frame */

	newfp[2] = cvfixnum((FIXTYPE)argc);
	xlfp = newfp;
	
	/* restore the stack */
	xlpop();

	/* return the number of arguments */
	return (argc);
}

/* pushargs - push a list of arguments */
int pushargs(fun,args)
  LVAL fun,args;
{
	LVAL *newfp;
	int argc;
	
	/* build a new argument stack frame */
	newfp = xlsp;
	pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
	pusharg(fun);
	pusharg(NIL); /* will be argc */

	/* push each argument */
	for (argc = 0; consp(args); args = cdr(args), ++argc)
		pusharg(car(args));

	/* establish the new stack frame */
	newfp[2] = cvfixnum((FIXTYPE)argc);
	xlfp = newfp;

	/* return the number of arguments */
	return (argc);
}

/* makearglist - make a list of the remaining arguments */
LVAL makearglist(argc,argv)
  int argc; LVAL *argv;
{
	LVAL list,this,last;
	xlsave1(list);
	for (last = NIL; --argc >= 0; last = this) {
		this = cons(*argv++,NIL);
		if (last) rplacd(last,this);
		else list = this;
		last = this;
	}
	xlpop();
	return (list);
}

#ifdef MSC6
/* no optimization which interferes with setjmp */
#pragma optimize("elg",off)
#endif

/* evfun - evaluate a function */
LOCAL LVAL evfun(fun,argc,argv)
  LVAL fun; int argc; LVAL *argv;
{
	LVAL oldenv,oldfenv,cptr,val;
	CONTEXT cntxt;

	/* protect some pointers */
	xlstkcheck(3);
	xlsave(oldenv);
	xlsave(oldfenv);
	xlsave(cptr);

	/* create a new environment frame */
	oldenv = xlenv;
	oldfenv = xlfenv;
	xlenv = xlframe(getenvi(fun));
	xlfenv = getfenv(fun);

	/* bind the formal parameters */
	xlabind(fun,argc,argv);

	/* setup the implicit block */
	if (getname(fun) != 0)
		xlbegin(&cntxt,CF_RETURN,getname(fun));

	/* execute the block */
	if (getname(fun) && setjmp(cntxt.c_jmpbuf))
		val = xlvalue;
	else
		for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr)) {

				/* check for control codes */
				if (--xlsample <= 0) {
						xlsample = SAMPLE;
						oscheck();
				}

				val = car(cptr);

				/* check for *evalhook* */
				if (getvalue(s_evalhook)) {
						val = evalhook(val);
						continue;
				}

				/* check for nil */
				if (null(val)) {
						val = NIL;
						continue;
				}

				/* dispatch on the node type */
				switch (ntype(val)) {
						case CONS:
								val = evform(val);
								break;
						case SYMBOL:
								val = xlgetvalue(val);
								break;
						default: /* nothing */
								break;
				}
		}
/*				val = xleval(car(cptr)); */

	/* finish the block context */
	if (getname(fun))
		xlend(&cntxt);

	/* restore the environment */
	xlenv = oldenv;
	xlfenv = oldfenv;

	/* restore the stack */
	xlpopn(3);

	/* return the result value */
	return (val);
}

#ifdef MSC6
#pragma optimize("",on)
#endif

/* xlclose - create a function closure */
LVAL xlclose(name,type,fargs,body,env,fenv)
  LVAL name,type,fargs,body,env,fenv;
{
	LVAL closure,key,arg,def,svar,new,last;
	char keyname[STRMAX+2];

	/* protect some pointers */
	xlsave1(closure);

	/* create the closure object */
	closure = newclosure(name,type,env,fenv);
	setlambda(closure,fargs);
	setbody(closure,body);

	/* handle each required argument */
	last = NIL;
	while (consp(fargs) && ((arg = car(fargs)) !=0) && !iskey(arg)) {

		/* make sure the argument is a symbol */
		if (!symbolp(arg))
			badarglist();

		/* create a new argument list entry */
		new = cons(arg,NIL);

		/* link it into the required argument list */
		if (last)
			rplacd(last,new);
		else
			setargs(closure,new);
		last = new;

		/* move the formal argument list pointer ahead */
		fargs = cdr(fargs);
	}

	/* check for the '&optional' keyword */
	if (consp(fargs) && car(fargs) == lk_optional) {
		fargs = cdr(fargs);

		/* handle each optional argument */
		last = NIL;
		while (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg)) {

			/* get the default expression and specified-p variable */
			def = svar = NIL;
			if (consp(arg)) {
				if ((def = cdr(arg)) != 0)
					if (consp(def)) {
						if ((svar = cdr(def)) != 0)
							if (consp(svar)) {
								svar = car(svar);
								if (!symbolp(svar))
									badarglist();
							}
							else
								badarglist();
						def = car(def);
					}
					else
						badarglist();
				arg = car(arg);
			}

			/* make sure the argument is a symbol */
			if (!symbolp(arg))
				badarglist();

			/* create a fully expanded optional expression */
			new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);

			/* link it into the optional argument list */
			if (last)
				rplacd(last,new);
			else
				setoargs(closure,new);
			last = new;
				
			/* move the formal argument list pointer ahead */
			fargs = cdr(fargs);
		}
	}

	/* check for the '&rest' keyword */
	if (consp(fargs) && car(fargs) == lk_rest) {
		fargs = cdr(fargs);

		/* get the &rest argument */
		if (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg) && symbolp(arg))
			setrest(closure,arg);
		else
			badarglist();

		/* move the formal argument list pointer ahead */
		fargs = cdr(fargs);
	}

	/* check for the '&key' keyword */
	if (consp(fargs) && car(fargs) == lk_key) {
		fargs = cdr(fargs);

		/* handle each key argument */
		last = NIL;
		while (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg)) {

			/* get the default expression and specified-p variable */
			def = svar = NIL;
			if (consp(arg)) {
				if ((def = cdr(arg)) != 0)
					if (consp(def)) {
						if ((svar = cdr(def)) != 0)
							if (consp(svar)) {
								svar = car(svar);
								if (!symbolp(svar))
									badarglist();
							}
							else
								badarglist();
						def = car(def);
					}
					else
						badarglist();
				arg = car(arg);
			}

			/* get the keyword and the variable */
			if (consp(arg)) {
				key = car(arg);
				if (!symbolp(key))
					badarglist();
				if ((arg = cdr(arg)) != 0)
					if (consp(arg))
						arg = car(arg);
					else
						badarglist();
			}
			else if (symbolp(arg)) {
				strcpy(keyname,":");
				strcat(keyname,(char *)getstring(getpname(arg)));
				key = xlenter(keyname);
			}

			/* make sure the argument is a symbol */
			if (!symbolp(arg))
				badarglist();

			/* create a fully expanded key expression */
			new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);

			/* link it into the optional argument list */
			if (last)
				rplacd(last,new);
			else
				setkargs(closure,new);
			last = new;

			/* move the formal argument list pointer ahead */
			fargs = cdr(fargs);
		}
	}

	/* check for the '&allow-other-keys' keyword */
	if (consp(fargs) && car(fargs) == lk_allow_other_keys)
		fargs = cdr(fargs);		/* this is the default anyway */

	/* check for the '&aux' keyword */
	if (consp(fargs) && car(fargs) == lk_aux) {
		fargs = cdr(fargs);

		/* handle each aux argument */
		last = NIL;
		while (consp(fargs) && ((arg = car(fargs)) != 0) && !iskey(arg)) {

			/* get the initial value */
			def = NIL;
			if (consp(arg)) {
				if ((def = cdr(arg)) != 0)
					if (consp(def))
						def = car(def);
					else
						badarglist();
				arg = car(arg);
			}

			/* make sure the argument is a symbol */
			if (!symbolp(arg))
				badarglist();

			/* create a fully expanded aux expression */
			new = cons(cons(arg,cons(def,NIL)),NIL);

			/* link it into the aux argument list */
			if (last)
				rplacd(last,new);
			else
				setaargs(closure,new);
			last = new;

			/* move the formal argument list pointer ahead */
			fargs = cdr(fargs);
		}
	}

	/* make sure this is the end of the formal argument list */
	if (fargs)
		badarglist();

	/* restore the stack */
	xlpop();

	/* return the new closure */
	return (closure);
}

/* xlabind - bind the arguments for a function */
VOID xlabind(fun,argc,argv)
  LVAL fun; int argc; LVAL *argv;
{
	LVAL *kargv,fargs,key,arg,def,svar,p;
	int rargc,kargc;
	
	/* protect some pointers */
	xlsave1(def);

	/* bind each required argument */
	for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {

		/* make sure there is an actual argument */
		if (--argc < 0)
			xlfail("too few arguments");

		/* bind the formal variable to the argument value */
		xlbind(car(fargs),*argv++);
	}

	/* bind each optional argument */
	for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {

		/* get argument, default and specified-p variable */
		p = car(fargs);
		arg = car(p); p = cdr(p);
		def = car(p); p = cdr(p);
		svar = car(p);

		/* bind the formal variable to the argument value */
		if (--argc >= 0) {
			xlbind(arg,*argv++);
			if (svar) xlbind(svar,true);
		}

		/* bind the formal variable to the default value */
		else {
			if (def) def = xleval(def);
			xlbind(arg,def);
			if (svar) xlbind(svar,NIL);
		}
	}

	/* save the count of the &rest of the argument list */
	rargc = argc;
	
	/* handle '&rest' argument */
	if ((arg = getrest(fun)) != 0) {
		def = makearglist(argc,argv);
		xlbind(arg,def);
		argc = 0;
	}

	/* handle '&key' arguments */
	if ((fargs = getkargs(fun)) != 0) {
		for (; fargs; fargs = cdr(fargs)) {

			/* get keyword, argument, default and specified-p variable */
			p = car(fargs);
			key = car(p); p = cdr(p);
			arg = car(p); p = cdr(p);
			def = car(p); p = cdr(p);
			svar = car(p);

			/* look for the keyword in the actual argument list */
			for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
				if (*kargv == key)
					break;

			/* bind the formal variable to the argument value */
			if (kargc >= 0) {
				xlbind(arg,*++kargv);
				if (svar) xlbind(svar,true);
			}

			/* bind the formal variable to the default value */
			else {
				if (def) def = xleval(def);
				xlbind(arg,def);
				if (svar) xlbind(svar,NIL);
			}
		}
		argc = 0;
	}

	/* check for the '&aux' keyword */
	for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {

		/* get argument and default */
		p = car(fargs);
		arg = car(p); p = cdr(p);
		def = car(p);

		/* bind the auxiliary variable to the initial value */
		if (def) def = xleval(def);
		xlbind(arg,def);
	}

	/* make sure there aren't too many arguments */
	if (argc > 0)
		xlfail("too many arguments");

	/* restore the stack */
	xlpop();
}

/* doenter - print trace information on function entry */
LOCAL VOID doenter(sym,argc,argv)
  LVAL sym; int argc; LVAL *argv;
{
	extern int xltrcindent;
	int i;
	
	/* indent to the current trace level */
	for (i = 0; i < xltrcindent; ++i)
		trcputstr(" ");
	++xltrcindent;

	/* display the function call */
	sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
	trcputstr(buf);
	while (--argc >= 0) {
		trcprin1(*argv++);
		if (argc) trcputstr(" ");
	}
	trcputstr(")\n");
}

/* doexit - print trace information for function/macro exit */
LOCAL VOID doexit(sym,val)
  LVAL sym,val;
{
	extern int xltrcindent;
	int i;
	
	/* indent to the current trace level */
	--xltrcindent;
	for (i = 0; i < xltrcindent; ++i)
		trcputstr(" ");
	
	/* display the function value */
	sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
	trcputstr(buf);
	trcprin1(val);
	trcputstr("\n");
}

/* member - is 'x' a member of 'list'? */
LOCAL int member(x,list)
  LVAL x,list;
{
	for (; consp(list); list = cdr(list))
		if (x == car(list))
			return (TRUE);
	return (FALSE);
}

/* xlunbound - signal an unbound variable error */
VOID xlunbound(sym)
  LVAL sym;
{
	xlcerror("try evaluating symbol again","unbound variable",sym);
}

/* xlfunbound - signal an unbound function error */
VOID xlfunbound(sym)
  LVAL sym;
{
	xlcerror("try evaluating symbol again","unbound function",sym);
}

/* xlstkoverflow - signal a stack overflow error */
VOID xlstkoverflow()
{
	xlabort("evaluation stack overflow");
}

/* xlargstkoverflow - signal an argument stack overflow error */
VOID xlargstkoverflow()
{
	xlabort("argument stack overflow");
}

/* badarglist - report a bad argument list error */
LOCAL VOID badarglist()
{
	xlfail("bad formal argument list");
}