xllist.c

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

    /* return the result of applying the test function */
    return (xlapply(1) != NIL);

}

/* dotest2 - call a test function with two arguments */
int dotest2(LVAL arg1, LVAL arg2, LVAL fun)
{
    LVAL *newfp;

    /* create the new call frame */
    newfp = xlsp;
    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
    pusharg(fun);
    pusharg(cvfixnum((FIXTYPE)2));
    pusharg(arg1);
    pusharg(arg2);
    xlfp = newfp;

    /* return the result of applying the test function */
    return (xlapply(2) != NIL);

}

/* xnth - return the nth element of a list */
LVAL xnth(void)
{
    return (nth(TRUE));
}

/* xnthcdr - return the nth cdr of a list */
LVAL xnthcdr(void)
{
    return (nth(FALSE));
}

/* nth - internal nth function */
LOCAL LVAL nth(int carflag)
{
    LVAL list,num;
    FIXTYPE n;

    /* get n and the list */
    num = xlgafixnum();
    list = xlgacons();
    xllastarg();

    /* make sure the number isn't negative */
    if ((n = getfixnum(num)) < 0)
        xlfail("bad argument");

    /* 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 */
LVAL xlength(void)
{
    FIXTYPE n=0;
    LVAL arg;

    /* get the list or string */
    arg = xlgetarg();
    xllastarg();

    /* 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 = (FIXTYPE)getslength(arg)-1;

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

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

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

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

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

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

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

/* map - internal mapping function */
LOCAL LVAL map(int carflag, int valflag)
{
    LVAL *newfp,fun,lists,val,last,p,x,y;
    int argc;

    /* protect some pointers */
    xlstkcheck(3);
    xlsave(fun);
    xlsave(lists);
    xlsave(val);

    /* get the function to apply and the first list */
    fun = xlgetarg();
    lists = xlgalist();

    /* initialize the result list */
    val = (valflag ? NIL : lists);

    /* build a list of argument lists */
    for (lists = last = consa(lists); moreargs(); last = cdr(last))
        rplacd(last,cons(xlgalist(),NIL));

    /* loop through each of the argument lists */
    for (;;) {
        /* build an argument list from the sublists */
        newfp = xlsp;
        pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
        pusharg(fun);
        pusharg(NIL);
        argc = 0;
        for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
            pusharg(carflag ? car(y) : y);
            rplaca(x,cdr(y));
            ++argc;
        }

        /* quit if any of the lists were empty */
        if (x) {
            xlsp = newfp;
            break;
        }

        /* apply the function to the arguments */
        newfp[2] = cvfixnum((FIXTYPE)argc);
        xlfp = newfp;
        if (valflag) {
            p = consa(xlapply(argc));
            if (val) rplacd(last,p);
            else val = p;
            last = p;
        }
        else
            xlapply(argc);
    }

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

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

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

    /* get the list and the new car */
    list = xlgacons();
    newcar = xlgetarg();
    xllastarg();

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

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

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

    /* get the list and the new cdr */
    list = xlgacons();
    newcdr = xlgetarg();
    xllastarg();

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

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

/* xnconc - destructively append lists */
LVAL xnconc(void)
{
    LVAL next,last=NULL,val;

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

            /* ignore everything except lists */
            if ((next = nextarg()) && consp(next)) {

                /* concatenate this list to the result list */
                if (val) rplacd(last,next);
                else val = next;

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

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

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

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

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

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

    /* delete leading matches */
    while (consp(list)) {
        if (dotest2(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 (dotest2(x,car(list),fcn) == tresult)
                rplacd(last,cdr(list));
            else
                last = list;

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

    /* restore the stack */
    xlpop();

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

/* xdelif - built-in function 'delete-if' */
LVAL xdelif(void)
{
    LVAL delif();
    return (delif(TRUE));
}

/* xdelifnot - built-in function 'delete-if-not' */
LVAL xdelifnot(void)
{
    LVAL delif();
    return (delif(FALSE));
}

/* delif - common routine for 'delete-if' and 'delete-if-not' */
LOCAL LVAL delif(int tresult)
{
    LVAL list,fcn,last,val;

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

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

    /* delete leading matches */
    while (consp(list)) {
        if (dotest1(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 (dotest1(car(list),fcn) == tresult)
                rplacd(last,cdr(list));
            else
                last = list;

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

    /* restore the stack */
    xlpop();

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

/* xsort - built-in function 'sort' */
LVAL xsort(void)
{
    LVAL sortlist();
    LVAL list,fcn;

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

    /* get the list to sort and the comparison function */
    list = xlgalist();
    fcn = xlgetarg();
    xllastarg();

    /* sort the list */
    list = sortlist(list,fcn);

    if (list && (ntype(list) == FREE_NODE)) {
        stdputstr("error in sort 2");
    }

    /* restore the stack and return the sorted list */
    xlpopn(2);
    return (list);
}

/*
    This sorting algorithm is based on a Modula-2 sort written by
    Richie Bielak and published in the February 1988 issue of
    "Computer Language" magazine in a letter to the editor.
*/

/* sortlist - sort a list using quicksort */
LOCAL LVAL sortlist(LVAL list, LVAL fcn)
{
    LVAL gluelists();
    LVAL smaller,pivot,larger;
    
    /* protect some pointers */
    xlstkcheck(3);
    xlsave(smaller);
    xlsave(pivot);
    xlsave(larger);
    
    /* lists with zero or one element are already sorted */
    if (consp(list) && consp(cdr(list))) {
        pivot = list; list = cdr(list);
        splitlist(pivot,list,&smaller,&larger,fcn);
        smaller = sortlist(smaller,fcn);
        larger = sortlist(larger,fcn);
        list = gluelists(smaller,pivot,larger);
    }

    /* cleanup the stack and return the sorted list */
    xlpopn(3);
    return (list);
}

/* splitlist - split the list around the pivot */
LOCAL void splitlist(LVAL pivot, LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn)
{
    LVAL next;

    xlprot1(list); // protect list from gc
    // the rplacd disconnects list, and next is the only 
    // reference to it, but next is immediately assigned to list
    // before dotest2 which is where gc might run.
    
    /* initialize the result lists */
    *psmaller = *plarger = NIL;
    
    /* split the list */
    for (; consp(list); list = next) {
        next = cdr(list);
        if (dotest2(car(list),car(pivot),fcn)) {
            rplacd(list,*psmaller);
            *psmaller = list;
        }
        else {
            rplacd(list,*plarger);
            *plarger = list;
        }
    }
    xlpop();
}

/* gluelists - glue the smaller and larger lists with the pivot */
LOCAL LVAL gluelists(LVAL smaller, LVAL pivot, LVAL larger)
{
    LVAL last;
    
    /* larger always goes after the pivot */
    rplacd(pivot,larger);

    /* if the smaller list is empty, we're done */
    if (null(smaller)) return (pivot);

    /* append the smaller to the front of the resulting list */
    for (last = smaller; consp(cdr(last)); last = cdr(last))
        ;
    rplacd(last,pivot);

    return (smaller);
}