/* xlsubr - xlisp builtin function support routines */
/*		Copyright (c) 1985, by David Michael Betz
		All Rights Reserved
		Permission is granted for unrestricted non-commercial use		*/

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

/* external variables */
extern LVAL k_test,k_tnot,s_eql;

/* xlsubr - define a builtin function */
#ifdef ANSI
LVAL xlsubr(char *sname, int type, LVAL (*fcn)(void), int offset)
#else
LVAL xlsubr(sname,type,fcn,offset)
  char *sname; int type; LVAL (*fcn)(); int offset;
#endif
{
	LVAL sym;
	sym = xlenter(sname);
	setfunction(sym,cvsubr(fcn,type,offset));
	return (sym);
}

/* xlgetkeyarg - get a keyword argument */
int xlgetkeyarg(key,pval)
  LVAL key,*pval;
{
	LVAL *argv=xlargv;
	int argc=xlargc;
	for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
		if (*argv == key) {
			*pval = *++argv;
			return (TRUE);
		}
	}
	return (FALSE);
}

/* xlgkfixnum - get a fixnum keyword argument */
int xlgkfixnum(key,pval)
  LVAL key,*pval;
{
	if (xlgetkeyarg(key,pval)) {
		if (!fixp(*pval))
			xlbadtype(*pval);
		return (TRUE);
	}
	return (FALSE);
}

/* xltest - get the :test or :test-not keyword argument */
VOID xltest(pfcn,ptresult)
  LVAL *pfcn; int *ptresult;
{
	if (xlgetkeyarg(k_test,pfcn))		/* :test */
		*ptresult = TRUE;
	else if (xlgetkeyarg(k_tnot,pfcn))	/* :test-not */
		*ptresult = FALSE;
	else {
		*pfcn = getfunction(s_eql);
		*ptresult = TRUE;
	}
}

/* xlgetfile - get a file or stream */
LVAL xlgetfile()
{
	LVAL arg;

	/* get a file or stream (cons) or nil */
	if ((arg = xlgetarg()) != 0) {
		if (streamp(arg)) {
			if (getfile(arg) == NULL)
				xlfail("file not open");
		}
		else if (!ustreamp(arg))
			xlbadtype(arg);
	}
	return (arg);
}

/* xlgetfname - get a filename */
LVAL xlgetfname()
{
	LVAL name;

	/* get the next argument */
	name = xlgetarg();

	/* get the filename string */
	if (symbolp(name))
		name = getpname(name);
	else if (!stringp(name))
		xlbadtype(name);

	/* return the name */
	return (name);
}

/* needsextension - check if a filename needs an extension */
int needsextension(name)
  char *name;
{
	char *p;

	/* check for an extension */
	for (p = &name[strlen(name)]; --p >= &name[0]; )
		if (*p == '.')
			return (FALSE);
		else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
			return (TRUE);

	/* no extension found */
	return (TRUE);
}

/* xlbadtype - report a "bad argument type" error */
LVAL xlbadtype(arg)
  LVAL arg;
{
	return xlerror("bad argument type",arg);
}

/* xltoofew - report a "too few arguments" error */
LVAL xltoofew()
{
	xlfail("too few arguments");
	return (NIL);	/* never returns */
}

/* xltoomany - report a "too many arguments" error */
VOID xltoomany()
{
	xlfail("too many arguments");
}

/* eql - internal eql function */
int eql(arg1,arg2)
  LVAL arg1,arg2;
{
	/* compare the arguments */
	if (arg1 == arg2)
		return (TRUE);
	else if (arg1) {
		switch (ntype(arg1)) {
		case FIXNUM:
			return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
		case FLONUM:
			return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
		default:
			return (FALSE);
		}
	}
	else
		return (FALSE);
}

/* equal- internal equal function */
int equal(arg1,arg2)
  LVAL arg1,arg2;
{
	/* compare the arguments */
isItEqual:	/* turn tail recursion into iteration */
	if (arg1 == arg2)
		return (TRUE);
	else if (arg1) {
		switch (ntype(arg1)) {
		case FIXNUM:
			return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
		case FLONUM:
			return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
		case STRING:
			return (stringp(arg2) ? strcmp((char *)getstring(arg1),
										   (char *)getstring(arg2)) == 0 : FALSE);
		case CONS:	/* TAA MOD turns tail recursion into iteration */
					/* Not only is this faster, but greatly reduces chance */
					/* of stack overflow */
			if (consp(arg2) && equal(car(arg1),car(arg2))) {
				arg1 = cdr(arg1);
				arg2 = cdr(arg2);
				goto isItEqual;
			}
			return FALSE;
		case VECTOR: /* TAA MOD to compare vectors. (Why was it missing?) */
			if (vectorp(arg2) && getsize(arg1) == getsize(arg2)) {
				int i = getsize(arg2);
				for (;--i >= 0;)
					if (getelement(arg1,i) != getelement(arg2,i) &&
						!equal(getelement(arg1,i),getelement(arg2,i)))
						return (FALSE);
				return (TRUE);
			}
			return (FALSE);
		default:
			return (FALSE);
		}
	}
	else
		return (FALSE);
}