xllist.c

Audacity是一款用於錄音和編輯聲音的、免費的開放源碼軟體。它可以執行於Mac OS X、Microsoft Windows、GNU/Linux和其它作業系統

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

/* CHANGE LOG
 * --------------------------------------------------------------------
 * 28Apr03  dm  eliminate some compiler warnings
 * 28Apr03 rbd  fix check in sort routine
 */


#include "xlisp.h"

/* forward declarations */
FORWARD LOCAL LVAL cxr(char *adstr);
FORWARD LOCAL LVAL nth(int carflag);
FORWARD LOCAL LVAL assoc(LVAL expr, LVAL alist, LVAL fcn, int tresult);
FORWARD LOCAL LVAL subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, int tresult);
FORWARD LOCAL LVAL sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult);
FORWARD LOCAL LVAL map(int carflag, int valflag);
FORWARD LOCAL LVAL remif(int tresult);
FORWARD LOCAL LVAL delif(int tresult);
FORWARD LOCAL LVAL sortlist(LVAL list, LVAL fcn);
FORWARD LOCAL void splitlist(LVAL pivot, LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn);
FORWARD LOCAL LVAL gluelists(LVAL smaller, LVAL pivot, LVAL larger);


/* xcar - take the car of a cons cell */
LVAL xcar(void)
{
    LVAL list;
    list = xlgalist();
    xllastarg();
    return (list ? car(list) : NIL);
}

/* xcdr - take the cdr of a cons cell */
LVAL xcdr(void)
{
    LVAL list;
    list = xlgalist();
    xllastarg();
    return (list ? cdr(list) : NIL);
}

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

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

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

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

    /* get the list */
    list = xlgalist();
    xllastarg();

    /* 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 */
LVAL xcons(void)
{
    LVAL arg1,arg2;

    /* get the two arguments */
    arg1 = xlgetarg();
    arg2 = xlgetarg();
    xllastarg();

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

/* xlist - built a list of the arguments */
LVAL xlist(void)
{
    LVAL last=NULL,next,val;

    /* protect some pointers */
    xlsave1(val);

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

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

    /* restore the stack */
    xlpop();

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

/* xappend - built-in function append */
LVAL xappend(void)
{
    LVAL list,last=NULL,next,val;

    /* protect some pointers */
    xlsave1(val);

    /* initialize */
    val = NIL;
    
    /* append each argument */
    if (moreargs()) {
        while (xlargc > 1) {

            /* append each element of this list to the result list */
            for (list = nextarg(); consp(list); list = cdr(list)) {
                next = consa(car(list));
                if (val) rplacd(last,next);
                else val = next;
                last = next;
            }
        }

        /* handle the last argument */
        if (val) rplacd(last,nextarg());
        else val = nextarg();
    }

    /* restore the stack */
    xlpop();

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

/* xreverse - built-in function reverse */
LVAL xreverse(void)
{
    LVAL list,val;

    /* protect some pointers */
    xlsave1(val);

    /* get the list to reverse */
    list = xlgalist();
    xllastarg();

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

    /* restore the stack */
    xlpop();

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

/* xlast - return the last cons of a list */
LVAL xlast(void)
{
    LVAL list;

    /* get the list */
    list = xlgalist();
    xllastarg();

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

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

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

    /* protect some pointers */
    xlsave1(fcn);

    /* get the expression to look for and the list */
    x = xlgetarg();
    list = xlgalist();
    xltest(&fcn,&tresult);

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

    /* restore the stack */
    xlpop();

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

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

    /* protect some pointers */
    xlsave1(fcn);

    /* get the expression to look for and the association list */
    x = xlgetarg();
    alist = xlgalist();
    xltest(&fcn,&tresult);

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

    /* restore the stack */
    xlpop();

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

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

    /* protect some pointers */
    xlsave1(fcn);

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

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

    /* restore the stack */
    xlpop();

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

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

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

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

    /* protect some pointers */
    xlsave1(fcn);

    /* get the assocation list and the expression */
    alist = xlgalist();
    expr = xlgetarg();
    xltest(&fcn,&tresult);

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

    /* restore the stack */
    xlpop();

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

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

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

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

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

/* xremove - built-in function 'remove' */
LVAL xremove(void)
{
    LVAL x,list,fcn,val,last=NULL,next;
    int tresult;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(fcn);
    xlsave(val);

    /* get the expression to remove and the list */
    x = xlgetarg();
    list = xlgalist();
    xltest(&fcn,&tresult);

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

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

    /* restore the stack */
    xlpopn(2);

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

/* xremif - built-in function 'remove-if' */
LVAL xremif(void)
{
    LVAL remif();
    return (remif(TRUE));
}

/* xremifnot - built-in function 'remove-if-not' */
LVAL xremifnot(void)
{
    LVAL remif();
    return (remif(FALSE));
}

/* remif - common code for 'remove-if' and 'remove-if-not' */
LOCAL LVAL remif(int tresult)
{
    LVAL list,fcn,val,last=NULL,next;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(fcn);
    xlsave(val);

    /* get the expression to remove and the list */
    fcn = xlgetarg();
    list = xlgalist();
    xllastarg();

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

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

    /* restore the stack */
    xlpopn(2);

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

/* dotest1 - call a test function with one argument */
int dotest1(LVAL arg, LVAL fun)
{
    LVAL *newfp;

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(fun);
    pusharg(cvfixnum((FIXTYPE)1));
    pusharg(arg);
    xlfp = newfp;