/* xllist - xlisp list builtin functions */

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

#include "xlisp.h"

/* external variables */
extern struct node *xlstack;

/* local variables */
static struct node *t;
static struct node *a_subr;
static struct node *a_list;
static struct node *a_sym;
static struct node *a_int;
static struct node *a_str;
static struct node *a_obj;
static struct node *a_fptr;
static struct node *a_kmap;

/* xlist - builtin function list */
LOCAL struct node *xlist(args)
  struct node *args;
{
    struct node *oldstk,arg,list,val,*last,*lptr;

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

    /* initialize */
    arg.n_ptr = args;

    /* evaluate and append each argument */
    for (last = NULL; arg.n_ptr != NULL; last = lptr) {

        /* evaluate the next argument */
        val.n_ptr = xlevarg(&arg.n_ptr);

        /* append this argument to the end of the list */
        lptr = newnode(LIST);
        if (last == NULL)
            list.n_ptr = lptr;
        else
            last->n_listnext = lptr;
        lptr->n_listvalue = val.n_ptr;
    }

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

    /* return the list */
    return (list.n_ptr);
}

/* cond - builtin function cond */
LOCAL struct node *cond(args)
  struct node *args;
{
    struct node *oldstk,arg,list,*val;

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

    /* initialize */
    arg.n_ptr = args;

    /* initialize the return value */
    val = NULL;

    /* find a predicate that is true */
    while (arg.n_ptr != NULL) {

        /* get the next conditional */
        list.n_ptr = xlmatch(LIST,&arg.n_ptr);

        /* evaluate the predicate part */
        if (xlevarg(&list.n_ptr) != NULL) {

            /* evaluate each expression */
            while (list.n_ptr != NULL)
                val = xlevarg(&list.n_ptr);

            /* exit the loop */
            break;
        }
    }

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

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

/* atom - is this an atom? */
LOCAL struct node *atom(args)
  struct node *args;
{
    struct node *arg;

    /* get the argument */
    if ((arg = xlevarg(&args)) == NULL || arg->n_type != LIST)
        return (t);
    else
        return (NULL);
}

/* null - is this null? */
LOCAL struct node *null(args)
  struct node *args;
{
    /* get the argument */
    if (xlevarg(&args) == NULL)
        return (t);
    else
        return (NULL);
}

/* type - return type of a thing */
LOCAL struct node *type(args)
    struct node *args;
{
    struct node *arg;

    if (!(arg = xlevarg(&args)))
        return (NULL);

    switch (arg->n_type) {
        case SUBR: return (a_subr);
        case LIST: return (a_list);
        case SYM: return (a_sym);
        case INT: return (a_int);
        case STR: return (a_str);
        case OBJ: return (a_obj);
        case FPTR: return (a_fptr);
        case KMAP: return (a_kmap);
        default: xlfail("Bad node.");
        }
}

/* listp - is this a list? */
LOCAL struct node *listp(args)
  struct node *args;
{
    /* get the argument */
    if (xlistp(xlevarg(&args)))
        return (t);
    else
        return (NULL);
}

/* xlistp - internal listp function */
LOCAL int xlistp(arg)
  struct node *arg;
{
    return (arg == NULL || arg->n_type == LIST);
}

/* eq - are these equal? */
LOCAL struct node *eq(args)
  struct node *args;
{
    struct node *oldstk,arg,arg1,arg2,*val;

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

    /* initialize */
    arg.n_ptr = args;

    /* first argument */
    arg1.n_ptr = xlevarg(&arg.n_ptr);

    /* second argument */
    arg2.n_ptr = xlevarg(&arg.n_ptr);

    /* make sure there aren't any more arguments */
    xllastarg(arg.n_ptr);

    /* compare the arguments */
    if (xeq(arg1.n_ptr,arg2.n_ptr))
        val = t;
    else
        val = NULL;

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

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

/* xeq - internal eq function */
LOCAL int xeq(arg1,arg2)
  struct node *arg1,*arg2;
{
    /* compare the arguments */
    if (arg1 != NULL && arg1->n_type == INT &&
        arg2 != NULL && arg2->n_type == INT)
        return (arg1->n_int == arg2->n_int);
    else
        return (arg1 == arg2);
}

/* equal - are these equal? */
LOCAL struct node *equal(args)
  struct node *args;
{
    struct node *oldstk,arg,arg1,arg2,*val;

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

    /* initialize */
    arg.n_ptr = args;

    /* first argument */
    arg1.n_ptr = xlevarg(&arg.n_ptr);

    /* second argument */
    arg2.n_ptr = xlevarg(&arg.n_ptr);

    /* make sure there aren't any more arguments */
    xllastarg(arg.n_ptr);

    /* compare the arguments */
    if (xequal(arg1.n_ptr,arg2.n_ptr))
        val = t;
    else
        val = NULL;

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

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

/* xequal - internal equal function */
LOCAL int xequal(arg1,arg2)
  struct node *arg1,*arg2;
{
    /* compare the arguments */
    if (xeq(arg1,arg2))
        return (TRUE);
    else if (xlistp(arg1) && xlistp(arg2))
        return (xequal(arg1->n_listvalue,arg2->n_listvalue) &&
                xequal(arg1->n_listnext, arg2->n_listnext));
    else
        return (FALSE);
}

/* head - return the head of a list */
LOCAL struct node *head(args)
  struct node *args;
{
    struct node *list;

    /* get the list */
    if ((list = xlevmatch(LIST,&args)) == NULL)
        xlfail("null list");

    /* make sure this is the only argument */
    xllastarg(args);

    /* return the head of the list */
    return (list->n_listvalue);
}

/* tail - return the tail of a list */
LOCAL struct node *tail(args)
  struct node *args;
{
    struct node *list;

    /* get the list */
    if ((list = xlevmatch(LIST,&args)) == NULL)
        xlfail("null list");

    /* make sure this is the only argument */
    xllastarg(args);

    /* return the tail of the list */
    return (list->n_listnext);
}

/* nth - return the nth element of a list */
LOCAL struct node *nth(args)
  struct node *args;
{
    struct node *oldstk,arg,list;
    int n;

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

    /* initialize */
    arg.n_ptr = args;

    /* get n */
    if ((n = xlevmatch(INT,&arg.n_ptr)->n_int) < 1)
        xlfail("invalid argument");

    /* get the list */
    if ((list.n_ptr = xlevmatch(LIST,&arg.n_ptr)) == NULL)
        xlfail("invalid argument");

    /* make sure this is the only argument */
    xllastarg(arg.n_ptr);

    /* find the nth element */
    for (; n > 1; n--) {
        list.n_ptr = list.n_ptr->n_listnext;
        if (list.n_ptr == NULL || list.n_ptr->n_type != LIST)
            xlfail("invalid argument");
    }

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

    /* return the list nth list element */
    return (list.n_ptr->n_listvalue);
}

/* length - return the length of a list */
LOCAL struct node *length(args)
  struct node *args;
{
    struct node *oldstk,list,*val;
    int n;

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

    /* get the list */
    list.n_ptr = xlevmatch(LIST,&args);

    /* make sure this is the only argument */
    xllastarg(args);

    /* find the length */
    for (n = 0; list.n_ptr != NULL; n++)
        list.n_ptr = list.n_ptr->n_listnext;

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

    /* create the value node */
    val = newnode(INT);
    val->n_int = n;

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

/* append - builtin function append */
LOCAL struct node *append(args)
  struct node *args;
{
    struct node *oldstk,arg,list,last,val,*lptr;

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

    /* initialize */
    arg.n_ptr = args;

    /* evaluate and append each argument */
    while (arg.n_ptr != NULL) {

        /* evaluate the next argument */
        list.n_ptr = xlevmatch(LIST,&arg.n_ptr);

        /* append each element of this list to the result list */
        while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {

            /* append this element */
            lptr = newnode(LIST);
            if (last.n_ptr == NULL)
                val.n_ptr = lptr;
            else
                last.n_ptr->n_listnext = lptr;
            lptr->n_listvalue = list.n_ptr->n_listvalue;

            /* save the new last element */
            last.n_ptr = lptr;

            /* move to the next element */
            list.n_ptr = list.n_ptr->n_listnext;
        }

        /* make sure the list ended in a nil */
        if (list.n_ptr != NULL)
            xlfail("bad list");
    }

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

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

/* reverse - builtin function reverse */
LOCAL struct node *reverse(args)
  struct node *args;
{
    struct node *oldstk,list,val,*lptr;

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

    /* get the list to reverse */
    list.n_ptr = xlevmatch(LIST,&args);

    /* make sure there aren't any more arguments */
    xllastarg(args);

    /* append each element of this list to the result list */
    while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {

        /* append this element */
        lptr = newnode(LIST);
        lptr->n_listvalue = list.n_ptr->n_listvalue;
        lptr->n_listnext = val.n_ptr;
        val.n_ptr = lptr;

        /* move to the next element */
        list.n_ptr = list.n_ptr->n_listnext;
    }

    /* make sure the list ended in a nil */
    if (list.n_ptr != NULL)
        xlfail("bad list");

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

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

/* cons - construct a new list cell */
LOCAL struct node *cons(args)
  struct node *args;
{
    struct node *oldstk,arg,arg1,arg2,*lptr;

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

    /* initialize */
    arg.n_ptr = args;

    /* first argument */
    arg1.n_ptr = xlevarg(&arg.n_ptr);

    /* second argument */
    arg2.n_ptr = xlevarg(&arg.n_ptr);

    /* make sure there aren't any more arguments */
    xllastarg(arg.n_ptr);

    /* construct a new list element */
    lptr = newnode(LIST);
    lptr->n_listvalue = arg1.n_ptr;
    lptr->n_listnext  = arg2.n_ptr;

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

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

/* xllinit - xlisp list initialization routine */
xllinit()
{
    /* define some symbols */
    t = xlenter("t");
    a_subr = xlenter("SUBR");
    a_list = xlenter("LIST");
    a_sym = xlenter("SYM");
    a_int = xlenter("INT");
    a_str = xlenter("STR");
    a_obj = xlenter("OBJ");
    a_fptr = xlenter("FPTR");
    a_kmap = xlenter("KMAP");

    /* functions with reasonable names */
    xlsubr("head",head);
    xlsubr("tail",tail);
    xlsubr("nth",nth);

    /* real lisp functions */
    xlsubr("atom",atom);
    xlsubr("eq",eq);
    xlsubr("equal",equal);
    xlsubr("null",null);
    xlsubr("type",type);
    xlsubr("listp",listp);
    xlsubr("cond",cond);
    xlsubr("list",xlist);
    xlsubr("cons",cons);
    xlsubr("car",head);
    xlsubr("cdr",tail);
    xlsubr("append",append);
    xlsubr("reverse",reverse);
    xlsubr("length",length);
}

fisnew(args)
  struct node *args;
{
    /* make sure there aren'