xlcont.c

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

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

/* xand - special form 'and' */
LVAL xand(void)
{
    LVAL val;

    /* evaluate each argument */
    for (val = s_true; moreargs(); )
        if ((val = xleval(nextarg())) == NIL)
            break;

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

/* xor - special form 'or' */
LVAL xor(void)
{
    LVAL val;

    /* evaluate each argument */
    for (val = NIL; moreargs(); )
        if ((val = xleval(nextarg())))
            break;

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

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

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

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

/* xlet - special form 'let' */
LVAL xlet(void)
{
    return (let(TRUE));
}

/* xletstar - special form 'let*' */
LVAL xletstar(void)
{
    return (let(FALSE));
}

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

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

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

    /* get the list of bindings and bind the symbols */
    if (!pflag) {
        xlenv = newenv;
    }
    dobindings(xlgalist(),newenv);
    if (pflag) {
        xlenv = newenv;
    }

    /* execute the code */
    for (val = NIL; moreargs(); )
        val = xleval(nextarg());

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

    /* restore the stack */
    xlpop();

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

/* xflet - built-in function 'flet' */
LVAL xflet(void)
{
    return (flet(s_lambda,TRUE));
}

/* xlabels - built-in function 'labels' */
LVAL xlabels(void)
{
    return (flet(s_lambda,FALSE));
}

/* xmacrolet - built-in function 'macrolet' */
LVAL xmacrolet(void)
{
    return (flet(s_macro,TRUE));
}

/* flet - common flet/labels/macrolet routine */
LOCAL LVAL flet(LVAL type, int letflag)
{
    LVAL list,bnd,sym,fargs,val;

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

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

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

        /* get the symbol and the function definition */
        sym = match(SYMBOL,&bnd);
        fargs = match(LIST,&bnd);
        val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));

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

    /* execute the code */
    for (val = NIL; moreargs(); )
        val = xleval(nextarg());

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

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

/* xprog - special form 'prog' */
LVAL xprog(void)
{
    return (prog(TRUE));
}

/* xprogstar - special form 'prog*' */
LVAL xprogstar(void)
{
    return (prog(FALSE));
}

/* prog - common prog routine */
LOCAL LVAL prog(int pflag)
{
    LVAL newenv,val;
    XLCONTEXT cntxt;

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

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

    /* establish a new execution context */
    xlbegin(&cntxt,CF_RETURN,NIL);
    if (setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else {

        /* get the list of bindings and bind the symbols */
        if (!pflag) {
            xlenv = newenv;
        }
        dobindings(xlgalist(),newenv);
        if (pflag) {
            xlenv = newenv;
        }

        /* execute the code */
        tagbody();
        val = NIL;

        /* unbind the arguments */
        xlenv = cdr(xlenv);
    }
    xlend(&cntxt);

    /* restore the stack */
    xlpop();

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

/* 4035 is the "no return value" warning message */
/* xgo, xreturn, xrtnfrom, and xthrow don't return anything */
/* #pragma warning(disable: 4035) */
/* xgo - special form 'go' */
LVAL xgo(void)
{
    LVAL label;

    /* get the target label */
    label = xlgetarg();
    xllastarg();

    /* transfer to the label */
    xlgo(label);
    return NIL; /* never happens */
}

/* xreturn - special form 'return' */
LVAL xreturn(void)
{
    LVAL val;

    /* get the return value */
    val = (moreargs() ? xleval(nextarg()) : NIL);
    xllastarg();

    /* return from the inner most block */
    xlreturn(NIL,val);
    return NIL; /* never happens */
}

/* xrtnfrom - special form 'return-from' */
LVAL xrtnfrom(void)
{
    LVAL name,val;

    /* get the return value */
    name = xlgasymbol();
    val = (moreargs() ? xleval(nextarg()) : NIL);
    xllastarg();

    /* return from the inner most block */
    xlreturn(name,val);
    return NIL; /* never happens */
}

/* xprog1 - special form 'prog1' */
LVAL xprog1(void)
{
    return (progx(1));
}

/* xprog2 - special form 'prog2' */
LVAL xprog2(void)
{
    return (progx(2));
}

/* progx - common progx code */
LOCAL LVAL progx(int n)
{
    LVAL val;

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

    /* evaluate the first n expressions */
    while (moreargs() && --n >= 0)
        val = xleval(nextarg());

    /* evaluate each remaining argument */
    while (moreargs())
        xleval(nextarg());

    /* restore the stack */
    xlpop();

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

/* xprogn - special form 'progn' */
LVAL xprogn(void)
{
    LVAL val;

    /* evaluate each expression */
    for (val = NIL; moreargs(); )
        val = xleval(nextarg());

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

/* xprogv - special form 'progv' */
LVAL xprogv(void)
{
    LVAL olddenv,vars,vals,val;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(vars);
    xlsave(vals);

    /* get the list of variables and the list of values */
    vars = xlgetarg(); vars = xleval(vars);
    vals = xlgetarg(); vals = xleval(vals);

    /* bind the values to the variables */
    for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
        if (!symbolp(car(vars)))
            xlerror("expecting a symbol",car(vars));
        if (consp(vals)) {
            xldbind(car(vars),car(vals));
            vals = cdr(vals);
        }
        else
            xldbind(car(vars),s_unbound);
    }

    /* evaluate each expression */
    for (val = NIL; moreargs(); )
        val = xleval(nextarg());

    /* restore the previous environment and the stack */
    xlunbind(olddenv);
    xlpopn(2);

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

/* xloop - special form 'loop' */
LVAL xloop(void)
{
    LVAL *argv,arg,val;
    XLCONTEXT cntxt;
    int argc;

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

    /* establish a new execution context */
    xlbegin(&cntxt,CF_RETURN,NIL);
    if (setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else
        for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
            while (moreargs()) {
                arg = nextarg();
                if (consp(arg))
                    xleval(arg);
            }
    xlend(&cntxt);

    /* restore the stack */
    xlpop();

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

/* xdo - special form 'do' */
LVAL xdo(void)
{
    return (doloop(TRUE));
}

/* xdostar - special form 'do*' */
LVAL xdostar(void)
{
    return (doloop(FALSE));
}

/* doloop - common do routine */
LOCAL LVAL doloop(int pflag)
{
    LVAL newenv,*argv,blist,clist,test,val;
    XLCONTEXT cntxt;
    int argc;

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

    /* get the list of bindings, the exit test and the result forms */
    blist = xlgalist();
    clist = xlgalist();
    test = (consp(clist) ? car(clist) : NIL);
    argv = xlargv;
    argc = xlargc;

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

    /* establish a new execution context */
    xlbegin(&cntxt,CF_RETURN,NIL);
    if (setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else {

        /* 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 (val = NIL; xleval(test) == NIL; doupdates(blist,pflag)) {
            xlargv = argv;
            xlargc = argc;
            tagbody();
        }

        /* evaluate the result expression */
        if (consp(clist))
            for (clist = cdr(clist); consp(clist); clist = cdr(clist))
                val = xleval(car(clist));

        /* unbind the arguments */
        xlenv = cdr(xlenv);
    }
    xlend(&cntxt);

    /* restore the stack */
    xlpop();

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

/* xdolist - special form 'dolist' */
LVAL xdolist(void)
{
    LVAL list,*argv,clist,sym,val;
    XLCONTEXT cntxt;
    int argc;

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

    /* get the control list (sym list result-expr) */
    clist = xlgalist();
    sym = match(SYMBOL,&clist);
    list = evmatch(LIST,&clist);
    argv = xlargv;
    argc = xlargc;

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

    /* establish a new execution context */
    xlbegin(&cntxt,CF_RETURN,NIL);
    if (setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else {

        /* loop through the list */
        for (val = NIL; consp(list); list = cdr(list)) {

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

            /* execute the loop body */
            xlargv = argv;
            xlargc = argc;
            tagbody();
        }