/* xllist.c - xlisp built-in list functions */
/*        Copyright (c) 1985, by David Michael Betz
          All Rights Reserved
          Permission is granted for unrestricted non-commercial use   */

#include "flp1_xlisp_h"

#ifdef MEGAMAX
overlay "overflow"
#endif

/* external variables */
extern NODE *s_unbound;
extern NODE *true;

/* forward declarations */
FORWARD NODE *cxr();
FORWARD NODE *nth(),*assoc();
FORWARD NODE *subst(),*sublis(),*map();

/* xcar - take the car of a cons cell */
NODE *xcar(args)
  NODE *args;
{
    NODE *list;
    list = xlmatch(LIST,&args);
    xllastarg(args);
    return (list ? car(list) : NIL);
}

/* xcdr - take the cdr of a cons cell */
NODE *xcdr(args)
  NODE *args;
{
    NODE *list;
    list = xlmatch(LIST,&args);
    xllastarg(args);
    return (list ? cdr(list) : NIL);
}

/* cxxr functions */
NODE *xcaar(args) NODE *args; { return (cxr(args,"aa")); }
NODE *xcadr(args) NODE *args; { return (cxr(args,"da")); }
NODE *xcdar(args) NODE *args; { return (cxr(args,"ad")); }
NODE *xcddr(args) NODE *args; { return (cxr(args,"dd")); }

/* cxxxr functions */
NODE *xcaaar(args) NODE *args; { return (cxr(args,"aaa")); }
NODE *xcaadr(args) NODE *args; { return (cxr(args,"daa")); }
NODE *xcadar(args) NODE *args; { return (cxr(args,"ada")); }
NODE *xcaddr(args) NODE *args; { return (cxr(args,"dda")); }
NODE *xcdaar(args) NODE *args; { return (cxr(args,"aad")); }
NODE *xcdadr(args) NODE *args; { return (cxr(args,"dad")); }
NODE *xcddar(args) NODE *args; { return (cxr(args,"add")); }
NODE *xcdddr(args) NODE *args; { return (cxr(args,"ddd")); }

/* cxxxxr functions */
NODE *xcaaaar(args) NODE *args; { return (cxr(args,"aaaa")); }
NODE *xcaaadr(args) NODE *args; { return (cxr(args,"daaa")); }
NODE *xcaadar(args) NODE *args; { return (cxr(args,"adaa")); }
NODE *xcaaddr(args) NODE *args; { return (cxr(args,"ddaa")); }
NODE *xcadaar(args) NODE *args; { return (cxr(args,"aada")); }
NODE *xcadadr(args) NODE *args; { return (cxr(args,"dada")); }
NODE *xcaddar(args) NODE *args; { return (cxr(args,"adda")); }
NODE *xcadddr(args) NODE *args; { return (cxr(args,"ddda")); }
NODE *xcdaaar(args) NODE *args; { return (cxr(args,"aaad")); }
NODE *xcdaadr(args) NODE *args; { return (cxr(args,"daad")); }
NODE *xcdadar(args) NODE *args; { return (cxr(args,"adad")); }
NODE *xcdaddr(args) NODE *args; { return (cxr(args,"ddad")); }
NODE *xcddaar(args) NODE *args; { return (cxr(args,"aadd")); }
NODE *xcddadr(args) NODE *args; { return (cxr(args,"dadd")); }
NODE *xcdddar(args) NODE *args; { return (cxr(args,"addd")); }
NODE *xcddddr(args) NODE *args; { return (cxr(args,"dddd")); }

/* cxr - common car/cdr routine */
LOCAL NODE *cxr(args,adstr)
  NODE *args; char *adstr;
{
    NODE *list;

    /* get the list */
    list = xlmatch(LIST,&args);
    xllastarg(args);

    /* perform the car/cdr operations */
    while (*adstr && consp(list))
          list = (*adstr++ == 'a' ? car(list) : cdr(list));

    /* make sure the operation succeeded */
    if (*adstr && list)
          xlfail("bad argument");

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

/* xcons - construct a new list cell */
NODE *xcons(args)
  NODE *args;
{
    NODE *arg1,*arg2;

    /* get the two arguments */
    arg1 = xlarg(&args);
    arg2 = xlarg(&args);
    xllastarg(args);

    /* construct a new list element */
    return (cons(arg1,arg2));
}

/* xlist - built a list of the arguments */
NODE *xlist(args)
  NODE *args;
{
    NODE ***oldstk,*last,*next,*val;

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

    /* add each argument to the list */
    for (val = NIL; consp(args); args = cdr(args)) {

          /* append this argument to the end of the list */
          next = consa(car(args));
          if (val) rplacd(last,next);
          else val = next;
          last = next;
    }

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

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

/* xappend - built-in function append */
NODE *xappend(args)
  NODE *args;
{
    NODE ***oldstk,*list,*last,*next,*val;

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

    /* append each argument */
    for (val = NIL; consp(args); args = cdr(args)) {

          /* append each element of this list to the result list */
          for (list = car(args); consp(list); list = cdr(list)) {

              /* append this element */
              next = consa(car(list));
              if (val) rplacd(last,next);
              else val = next;
              last = next;
          }
    }

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

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

/* xreverse - built-in function reverse */
NODE *xreverse(args)
  NODE *args;
{
    NODE ***oldstk,*list,*val;

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

    /* get the list to reverse */
    list = xlmatch(LIST,&args);
    xllastarg(args);

    /* append each element to the head of the result list */
    for (val = NIL; consp(list); list = cdr(list))
          val = cons(car(list),val);

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

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

/* xlast - return the last cons of a list */
NODE *xlast(args)
  NODE *args;
{
    NODE *list;

    /* get the list */
    list = xlmatch(LIST,&args);
    xllastarg(args);

    /* find the last cons */
    while (consp(list) && cdr(list))
          list = cdr(list);

    /* return the last element */
    return (list);
}

/* xmember - built-in function 'member' */
NODE *xmember(args)
  NODE *args;
{
    NODE ***oldstk,*x,*list,*fcn,*val;
    int tresult;

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

    /* get the expression to look for and the list */
    x = xlarg(&args);
    list = xlmatch(LIST,&args);
    xltest(&fcn,&tresult,&args);
    xllastarg(args);

    /* look for the expression */
    for (val = NIL; consp(list); list = cdr(list))
          if (dotest(x,car(list),fcn) == tresult) {
              val = list;
              break;
          }

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

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

/* xassoc - built-in function 'assoc' */
NODE *xassoc(args)
  NODE *args;
{
    NODE ***oldstk,*x,*alist,*fcn,*pair,*val;
    int tresult;

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

    /* get the expression to look for and the association list */
    x = xlarg(&args);
    alist = xlmatch(LIST,&args);
    xltest(&fcn,&tresult,&args);
    xllastarg(args);

    /* look for the expression */
    for (val = NIL; consp(alist); alist = cdr(alist))
          if ((pair = car(alist)) && consp(pair))
              if (dotest(x,car(pair),fcn) == tresult) {
                    val = pair;
                    break;
              }

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

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

/* xsubst - substitute one expression for another */
NODE *xsubst(args)
  NODE *args;
{
    NODE ***oldstk,*to,*from,*expr,*fcn,*val;
    int tresult;

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

    /* get the to value, the from value and the expression */
    to = xlarg(&args);
    from = xlarg(&args);
    expr = xlarg(&args);
    xltest(&fcn,&tresult,&args);
    xllastarg(args);

    /* do the substitution */
    val = subst(to,from,expr,fcn,tresult);

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

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

/* subst - substitute one expression for another */
LOCAL NODE *subst(to,from,expr,fcn,tresult)
  NODE *to,*from,*expr,*fcn; int tresult;
{
    NODE ***oldstk,*carval,*cdrval;

    if (dotest(expr,from,fcn) == tresult)
          return (to);
    else if (consp(expr)) {
          oldstk = xlstack;
          xlsave1(carval);
          carval = subst(to,from,car(expr),fcn,tresult);
          cdrval = subst(to,from,cdr(expr),fcn,tresult);
          xlstack = oldstk;
          return (cons(carval,cdrval));
    }
    else
          return (expr);
}

/* xsublis - substitute using an association list */
NODE *xsublis(args)
  NODE *args;
{
    NODE ***oldstk,*alist,*expr,*fcn,*val;
    int tresult;

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

    /* get the assocation list and the expression */
    alist = xlmatch(LIST,&args);
    expr = xlarg(&args);
    xltest(&fcn,&tresult,&args);
    xllastarg(args);

    /* do the substitution */
    val = sublis(alist,expr,fcn,tresult);

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

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

/* sublis - substitute using an association list */
LOCAL NODE *sublis(alist,expr,fcn,tresult)
  NODE *alist,*expr,*fcn; int tresult;
{
    NODE ***oldstk,*carval,*cdrval,*pair;

    if (pair = assoc(expr,alist,fcn,tresult))
          return (cdr(pair));
    else if (consp(expr)) {
          oldstk = xlstack;
          xlsave1(carval);
          carval = sublis(alist,car(expr),fcn,tresult);
          cdrval = sublis(alist,cdr(expr),fcn,tresult);
          xlstack = oldstk;
          return (cons(carval,cdrval));
    }
    else
          return (expr);
}

/* assoc - find a pair in an association list */
LOCAL NODE *assoc(expr,alist,fcn,tresult)
  NODE *expr,*alist,*fcn; int tresult;
{
    NODE *pair;

    for (; consp(alist); alist = cdr(alist))
          if ((pair = car(alist)) && consp(pair))
              if (dotest(expr,car(pair),fcn) == tresult)
                    return (pair);
    return (NIL);
}

/* xremove - built-in function 'remove' */
NODE *xremove(args)
  NODE *args;
{
    NODE ***oldstk,*x,*list,*fcn,*val,*last,*next;
    int tresult;

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

    /* get the expression to remove and the list */
    x = xlarg(&args);
    list = xlmatch(LIST,&args);
    xltest(&fcn,&tresult,&args);
    xllastarg(args);

    /* remove matches */
    for (; consp(list); list = cdr(list))

          /* check to see if this element should be deleted */
          if (dotest(x,car(list),fcn) != tresult) {
              next = consa(car(list));
              if (val) rplacd(last,next);
              else val = next;
              last = next;
          }

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

    /* return the updated list */
    return (val);
}

/* dotest - call a test function */
int dotest(arg1,arg2,fcn)
  NODE *arg1,*arg2,*fcn;
{
    NODE ***oldstk,*args,*val;

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

    /* build an argument list */
    args = cons(arg1,consa(arg2));

    /* apply the test function */
    val = xlapply(fcn,args);

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

    /* return the result of the test */
    return (val != NIL);
}

/* xnth - return the nth element of a list */
NODE *xnth(args)
  NODE *args;
{
    return (nth(args,TRUE));
}

/* xnthcdr - return the nth cdr of a list */
NODE *xnthcdr(args)
  NODE *args;
{
    return (nth(args,FALSE));
}

/* nth - internal nth function */
LOCAL NODE *nth(args,carflag)
  NODE *args; int carflag;
{
    NODE *list;
    FIXNUM n;

    /* get n and the list */
    if ((n = getfixnum(xlmatch(INT,&args))) < 0)
          xlfail("bad argument");
    if ((list = xlmatch(LIST,&args)) == NIL)
          xlfail("bad argument");
    xllastarg(args);

    /* find the nth element */
    while (consp(list) && --n >= 0)
          list = cdr(list);

    /* return the list beginning at the nth element */
    return (carflag && consp(list) ? car(list) : list);
}

/* xlength - return the length of a list or string */
NODE *xlength(args)
  NODE *args;
{
    NODE *arg;
    FIXNUM n;

    /* get the list or string */
    arg = xlarg(&args);
    xllastarg(args);

    /* find the length of a list */
    if (listp(arg))
          for (n = 0; consp(arg); n++)
              arg = cdr(arg);

    /* find the length of a string */
    else if (stringp(arg))
          n = strlen(getstring(arg));

    /* find the length of a vector */
    else if (vectorp(arg))
          n = getsize(arg);

    /* otherwise, bad argument type */
    else
          xlerror("bad argument type",arg);

    /* return the length */
    return (cvfixnum(n));
}

/* xmapc - built-in function 'mapc' */
NODE *xmapc(args)
  NODE *args;
{
    return (map(args,TRUE,FALSE));
}

/* xmapcar - built-in function 'mapcar' */
NODE *xmapcar(args)
  NODE *args;
{
    return (map(args,TRUE,TRUE));
}

/* xmapl - built-in function 'mapl' */
NODE *xmapl(args)
  NODE *args;
{
    return (map(args,FALSE,FALSE));
}

/* xmaplist - built-in function 'maplist' */
NODE *xmaplist(args)
  NODE *args;
{
    return (map(args,FALSE,TRUE));
}

/* map - internal mapping function */
LOCAL NODE *map(args,carflag,valflag)
  NODE *args; int carflag,valflag;
{
    NODE ***oldstk,*fcn,*lists,*arglist,*val,*last,*p,*x,*y;

    /* create a new stack frame */
    oldstk = xlstack;
    xlstkcheck(4);
    xlsave(fcn);
    xlsave(lists);
    xlsave(arglist);
    xlsave(val);

    /* get the function to apply and the first list */
    fcn = xlarg(&args);
    lists = xlmatch(LIST,&args);

    /* save the first list if not saving function values */
    if (!valflag)
          val = lists;

    /* build a list of argument lists (reversed) */
    for (lists = consa(lists); args; )
          lists = cons(xlmatch(LIST,&args),lists);

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

    /* loop through each of the argument lists */
    for (;;) {

          /* build an argument list from the sublists */
          arglist = NIL;
          for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
              arglist = cons(carflag ? car(y) : y,arglist);
              rplaca(x,cdr(y));
          }

          /* quit if any of the lists were empty */
          if (x) break;

          /* apply the function to the arguments */
          if (valflag) {
              p = consa(xlapply(fcn,arglist));
              if (val) rplacd(last,p);
              else val = p;
              last = p;
          }
          else
              xlapply(fcn,arglist);
    }

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

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

/* xrplca - replace the car of a list node */
NODE *xrplca(args)
  NODE *args;
{
    NODE *list,*newcar;

    /* get the list and the new car */
    if ((list = xlmatch(LIST,&args)) == NIL)
          xlfail("bad argument");
    newcar = xlarg(&args);
    xllastarg(args);

    /* replace the car */
    rplaca(list,newcar);

    /* return the list node that was modified */
    return (list);
}

/* xrplcd - replace the cdr of a list node */
NODE *xrplcd(args)
  NODE *args;
{
    NODE *list,*newcdr;

    /* get the list and the new cdr */
    if ((list = xlmatch(LIST,&args)) == NIL)
          xlfail("bad argument");
    newcdr = xlarg(&args);
    xllastarg(args);

    /* replace the cdr */
    rplacd(list,newcdr);

    /* return the list node that was modified */
    return (list);
}

/* xnconc - destructively append lists */
NODE *xnconc(args)
  NODE *args;
{
    NODE *list,*last,*val;

    /* concatenate each argument */
    for (val = NIL; args; ) {

          /* concatenate this list */
          if (list = xlmatch(LIST,&args)) {

              /* check for this being the first non-empty list */
              if (val) rplacd(last,list);
              else val = list;

              /* find the end of the list */
              while (consp(cdr(list)))
                    list = cdr(list);

              /* save the new last element */
              last = list;
          }
    }

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

/* xdelete - built-in function 'delete' */
NODE *xdelete(args)
  NODE *args;
{
    NODE ***oldstk,*x,*list,*fcn,*last,*val;
    int tresult;

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

    /* get the expression to delete and the list */
    x = xlarg(&args);
    list = xlmatch(LIST,&args);
    xltest(&fcn,&tresult,&args);
    xllastarg(args);

    /* delete leading matches */
    while (consp(list)) {
          if (dotest(x,car(list),fcn) != tresult)
              break;
          list = cdr(list);
    }
    val = last = list;

    /* delete embedded matches */
    if (consp(list)) {

          /* skip the first non-matching element */
          list = cdr(list);

          /* look for embedded matches */
          while (consp(list)) {

              /* check to see if this element should be deleted */
              if (dotest(x,car(list),fcn) == tresult)
                    rplacd(last,cdr(list));
              else
                    last = list;

              /* move to the next element */
              list = cdr(list);
          }
    }

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

    /* return the updated list */
    return (val);
}

/* xatom - is this an atom? */
NODE *xatom(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (atom(arg) ? true : NIL);
}

/* xsymbolp - is this an symbol? */
NODE *xsymbolp(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (arg == NIL || symbolp(arg) ? true : NIL);
}

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

/* xboundp - is this a value bound to this symbol? */
NODE *xboundp(args)
  NODE *args;
{
    NODE *sym;
    sym = xlmatch(SYM,&args);
    xllastarg(args);
    return (getvalue(sym) == s_unbound ? NIL : true);
}

/* xnull - is this null? */
NODE *xnull(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (null(arg) ? true : NIL);
}

/* xlistp - is this a list? */
NODE *xlistp(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (listp(arg) ? true : NIL);
}

/* xconsp - is this a cons? */
NODE *xconsp(args)
  NODE *args;
{
    NODE *arg;
    arg = xlarg(&args);
    xllastarg(args);
    return (consp(arg) ? true : NIL);
}

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

    /* get the two arguments */
    arg1 = xlarg(&args);
    arg2 = xlarg(&args);
    xllastarg(args);

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

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

    /* get the two arguments */
    arg1 = xlarg(&args);
    arg2 = xlarg(&args);
    xllastarg(args);

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

/* xequal - are these equal? */
NODE *xequal(args)
  NODE *args;
{
    NODE *arg1,*arg2;

    /* get the two arguments */
    arg1 = xlarg(&args);
    arg2 = xlarg(&args);
    xllastarg(args);

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