/* xlbfun.c - xlisp basic built-in functions */
/*		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 xlenv,xlfenv,xldenv,true;
extern LVAL s_evalhook,s_applyhook;
extern LVAL s_unbound;
extern char gsprefix[];
extern FIXTYPE gsnumber;

/* forward declarations */
#ifdef ANSI
LVAL makesymbol(int iflag);
#else
FORWARD LVAL makesymbol();
#endif

/* xeval - the built-in function 'eval' */
LVAL xeval()
{
	LVAL expr;

	/* get the expression to evaluate */
	expr = xlgetarg();
	xllastarg();

	/* evaluate the expression */
	return (xleval(expr));
}

/* xapply - the built-in function 'apply' */
LVAL xapply()
{
	LVAL fun,arglist;

	/* get the function and argument list */
	fun = xlgetarg();
	arglist = xlgalist();
	xllastarg();

	/* apply the function to the arguments */
	return (xlapply(pushargs(fun,arglist)));
}

/* xfuncall - the built-in function 'funcall' */
LVAL xfuncall()
{
	LVAL *newfp;
	int argc;
	
	/* build a new argument stack frame */
	newfp = xlsp;
	pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
	pusharg(xlgetarg());
	pusharg(NIL); /* will be argc */

	/* push each argument */
	for (argc = 0; moreargs(); ++argc)
		pusharg(nextarg());

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

	/* apply the function to the arguments */
	return (xlapply(argc));
}

/* xmacroexpand - expand a macro call repeatedly */
LVAL xmacroexpand()
{
	LVAL form;
	form = xlgetarg();
	xllastarg();
	return (xlexpandmacros(form));
}

/* x1macroexpand - expand a macro call */
LVAL x1macroexpand()
{
	LVAL form,fun,args;

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

	/* get the form */
	form = xlgetarg();
	xllastarg();

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

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

/* xatom - is this an atom? */
LVAL xatom()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (atom(arg) ? true : NIL);
}

/* xsymbolp - is this an symbol? */
LVAL xsymbolp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (arg == NIL || symbolp(arg) ? true : NIL);
}

/* xnumberp - is this a number? */
LVAL xnumberp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (fixp(arg) || floatp(arg) ? true : NIL);
}

/* xintegerp - is this an integer? */
LVAL xintegerp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (fixp(arg) ? true : NIL);
}

/* xfloatp - is this a float? */
LVAL xfloatp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (floatp(arg) ? true : NIL);
}

/* xcharp - is this a character? */
LVAL xcharp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (charp(arg) ? true : NIL);
}

/* xstringp - is this a string? */
LVAL xstringp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (stringp(arg) ? true : NIL);
}

/* xarrayp - is this an array? */
LVAL xarrayp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (vectorp(arg) ? true : NIL);
}

/* xstreamp - is this a stream? */
LVAL xstreamp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (streamp(arg) || ustreamp(arg) ? true : NIL);
}

/* xobjectp - is this an object? */
LVAL xobjectp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (objectp(arg) ? true : NIL);
}

/* xboundp - is this a value bound to this symbol? */
LVAL xboundp()
{
	LVAL sym;
	sym = xlgasymornil();	/* TAA fix */
	xllastarg();
	return (sym == NIL || boundp(sym) ? true : NIL);
}

/* xfboundp - is this a functional value bound to this symbol? */
LVAL xfboundp()
{
	LVAL sym;
	sym = xlgasymornil();	/* TAA fix */
	xllastarg();
	return (sym != NIL && fboundp(sym) ? true : NIL);
}

/* xnull - is this null? */
LVAL xnull()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (null(arg) ? true : NIL);
}

/* xlistp - is this a list? */
LVAL xlistp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (listp(arg) ? true : NIL);
}

/* xendp - is this the end of a list? */
LVAL xendp()
{
	LVAL arg;
	arg = xlgalist();
	xllastarg();
	return (null(arg) ? true : NIL);
}

/* xconsp - is this a cons? */
LVAL xconsp()
{
	LVAL arg;
	arg = xlgetarg();
	xllastarg();
	return (consp(arg) ? true : NIL);
}

/* xeq - are these equal? */
LVAL xeq()
{
	LVAL arg1,arg2;

	/* get the two arguments */
	arg1 = xlgetarg();
	arg2 = xlgetarg();
	xllastarg();

	/* compare the arguments */
	return (arg1 == arg2 ? true : NIL);
}

/* xeql - are these equal? */
LVAL xeql()
{
	LVAL arg1,arg2;

	/* get the two arguments */
	arg1 = xlgetarg();
	arg2 = xlgetarg();
	xllastarg();

	/* compare the arguments */
	return (eql(arg1,arg2) ? true : NIL);
}

/* xequal - are these equal? (recursive) */
LVAL xequal()
{
	LVAL arg1,arg2;

	/* get the two arguments */
	arg1 = xlgetarg();
	arg2 = xlgetarg();
	xllastarg();

	/* compare the arguments */
	return (equal(arg1,arg2) ? true : NIL);
}

/* xset - built-in function set */
LVAL xset()
{
	LVAL sym,val;

	/* get the symbol and new value */
	sym = xlgasymbol();
	val = xlgetarg();
	xllastarg();

	/* assign the symbol the value of argument 2 and the return value */
	setvalue(sym,val);

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

/* xgensym - generate a symbol */
LVAL xgensym()
{
	char sym[STRMAX+11]; /* enough space for prefix and number */
	LVAL x;

	/* get the prefix or number */
	if (moreargs()) {
		x = xlgetarg();
		switch (null(x)? CONS : ntype(x)) { /* was ntype(x)	  TAA Mod */
		case SYMBOL:
				x = getpname(x);
		case STRING:
				strncpy(gsprefix,(char *)getstring(x),STRMAX);
				gsprefix[STRMAX] = '\0';
				break;
		case FIXNUM:
				gsnumber = getfixnum(x);
				break;
		default:
				xlbadtype(x);
		}
	}
	xllastarg();

	/* create the pname of the new symbol */
	sprintf(sym,"%s%d",gsprefix,gsnumber++);

	/* make a symbol with this print name */
	return (xlmakesym(sym));
}

/* xmakesymbol - make a new uninterned symbol */
LVAL xmakesymbol()
{
	return (makesymbol(FALSE));
}

/* xintern - make a new interned symbol */
LVAL xintern()
{
	return (makesymbol(TRUE));
}

/* makesymbol - make a new symbol */
LOCAL LVAL makesymbol(iflag)
  int iflag;
{
	LVAL pname;
		int i;


	/* get the print name of the symbol to intern */
	pname = xlgastring();
	xllastarg();
		
		/* check for making "NIL" -- very bad */
		if (strcmp((char *)getstring(pname),"NIL") == 0)
				xlerror("you've got to be kidding!",NIL);

		/* check for containing only printable characters */
		i = getslength(pname)-1;
		while (i-- > 0) if (pname->n_string[i] < 32 )
				xlerror("string contains non-printing characters",pname);
		

	/* make the symbol */
	return (iflag ? xlenter((char *)getstring(pname))
				  : xlmakesym((char *)getstring(pname)));
}

/* xsymname - get the print name of a symbol */
LVAL xsymname()
{
	LVAL sym;

	/* get the symbol */
	sym = xlgasymornil();	/* TAA fix */
	xllastarg();

	/* handle NIL, which is not internally represented as a symbol */
	if (sym == NIL) {
		sym = newstring(4);
		strcpy((char *)getstring(sym), "NIL");
		return sym;
	}

	/* return the print name */
	return (getpname(sym));
}

/* xsymvalue - get the value of a symbol */
LVAL xsymvalue()
{
	LVAL sym,val;

	/* get the symbol */
	sym = xlgasymornil();	/* TAA fix */
	xllastarg();

	/* handle NIL */
	if (sym == NIL) return (NIL);

	/* get the global value */
	while ((val = getvalue(sym)) == s_unbound)
		xlunbound(sym);

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

/* xsymfunction - get the functional value of a symbol */
LVAL xsymfunction()
{
	LVAL sym,val;

	/* get the symbol */
	sym = xlgasymornil();		/* TAA fix */
	xllastarg();

	/* handle NIL */
	if (sym == NIL) {
		while (1)
			xlfunbound(sym);
	}


	/* get the global value */
	while ((val = getfunction(sym)) == s_unbound)
		xlfunbound(sym);

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

/* xsymplist - get the property list of a symbol */
LVAL xsymplist()
{
	LVAL sym;

	/* get the symbol */
	sym = xlgasymornil();	/* TAA fix */
	xllastarg();

	/* return the property list */
	return (sym == NIL ? NIL : getplist(sym));
}

/* xget - get the value of a property */
LVAL xget()
{
	LVAL sym,prp;

	/* get the symbol and property */
	sym = xlgasymbol();
	prp = xlgasymbol();
	xllastarg();

	/* retrieve the property value */
	return (xlgetprop(sym,prp));
}

/* xputprop - set the value of a property */
LVAL xputprop()
{
	LVAL sym,val,prp;

	/* get the symbol and property */
	sym = xlgasymbol();
	val = xlgetarg();
	prp = xlgasymbol();
	xllastarg();

	/* set the property value */
	xlputprop(sym,val,prp);

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

/* xremprop - remove a property value from a property list */
LVAL xremprop()
{
	LVAL sym,prp;

	/* get the symbol and property */
	sym = xlgasymbol();
	prp = xlgasymbol();
	xllastarg();

	/* remove the property */
	xlremprop(sym,prp);

	/* return nil */
	return (NIL);
}

/* xhash - compute the hash value of a string or symbol */
LVAL xhash()
{
	char *str;
	LVAL len,val;
	int n;

	/* get the string and the table length */
	val = xlgetarg();
	len = xlgafixnum(); n = (int)getfixnum(len);
	xllastarg();

	/* get the string */
	if (symbolp(val))
				str = getstring(getpname(val));
	else if (stringp(val))
				str = getstring(val);
	else
				xlbadtype(val);


	/* return the hash index */
	return (cvfixnum((FIXTYPE)hash(str,n)));
}



/* xaref - array reference function */
LVAL xaref()
{
	LVAL array,index;
	FIXTYPE i;			/* TAA fix */

	/* get the array (may be a string) and the index */
#ifdef COMMONLISP		/* allows strings to work with AREF */
	array = xlgetarg();
#else
	array = xlgavector();
#endif
	index = xlgafixnum(); i = /*(int) */ getfixnum(index);		/* TAA fix */
	xllastarg();

#ifdef COMMONLISP
	if (stringp(array)) {	/* extension -- allow fetching chars from string*/
		if (i < 0 || i >= getslength(array)-1)
			xlerror("string index out of bounds",index);
		return (cvchar(getstringch(array,i)));
	}
		
	if (!vectorp(array)) xlbadtype(array);	/* type must be array */
#endif

	/* range check the index */
	if (i < 0 || i >= getsize(array))
		xlerror("array index out of bounds",index);

	/* return the array element */
	return (getelement(array,(int)i));	/* TAA fix -- casting */
}

/* xmkarray - make a new array */
LVAL xmkarray()
{
	LVAL size;
	int n;

	/* get the size of the array */
	size = xlgafixnum() ; n = (int)getfixnum(size);
	if ((n<0) || getfixnum(size) != (long)n)
		xlerror("bad array size",size);
	xllastarg();

	/* create the array */
	return (newvector(n));
}

/* xvector - make a vector */
LVAL xvector()
{
	LVAL val;
	int i;

	/* make the vector */
	val = newvector(xlargc);

	/* store each argument */
	for (i = 0; moreargs(); ++i)
		setelement(val,i,nextarg());
	xllastarg();

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

/* xerror - special form 'error' */
LVAL xerror()
{
	LVAL emsg,arg;

	/* get the error message and the argument */
	emsg = xlgastring();
	arg = (moreargs() ? xlgetarg() : s_unbound);
	xllastarg();

	/* signal the error */
	return (xlerror((char *)getstring(emsg),arg));
}

/* xcerror - special form 'cerror' */
LVAL xcerror()
{
	LVAL cmsg,emsg,arg;

	/* get the correction message, the error message, and the argument */
	cmsg = xlgastring();
	emsg = xlgastring();
	arg = (moreargs() ? xlgetarg() : s_unbound);
	xllastarg();

	/* signal the error */
	xlcerror(getstring(cmsg),getstring(emsg),arg);

	/* return nil */
	return (NIL);
}

/* xbreak - special form 'break' */
LVAL xbreak()
{
	LVAL emsg,arg;

	/* get the error message */
	emsg = (moreargs() ? xlgastring() : NIL);
	arg = (moreargs() ? xlgetarg() : s_unbound);
	xllastarg();

	/* enter the break loop */
	xlbreak((emsg ? getstring(emsg) : "**BREAK**"),arg);

	/* return nil */
	return (NIL);
}

/* xcleanup - special form 'clean-up' */
LVAL xcleanup()
{
	xllastarg();
	xlcleanup();
	return (NIL);
}

/* xtoplevel - special form 'top-level' */
LVAL xtoplevel()
{
	xllastarg();
	xltoplevel();
	return (NIL);
}

/* xcontinue - special form 'continue' */
LVAL xcontinue()
{
	xllastarg();
	xlcontinue();
	return (NIL);
}

/* xevalhook - eval hook function */
LVAL xevalhook()
{
	LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;

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

	/* get the expression, the new hook functions and the environment */
	expr = xlgetarg();
	newehook = xlgetarg();
	newahook = xlgetarg();
	newenv = (moreargs() ? xlgalist() : NIL);
	xllastarg();

	/* bind *evalhook* and *applyhook* to the hook functions */
	olddenv = xldenv;
	xldbind(s_evalhook,newehook);
	xldbind(s_applyhook,newahook);

	/* establish the environment for the hook function */
	if (newenv) {
		oldenv = xlenv;
		oldfenv = xlfenv;
		xlenv = car(newenv);
		xlfenv = cdr(newenv);
	}

	/* evaluate the expression (bypassing *evalhook*) */
	val = xlxeval(expr);

	/* restore the old environment */
	xlunbind(olddenv);
	if (newenv) {
		xlenv = oldenv;
		xlfenv = oldfenv;
	}

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

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

#ifdef APPLYHOOK
/* xapplyhook - apply hook function */
LVAL xapplyhook()
{
	LVAL fcn,args,newehook,newahook,olddenv,val;

	/* get the function, arguments, and the new hook functions */
	fcn = xlgetarg();
	args = xlgetarg();
	newehook = xlgetarg();
	newahook = xlgetarg();
	xllastarg();

	/* bind *evalhook* and *applyhook* to the hook functions */
	olddenv = xldenv;
	xldbind(s_evalhook,newehook);
	xldbind(s_applyhook,newahook);

	/* apply function (apply always bypasses hooks) */
	val = xlapply(pushargs(fcn,args));

	/* restore the old environment */
	xlunbind(olddenv);

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

#endif