/* xlbfun.c - xlisp basic builtin functions */

#ifdef AZTEC
#include "stdio.h"
#else
#include <stdio.h>
#endif

#include "xlisp.h"

/* external variables */
extern struct node *xlstack;
extern struct node *s_lambda,*s_nlambda,*s_unbound;

/* local variables */
static char gsprefix[STRMAX+1] = { 'G',0 };
static char gsnumber = 1;

/* forward declarations */
FORWARD struct node *defun();

/* xeval - the builtin function 'eval' */
struct node *xeval(args)
  struct node *args;
{
    struct node *oldstk,expr,*val;

    /* create a new stack frame */
    oldstk = xlsave(&expr,NULL);

    /* get the expression to evaluate */
    expr.n_ptr = xlarg(&args);
    xllastarg(args);

    /* evaluate the expression */
    val = xleval(expr.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression evaluated */
    return (val);
}

/* xapply - the builtin function 'apply' */
struct node *xapply(args)
  struct node *args;
{
    struct node *oldstk,fun,arglist,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fun,&arglist,NULL);

    /* get the function and argument list */
    fun.n_ptr = xlarg(&args);
    arglist.n_ptr = xlarg(&args);
    xllastarg(args);

    /* if the function is a symbol, get its value */
    if (fun.n_ptr && fun.n_ptr->n_type == SYM)
	fun.n_ptr = xleval(fun.n_ptr);

    /* apply the function to the arguments */
    val = xlapply(fun.n_ptr,arglist.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression evaluated */
    return (val);
}

/* xfuncall - the builtin function 'funcall' */
struct node *xfuncall(args)
  struct node *args;
{
    struct node *oldstk,fun,arglist,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fun,&arglist,NULL);

    /* get the function and argument list */
    fun.n_ptr = xlarg(&args);
    arglist.n_ptr = args;

    /* if the function is a symbol, get its value */
    if (fun.n_ptr && fun.n_ptr->n_type == SYM)
	fun.n_ptr = xleval(fun.n_ptr);

    /* apply the function to the arguments */
    val = xlapply(fun.n_ptr,arglist.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the expression evaluated */
    return (val);
}

/* xquote - builtin function to quote an expression */
struct node *xquote(args)
  struct node *args;
{
    /* make sure there is exactly one argument */
    if (args == NULL || args->n_listnext != NULL)
	xlfail("incorrect number of arguments");

    /* return the quoted expression */
    return (args->n_listvalue);
}

/* xset - builtin function set */
struct node *xset(args)
  struct node *args;
{
    struct node *sym,*val;

    /* get the symbol and new value */
    sym = xlmatch(SYM,&args);
    val = xlarg(&args);
    xllastarg(args);

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

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

/* xsetq - builtin function setq */
struct node *xsetq(args)
  struct node *args;
{
    struct node *oldstk,arg,sym,val;

    /* create a new stack frame */
    oldstk = xlsave(&arg,&sym,&val,NULL);

    /* initialize */
    arg.n_ptr = args;

    /* get the symbol and new value */
    sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
    val.n_ptr = xlevarg(&arg.n_ptr);
    xllastarg(arg.n_ptr);

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

    /* restore the previous stack frame */
    xlstack = oldstk;

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

/* xdefun - builtin function 'defun' */
struct node *xdefun(args)
  struct node *args;
{
    return (defun(args,s_lambda));
}

/* xndefun - builtin function 'ndefun' */
struct node *xndefun(args)
  struct node *args;
{
    return (defun(args,s_nlambda));
}

/* defun - internal function definition routine */
LOCAL struct node *defun(args,type)
  struct node *args,*type;
{
    struct node *oldstk,sym,fargs,fun;

    /* create a new stack frame */
    oldstk = xlsave(&sym,&fargs,&fun,NULL);

    /* get the function symbol and formal argument list */
    sym.n_ptr = xlmatch(SYM,&args);
    fargs.n_ptr = xlmatch(LIST,&args);

    /* create a new function definition */
    fun.n_ptr = newnode(LIST);
    fun.n_ptr->n_listvalue = type;
    fun.n_ptr->n_listnext = newnode(LIST);
    fun.n_ptr->n_listnext->n_listvalue = fargs.n_ptr;
    fun.n_ptr->n_listnext->n_listnext = args;

    /* make the symbol point to a new function definition */
    assign(sym.n_ptr,fun.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the function symbol */
    return (sym.n_ptr);
}

/* xgensym - generate a symbol */
struct node *xgensym(args)
  struct node *args;
{
    char sym[STRMAX+1];
    struct node *x;

    /* get the prefix or number */
    if (args) {
	x = xlarg(&args);
	switch (x->n_type) {
	case SYM:
		strcpy(gsprefix,xlsymname(x));
		break;
	case STR:
		strcpy(gsprefix,x->n_str);
		break;
	case INT:
		gsnumber = x->n_int;
		break;
	default:
		xlfail("bad argument type");
	}
    }
    xllastarg(args);

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

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

/* xintern - intern a symbol */
struct node *xintern(args)
  struct node *args;
{
    struct node *oldstk,sym;

    /* create a new stack frame */
    oldstk = xlsave(&sym,NULL);

    /* get the symbol to intern */
    sym.n_ptr = xlmatch(SYM,&args);
    xllastarg(args);

    /* intern the symbol */
    sym.n_ptr = xlintern(sym.n_ptr);

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the symbol */
    return (sym.n_ptr);
}

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

    /* get the symbol */
    sym = xlmatch(SYM,&args);
    xllastarg(args);

    /* return the print name */
    return (sym->n_symplist->n_listvalue);
}

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

    /* get the symbol */
    sym = xlmatch(SYM,&args);
    xllastarg(args);

    /* return the property list */
    return (sym->n_symplist->n_listnext);
}

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

    /* get the symbol and property */
    sym = xlmatch(SYM,&args);
    prp = xlmatch(SYM,&args);
    xllastarg(args);

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

/* xputprop - put a property value onto a property list */
struct node *xputprop(args)
  struct node *args;
{
    struct node *oldstk,sym,val,prp;

    /* create a new stack frame */
    oldstk = xlsave(&sym,&val,&prp,NULL);

    /* get the symbol, value and property */
    sym.n_ptr = xlmatch(SYM,&args);
    val.n_ptr = xlarg(&args);
    prp.n_ptr = xlmatch(SYM,&args);
    xllastarg(args);

    /* put the property onto the property list */
    xlputprop(sym.n_ptr,val.n_ptr,prp.n_ptr);

    /* restore the previouse stack frame */
    xlstack = oldstk;

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

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

    /* get the symbol and property */
    sym = xlmatch(SYM,&args);
    prp = xlmatch(SYM,&args);
    xllastarg(args);

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

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