/* xlcont - xlisp special forms */
/*        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,*xlvalue;
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 *true;

/* forward declarations */
FORWARD NODE *bquote1();
FORWARD NODE *defun();
FORWARD NODE *let();
FORWARD NODE *prog();
FORWARD NODE *progx();
FORWARD NODE *doloop();

/* xquote - special form 'quote' */
NODE *xquote(args)
  NODE *args;
{
    if (atom(args))
          xlfail("too few arguments");
    else if (cdr(args) != NIL)
          xlfail("too many arguments");
    return (car(args));
}

/* xfunction - special form 'function' */
NODE *xfunction(args)
  NODE *args;
{
    NODE *val;

    /* get the argument */
    val = xlarg(&args);
    xllastarg(args);

    /* create a closure for lambda expressions */
    if (consp(val) && car(val) == s_lambda)
          val = cons(val,xlenv);

    /* otherwise, get the value of a symbol */
    else if (symbolp(val))
          val = xlgetvalue(val);

    /* otherwise, its an error */
    else
          xlerror("not a function",val);

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

/* xlambda - special form 'lambda' */
NODE *xlambda(args)
  NODE *args;
{
    NODE *fargs;

    /* get the formal argument list */
    fargs = xlmatch(LIST,&args);

    /* create a new function definition */
    return (cons(cons(s_lambda,cons(fargs,args)),xlenv));
}

/* xbquote - back quote special form */
NODE *xbquote(args)
  NODE *args;
{
    NODE *expr;

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

    /* fill in the template */
    return (bquote1(expr));
}

/* bquote1 - back quote helper function */
LOCAL NODE *bquote1(expr)
  NODE *expr;
{
    NODE ***oldstk,*val,*list,*last,*new;

    /* handle atoms */
    if (atom(expr))
          val = expr;

    /* handle (comma <expr>) */
    else if (car(expr) == s_comma) {
          if (atom(cdr(expr)))
              xlfail("bad comma expression");
          val = xleval(car(cdr(expr)));
    }

    /* handle ((comma-at <expr>) ... ) */
    else if (consp(car(expr)) && car(car(expr)) == s_comat) {
          oldstk = xlstack;
          xlstkcheck(2);
          xlsave(list);
          xlsave(val);
          if (atom(cdr(car(expr))))
              xlfail("bad comma-at expression");
          list = xleval(car(cdr(car(expr))));
          for (last = NIL; consp(list); list = cdr(list)) {
              new = consa(car(list));
              if (last)
                    rplacd(last,new);
              else
                    val = new;
              last = new;
          }
          if (last)
              rplacd(last,bquote1(cdr(expr)));
          else
              val = bquote1(cdr(expr));
          xlstack = oldstk;
    }

    /* handle any other list */
    else {
          oldstk = xlstack;
          xlsave1(val);
          val = consa(NIL);
          rplaca(val,bquote1(car(expr)));
          rplacd(val,bquote1(cdr(expr)));
          xlstack = oldstk;
    }

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

/* xsetq - special form 'setq' */
NODE *xsetq(args)
  NODE *args;
{
    NODE *sym,*val;

    /* handle each pair of arguments */
    for (val = NIL; args; ) {
          sym = xlmatch(SYM,&args);
          val = xlevarg(&args);
          xlsetvalue(sym,val);
    }

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

/* xsetf - special form 'setf' */
NODE *xsetf(args)
  NODE *args;
{
    NODE ***oldstk,*place,*value;

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

    /* handle each pair of arguments */
    while (args) {

          /* get place and value */
          place = xlarg(&args);
          value = xlevarg(&args);

          /* check the place form */
          if (symbolp(place))
              xlsetvalue(place,value);
          else if (consp(place))
              placeform(place,value);
          else
              xlfail("bad place form");
    }

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

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

/* placeform - handle a place form other than a symbol */
LOCAL placeform(place,value)
  NODE *place,*value;
{
    NODE ***oldstk,*fun,*arg1,*arg2;
    int i;

    /* check the function name */
    if ((fun = xlmatch(SYM,&place)) == s_get) {
          oldstk = xlstack;
          xlstkcheck(2);
          xlsave(arg1);
          xlsave(arg2);
          arg1 = xlevmatch(SYM,&place);
          arg2 = xlevmatch(SYM,&place);
          xllastarg(place);
          xlputprop(arg1,value,arg2);
          xlstack = oldstk;
    }
    else if (fun == s_svalue) {
          oldstk = xlstack;
          xlsave1(arg1);
          arg1 = xlevmatch(SYM,&place);
          xllastarg(place);
          setvalue(arg1,value);
          xlstack = oldstk;
    }
    else if (fun == s_splist) {
          oldstk = xlstack;
          xlsave1(arg1);
          arg1 = xlevmatch(SYM,&place);
          xllastarg(place);
          setplist(arg1,value);
          xlstack = oldstk;
    }
    else if (fun == s_car) {
          oldstk = xlstack;
          xlsave1(arg1);
          if ((arg1 = xlevmatch(LIST,&place)) == NIL)
              xlerror("bad argument type",arg1);
          xllastarg(place);
          rplaca(arg1,value);
          xlstack = oldstk;
    }
    else if (fun == s_cdr) {
          oldstk = xlstack;
          xlsave1(arg1);
          if ((arg1 = xlevmatch(LIST,&place)) == NIL)
              xlerror("bad argument type",arg1);
          xllastarg(place);
          rplacd(arg1,value);
          xlstack = oldstk;
    }
    else if (fun == s_nth) {
          oldstk = xlstack;
          xlstkcheck(2);
          xlsave(arg1);
          xlsave(arg2);
          arg1 = xlevmatch(INT,&place);
          arg2 = xlevmatch(LIST,&place);
          xllastarg(place);
          for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
              arg2 = cdr(arg2);
          if (consp(arg2))
              rplaca(arg2,value);
          xlstack = oldstk;
    }

    else if (fun == s_aref) {
          oldstk = xlstack;
          xlstkcheck(2);
          xlsave(arg1);
          xlsave(arg2);
          arg1 = xlevmatch(VECT,&place);
          arg2 = xlevmatch(INT,&place); i = (int)getfixnum(arg2);
          xllastarg(place);
          if (i < 0 || i >= getsize(arg1))
              xlerror("index out of range",arg2);
          setelement(arg1,i,value);
          xlstack = oldstk;
    }
    else
          xlfail("bad place form");
}

/* xdefun - special form 'defun' */
NODE *xdefun(args)
  NODE *args;
{
    return (defun(args,s_lambda));
}

/* xdefmacro - special form 'defmacro' */
NODE *xdefmacro(args)
  NODE *args;
{
    return (defun(args,s_macro));
}

/* defun - internal function definition routine */
LOCAL NODE *defun(args,type)
  NODE *args,*type;
{
    NODE *sym,*fargs;

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

    /* make the symbol point to a new function definition */
    xlsetvalue(sym,cons(cons(type,cons(fargs,args)),xlenv));

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

/* xcond - special form 'cond' */
NODE *xcond(args)
  NODE *args;
{
    NODE *list,*val;

    /* find a predicate that is true */
    for (val = NIL; consp(args); args = cdr(args)) {

          /* get the next conditional */
          list = car(args);

          /* evaluate the predicate part */
          if (consp(list) && (val = xleval(car(list)))) {

              /* evaluate each expression */
              for (list = cdr(list); consp(list); list = cdr(list))
                    val = xleval(car(list));

              /* exit the loop */
              break;
          }
    }

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

/* xcase - special form 'case' */
NODE *xcase(args)
  NODE *args;
{
    NODE ***oldstk,*key,*list,*cases,*val;

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

    /* get the key expression */
    key = xlevarg(&args);

    /* find a case that matches */
    for (val = NIL; consp(args); args = cdr(args)) {

          /* get the next case clause */
          list = car(args);

          /* make sure this is a valid clause */
          if (consp(list)) {

              /* compare the key list against the key */
              if ((cases = car(list)) == true ||
                (listp(cases) && keypresent(key,cases)) ||
                eql(key,cases)) {

                    /* evaluate each expression */
                    for (list = cdr(list); consp(list); list = cdr(list))
                        val = xleval(car(list));

                    /* exit the loop */
                    break;
              }
          }
          else
              xlerror("bad case clause",list);
    }

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

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

/* keypresent - check for the presence of a key in a list */
LOCAL int keypresent(key,list)
  NODE *key,*list;
{
    for (; consp(list); list = cdr(list))
          if (eql(car(list),key))
              return (TRUE);
    return (FALSE);
}

/* xand - special form 'and' */
NODE *xand(args)
  NODE *args;
{
    NODE *val;

    /* evaluate each argument */
    for (val = true; consp(args); args = cdr(args))
          if ((val = xleval(car(args))) == NIL)
              break;

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

/* xor - special form 'or' */
NODE *xor(args)
  NODE *args;
{
    NODE *val;

    /* evaluate each argument */
    for (val = NIL; consp(args); args = cdr(args))
          if ((val = xleval(car(args))))
              break;

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

/* xif - special form 'if' */
NODE *xif(args)
  NODE *args;
{
    NODE *testexpr,*thenexpr,*elseexpr;

    /* get the test expression, then clause and else clause */
    testexpr = xlarg(&args);
    thenexpr = xlarg(&args);
    elseexpr = (args ? xlarg(&args) : NIL);
    xllastarg(args);

    /* evaluate the appropriate clause */
    return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
}

/* xlet - special form 'let' */
NODE *xlet(args)
  NODE *args;
{
    return (let(args,TRUE));
}

/* xletstar - special form 'let*' */
NODE *xletstar(args)
  NODE *args;
{
    return (let(args,FALSE));
}

/* let - common let routine */
LOCAL NODE *let(args,pflag)
  NODE *args; int pflag;
{
    NODE ***oldstk,*newenv,*val;

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

    /* create a new environment frame */
    newenv = xlframe(xlenv);

    /* get the list of bindings and bind the symbols */
    if (!pflag) xlenv = newenv;
    dobindings(xlmatch(LIST,&args),newenv);
    if (pflag) xlenv = newenv;

    /* execute the code */
    for (val = NIL; consp(args); args = cdr(args))
          val = xleval(car(args));

    /* unbind the arguments */
    xlenv = cdr(xlenv);

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

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

/* xprog - special form 'prog' */
NODE *xprog(args)
  NODE *args;
{
    return (prog(args,TRUE));
}

/* xprogstar - special form 'prog*' */
NODE *xprogstar(args)
  NODE *args;
{
    return (prog(args,FALSE));
}

/* prog - common prog routine */
LOCAL NODE *prog(args,pflag)
  NODE *args; int pflag;
{
    NODE ***oldstk,*newenv,*val;

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

    /* create a new environment frame */
    newenv = xlframe(xlenv);

    /* get the list of bindings and bind the symbols */
    if (!pflag) xlenv = newenv;
    dobindings(xlmatch(LIST,&args),newenv);
    if (pflag) xlenv = newenv;

    /* execute the code */
    tagblock(args,&val);

    /* unbind the arguments */
    xlenv = cdr(xlenv);

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

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

/* xgo - special form 'go' */
NODE *xgo(args)
  NODE *args;
{
    NODE *label;

    /* get the target label */
    label = xlarg(&args);
    xllastarg(args);

    /* transfer to the label */
    xlgo(label);
}

/* xreturn - special form 'return' */
NODE *xreturn(args)
  NODE *args;
{
    NODE *val;

    /* get the return value */
    val = (args ? xlevarg(&args) : NIL);
    xllastarg(args);

    /* return from the inner most block */
    xlreturn(val);
}

/* xprog1 - special form 'prog1' */
NODE *xprog1(args)
  NODE *args;
{
    return (progx(args,1));
}

/* xprog2 - special form 'prog2' */
NODE *xprog2(args)
  NODE *args;
{
    return (progx(args,2));
}

/* progx - common progx code */
LOCAL NODE *progx(args,n)
  NODE *args; int n;
{
    NODE ***oldstk,*val;

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

    /* evaluate the first n expressions */
    for (; consp(args) && --n >= 0; args = cdr(args))
          val = xleval(car(args));

    /* evaluate each remaining argument */
    for (; consp(args); args = cdr(args))
          xleval(car(args));

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

    /* return the last test expression value */
    return (val);
}

/* xprogn - special form 'progn' */
NODE *xprogn(args)
  NODE *args;
{
    NODE *val;

    /* evaluate each expression */
    for (val = NIL; consp(args); args = cdr(args))
          val = xleval(car(args));

    /* return the last test expression value */
    return (val);
}

/* xdo - special form 'do' */
NODE *xdo(args)
  NODE *args;
{
    return (doloop(args,TRUE));
}

/* xdostar - special form 'do*' */
NODE *xdostar(args)
  NODE *args;
{
    return (doloop(args,FALSE));
}

/* doloop - common do routine */
LOCAL NODE *doloop(args,pflag)
  NODE *args; int pflag;
{
    NODE ***oldstk,*newenv,*blist,*clist,*test,*rval;
    int rbreak;

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

    /* get the list of bindings, the exit test and the result forms */
    blist = xlmatch(LIST,&args);
    clist = xlmatch(LIST,&args);
    test = (consp(clist) ? car(clist) : NIL);

    /* create a new environment frame */
    newenv = xlframe(xlenv);

    /* bind the symbols */
    if (!pflag) xlenv = newenv;
    dobindings(blist,newenv);
    if (pflag) xlenv = newenv;

    /* execute the loop as long as the test is false */
    for (rbreak = FALSE; xleval(test) == NIL; doupdates(blist,pflag))
          if (tagblock(args,&rval)) {
              rbreak = TRUE;
              break;
          }

    /* evaluate the result expression */
    if (!rbreak && consp(clist))
        for (rval = NIL, clist = cdr(clist); consp(clist); clist = cdr(clist))
              rval = xleval(car(clist));

    /* unbind the arguments */
    xlenv = cdr(xlenv);

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

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

/* xdolist - special form 'dolist' */
NODE *xdolist(args)
  NODE *args;
{
    NODE ***oldstk,*clist,*sym,*list,*rval;
    int rbreak;

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

    /* get the control list (sym list result-expr) */
    clist = xlmatch(LIST,&args);
    sym = xlmatch(SYM,&clist);
    list = xlevmatch(LIST,&clist);

    /* initialize the local environment */
    xlenv = xlframe(xlenv);
    xlbind(sym,NIL,xlenv);

    /* loop through the list */
    for (rbreak = FALSE; consp(list); list = cdr(list)) {

          /* bind the symbol to the next list element */
          xlsetvalue(sym,car(list));

          /* execute the loop body */
          if (tagblock(args,&rval)) {
              rbreak = TRUE;
              break;
          }
    }

    /* evaluate the result expression */
    if (!rbreak) {
          xlsetvalue(sym,NIL);
          rval = (consp(clist) ? xleval(car(clist)) : NIL);
    }

    /* unbind the arguments */
    xlenv = cdr(xlenv);

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

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

/* xdotimes - special form 'dotimes' */
NODE *xdotimes(args)
  NODE *args;
{
    NODE *clist,*sym,*rval;
    int rbreak,cnt,i;

    /* get the control list (sym list result-expr) */
    clist = xlmatch(LIST,&args);
    sym = xlmatch(SYM,&clist);
    cnt = getfixnum(xlevmatch(INT,&clist));

    /* initialize the local environment */
    xlenv = xlframe(xlenv);
    xlbind(sym,NIL,xlenv);

    /* loop through for each value from zero to cnt-1 */
    for (rbreak = FALSE, i = 0; i < cnt; ++i) {

          /* bind the symbol to the next list element */
          xlsetvalue(sym,cvfixnum((FIXNUM)i));

          /* execute the loop body */
          if (tagblock(args,&rval)) {
              rbreak = TRUE;
              break;
          }
    }

    /* evaluate the result expression */
    if (!rbreak) {
          xlsetvalue(sym,cvfixnum((FIXNUM)cnt));
          rval = (consp(clist) ? xleval(car(clist)) : NIL);
    }

    /* unbind the arguments */
    xlenv = cdr(xlenv);

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

/* xcatch - special form 'catch' */
NODE *xcatch(args)
  NODE *args;
{
    NODE ***oldstk,*tag,*val;
    CONTEXT cntxt;

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

    /* get the tag */
    tag = xlevarg(&args);

    /* establish an execution context */
    xlbegin(&cntxt,CF_THROW,tag);

    /* check for 'throw' */
    if (setjmp(cntxt.c_jmpbuf))
          val = xlvalue;

    /* otherwise, evaluate the remainder of the arguments */
    else {
          for (val = NIL; consp(args); args = cdr(args))
              val = xleval(car(args));
    }
    xlend(&cntxt);

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

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

/* xthrow - special form 'throw' */
NODE *xthrow(args)
  NODE *args;
{
    NODE *tag,*val;

    /* get the tag and value */
    tag = xlevarg(&args);
    val = (args ? xlevarg(&args) : NIL);
    xllastarg(args);

    /* throw the tag */
    xlthrow(tag,val);
}

/* xerrset - special form 'errset' */
NODE *xerrset(args)
  NODE *args;
{
    NODE *expr,*flag,*val;
    CONTEXT cntxt;

    /* get the expression and the print flag */
    expr = xlarg(&args);
    flag = (args ? xlarg(&args) : true);
    xllastarg(args);

    /* establish an execution context */
    xlbegin(&cntxt,CF_ERROR,flag);

    /* check for error */
    if (setjmp(cntxt.c_jmpbuf))
          val = NIL;

    /* otherwise, evaluate the expression */
    else {
          expr = xleval(expr);
          val = consa(expr);
    }
    xlend(&cntxt);

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

/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
LOCAL dobindings(list,env)
  NODE *list,*env;
{
    NODE ***oldstk,*bnd,*sym,*val;

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

    /* bind each symbol in the list of bindings */
    for (; consp(list); list = cdr(list)) {

          /* get the next binding */
          bnd = car(list);

          /* handle a symbol */
          if (symbolp(bnd)) {
              sym = bnd;
              val = NIL;
          }

          /* handle a list of the form (symbol expr) */
          else if (consp(bnd)) {
              sym = xlmatch(SYM,&bnd);
              val = xlevarg(&bnd);
          }
          else
              xlfail("bad binding");

          /* bind the value to the symbol */
          xlbind(sym,val,env);
    }

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

/* doupdates - handle updates for do/do* */
doupdates(list,pflag)
  NODE *list; int pflag;
{
    NODE ***oldstk,*plist,*bnd,*sym,*val;

    /* create a new stack frame */
    oldstk = xlstack;
    xlstkcheck(2);
    xlsave(plist);
    xlsave(val);

    /* bind each symbol in the list of bindings */
    for (; consp(list); list = cdr(list)) {

          /* get the next binding */
          bnd = car(list);

          /* handle a list of the form (symbol expr) */
          if (consp(bnd)) {
              sym = xlmatch(SYM,&bnd);
              bnd = cdr(bnd);
              if (bnd) {
                    val = xlevarg(&bnd);
                    if (pflag)
                        plist = cons(cons(sym,val),plist);
                    else
                        xlsetvalue(sym,val);
              }
          }
    }

    /* set the values for parallel updates */
    for (; plist; plist = cdr(plist))
          xlsetvalue(car(car(plist)),cdr(car(plist)));

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

/* tagblock - execute code within a block and tagbody */
int tagblock(code,pval)
  NODE *code,**pval;
{
    CONTEXT cntxt;
    int type,sts;

    /* establish an execution context */
    xlbegin(&cntxt,CF_GO|CF_RETURN,code);

    /* check for a 'return' */
    if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
          *pval = xlvalue;
          sts = TRUE;
    }

    /* otherwise, enter the body */
    else {

          /* check for a 'go' */
          if (type == CF_GO)
              code = xlvalue;

          /* evaluate each expression in the body */
          for (; consp(code); code = cdr(code))
              if (consp(car(code)))
                    xleval(car(code));

          /* fell out the bottom of the loop */
          *pval = NIL;
          sts = FALSE;
    }
    xlend(&cntxt);

    /* return status */
    return (sts);
}