/* 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 "flp1_xlisp_h"

/* external variables */
extern NODE *xlenv;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
extern NODE *s_lambda,*s_macro;
extern NODE *s_comma,*s_comat;
extern NODE *s_unbound;
extern char gsprefix[];
extern int gsnumber;

/* external routines */
extern NODE *xlxeval();

/* forward declarations */
FORWARD NODE *bquote1();
FORWARD NODE *defun();
FORWARD NODE *makesymbol();

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

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

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

/* xapply - the built-in function 'apply' */
NODE *xapply(args)
  NODE *args;
{
    NODE ***oldstk,*fun,*arglist,*val;

    /* create a new stack frame */
    oldstk = xlstack;
    xlsave1(fun);

    /* get the function and argument list */
    fun = xlarg(&args);
    arglist = xlmatch(LIST,&args);
    xllastarg(args);

    /* if the function is a symbol, get its value */
    if (symbolp(fun))
          fun = xleval(fun);

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

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

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

/* xfuncall - the built-in function 'funcall' */
NODE *xfuncall(args)
  NODE *args;
{
    NODE ***oldstk,*fun,*val;

    /* create a new stack frame */
    oldstk = xlstack;
    xlsave1(fun);

    /* get the function (the rest of the args is the argument list) */
    fun = xlarg(&args);

    /* if the function is a symbol, get its value */
    if (symbolp(fun))
          fun = xleval(fun);

    /* apply the function to the arguments */
    val = xlapply(fun,args);

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

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

/* xset - built-in function set */
NODE *xset(args)
  NODE *args;
{
    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 */
    setvalue(sym,val);

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

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

    /* get the prefix or number */
    if (args) {
          x = xlarg(&args);
          switch (ntype(x)) {
          case STR:
                    strcpy(gsprefix,getstring(x));
                    break;
          case INT:
                    gsnumber = getfixnum(x);
                    break;
          default:
                    xlerror("bad argument type",x);
          }
    }
    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));
}

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

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

/* makesymbol - make a new symbol */
LOCAL NODE *makesymbol(args,iflag)
  NODE *args; int iflag;
{
    char *pname;

    /* get the print name of the symbol to intern */
    pname = getstring(xlmatch(STR,&args));
    xllastarg(args);

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

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

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

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

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

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

    /* get the global value */
    while ((val = getvalue(sym)) == s_unbound)
          xlcerror("try evaluating symbol again","unbound variable",sym);

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

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

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

    /* return the property list */
    return (getplist(sym));
}

/* xget - get the value of a property */
NODE *xget(args)
  NODE *args;
{
    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 - set the value of a property */
NODE *xputprop(args)
  NODE *args;
{
    NODE *sym,*val,*prp;

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

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

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

/* xremprop - remove a property value from a property list */
NODE *xremprop(args)
  NODE *args;
{
    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 (NIL);
}

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

    /* get the string and the table length */
    val = xlarg(&args);
    len = (int)getfixnum(xlmatch(INT,&args));
    xllastarg(args);

    /* get the string */
    if (symbolp(val))
          str = getstring(getpname(val));
    else if (stringp(val))
          str = getstring(val);
    else
          xlerror("bad argument type",val);

    /* return the hash index */
    return (cvfixnum((FIXNUM)hash(str,len)));
}

/* xaref - array reference function */
NODE *xaref(args)
  NODE *args;
{
    NODE *array,*index;
    int i;

    /* get the array and the index */
    array = xlmatch(VECT,&args);
    index = xlmatch(INT,&args); i = (int)getfixnum(index);
    xllastarg(args);

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

    /* return the array element */
    return (getelement(array,i));
}

/* xmkarray - make a new array */
NODE *xmkarray(args)
  NODE *args;
{
    int size;

    /* get the size of the array */
    size = (int)getfixnum(xlmatch(INT,&args));
    xllastarg(args);

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

/* xerror - special form 'error' */
NODE *xerror(args)
  NODE *args;
{
    char *emsg; NODE *arg;

    /* get the error message and the argument */
    emsg = getstring(xlmatch(STR,&args));
    arg = (args ? xlarg(&args) : s_unbound);
    xllastarg(args);

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

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

    /* get the correction message, the error message, and the argument */
    cmsg = getstring(xlmatch(STR,&args));
    emsg = getstring(xlmatch(STR,&args));
    arg = (args ? xlarg(&args) : s_unbound);
    xllastarg(args);

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

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

/* xbreak - special form 'break' */
NODE *xbreak(args)
  NODE *args;
{
    char *emsg; NODE *arg;

    /* get the error message */
    emsg = (args ? getstring(xlmatch(STR,&args)) : "**BREAK**");
    arg = (args ? xlarg(&args) : s_unbound);
    xllastarg(args);

    /* enter the break loop */
    xlbreak(emsg,arg);

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

/* xcleanup - special form 'clean-up' */
NODE *xcleanup(args)
  NODE *args;
{
    xllastarg(args);
    xlcleanup();
}

/* xtoplevel - special form 'top-level' */
NODE *xtoplevel(args)
  NODE *args;
{
    xllastarg(args);
    xltoplevel();
}

/* xcontinue - special form 'continue' */
NODE *xcontinue(args)
  NODE *args;
{
    xllastarg(args);
    xlcontinue();
}

/* xevalhook - eval hook function */
NODE *xevalhook(args)
  NODE *args;
{
    NODE ***oldstk,*expr,*ehook,*ahook,*oldenv;
    NODE *newehook,*newahook,*newenv,*val;

    /* create a new stack frame */
    oldstk = xlstack;
    xlstkcheck(4);
    xlsave(ehook);
    xlsave(ahook);
    xlsave(oldenv);
    xlsave(newenv);

    /* get the expression, the new hook functions and the environment */
    expr = xlarg(&args);
    newehook = xlarg(&args);
    newahook = xlarg(&args);
    newenv = (args ? xlarg(&args) : xlenv);
    xllastarg(args);

    /* bind *evalhook* and *applyhook* to the hook functions */
    ehook = getvalue(s_evalhook);
    setvalue(s_evalhook,newehook);
    ahook = getvalue(s_applyhook);
    setvalue(s_applyhook,newahook);
    oldenv = xlenv;
    xlenv = newenv;

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

    /* unbind the hook variables */
    setvalue(s_evalhook,ehook);
    setvalue(s_applyhook,ahook);
    xlenv = oldenv;

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

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