xlcont.c

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

        /* evaluate the result expression */
        xlsetvalue(sym,NIL);
        val = (consp(clist) ? xleval(car(clist)) : NIL);

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

    /* restore the stack */
    xlpop();

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

/* xdotimes - special form 'dotimes' */
LVAL xdotimes(void)
{
    LVAL *argv,clist,sym,cnt,val;
    XLCONTEXT cntxt;
    int argc,n,i;

    /* get the control list (sym list result-expr) */
    clist = xlgalist();
    sym = match(SYMBOL,&clist);
    cnt = evmatch(FIXNUM,&clist); n = getfixnum(cnt);
    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 for each value from zero to n-1 */
        for (val = NIL, i = 0; i < n; ++i) {

            /* bind the symbol to the next list element */
            xlsetvalue(sym,cvfixnum((FIXTYPE)i));

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

        /* evaluate the result expression */
        xlsetvalue(sym,cnt);
        val = (consp(clist) ? xleval(car(clist)) : NIL);

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

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

/* xblock - special form 'block' */
LVAL xblock(void)
{
    LVAL name,val;
    XLCONTEXT cntxt;

    /* get the block name */
    name = xlgetarg();
    if (name && !symbolp(name))
        xlbadtype(name);

    /* execute the block */
    xlbegin(&cntxt,CF_RETURN,name);
    if (setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else
        for (val = NIL; moreargs(); )
            val = xleval(nextarg());
    xlend(&cntxt);

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

/* xtagbody - special form 'tagbody' */
LVAL xtagbody(void)
{
    tagbody();
    return (NIL);
}

/* xcatch - special form 'catch' */
LVAL xcatch(void)
{
    XLCONTEXT cntxt;
    LVAL tag,val;

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

    /* get the tag */
    tag = xleval(nextarg());

    /* establish an execution context */
    xlbegin(&cntxt,CF_THROW,tag);

    /* check for 'throw' */
    if (setjmp(cntxt.c_jmpbuf))
        val = xlvalue;

    /* otherwise, evaluate the remainder of the arguments */
    else {
        for (val = NIL; moreargs(); )
            val = xleval(nextarg());
    }
    xlend(&cntxt);

    /* restore the stack */
    xlpop();

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

/* xthrow - special form 'throw' */
LVAL xthrow(void)
{
    LVAL tag,val;

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

    /* throw the tag */
    xlthrow(tag,val);
    return NIL; /* never happens */
}

/* xunwindprotect - special form 'unwind-protect' */
LVAL xunwindprotect(void)
{
    extern XLCONTEXT *xltarget;
    extern int xlmask;
    XLCONTEXT cntxt;
    XLCONTEXT *target = NULL;
    int mask = 0;
    int sts;
    LVAL val;

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

    /* get the expression to protect */
    val = xlgetarg();

    /* evaluate the protected expression */
    xlbegin(&cntxt,CF_UNWIND,NIL);
    if ((sts = setjmp(cntxt.c_jmpbuf))) {
        target = xltarget;
        mask = xlmask;
        val = xlvalue;
    }
    else
        val = xleval(val);
    xlend(&cntxt);
        
    /* evaluate the cleanup expressions */
    while (moreargs())
        xleval(nextarg());

    /* if unwinding, continue unwinding */
    if (sts)
        xljump(target,mask,val);

    /* restore the stack */
    xlpop();

    /* return the value of the protected expression */
    return (val);
}

/* xerrset - special form 'errset' */
LVAL xerrset(void)
{
    LVAL expr,flag,val;
    XLCONTEXT cntxt;

    /* get the expression and the print flag */
    expr = xlgetarg();
    flag = (moreargs() ? xlgetarg() : s_true);
    xllastarg();

    /* establish an execution context */
    xlbegin(&cntxt,CF_ERROR,flag);

    /* check for error */
    if (setjmp(cntxt.c_jmpbuf))
        val = NIL;

    /* otherwise, evaluate the expression */
    else {
        expr = xleval(expr);
        val = consa(expr);
    }
    xlend(&cntxt);

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

/* xtrace - special form 'trace' */
LVAL xtrace(void)
{
    LVAL sym,fun,this;

    /* loop through all of the arguments */
    sym = xlenter("*TRACELIST*");
    while (moreargs()) {
        fun = xlgasymbol();

        /* check for the function name already being in the list */
        for (this = getvalue(sym); consp(this); this = cdr(this))
            if (car(this) == fun)
                break;

        /* add the function name to the list */
        if (null(this))
            setvalue(sym,cons(fun,getvalue(sym)));
    }
    return (getvalue(sym));
}

/* xuntrace - special form 'untrace' */
LVAL xuntrace(void)
{
    LVAL sym,fun,this,last;

    /* loop through all of the arguments */
    sym = xlenter("*TRACELIST*");
    while (moreargs()) {
        fun = xlgasymbol();

        /* remove the function name from the list */
        last = NIL;
        for (this = getvalue(sym); consp(this); this = cdr(this)) {
            if (car(this) == fun) {
                if (last)
                    rplacd(last,cdr(this));
                else
                    setvalue(sym,cdr(this));
                break;
            }
            last = this;
        }
    }
    return (getvalue(sym));
}

/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
LOCAL void dobindings(LVAL list, LVAL env)
{
    LVAL bnd, val;
    LVAL sym = NULL;

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

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

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

        /* handle a symbol */
        if (symbolp(bnd)) {
            sym = bnd;
            val = NIL;
        }

        /* handle a list of the form (symbol expr) */
        else if (consp(bnd)) {
            sym = match(SYMBOL,&bnd);
            val = evarg(&bnd);
        }
        else
            xlfail("bad binding");

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

    /* restore the stack */
    xlpop();
}

/* doupdates - handle updates for do/do* */
LOCAL void doupdates(LVAL list, int pflag)
{
    LVAL plist,bnd,sym,val;

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

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

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

        /* handle a list of the form (symbol expr) */
        if (consp(bnd)) {
            sym = match(SYMBOL,&bnd);
            bnd = cdr(bnd);
            if (bnd) {
                val = evarg(&bnd);
                if (pflag)
                    plist = cons(cons(sym,val),plist);
                else
                    xlsetvalue(sym,val);
            }
        }
    }

    /* set the values for parallel updates */
    for (; plist; plist = cdr(plist))
        xlsetvalue(car(car(plist)),cdr(car(plist)));

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

/* tagbody - execute code within a block and tagbody */
LOCAL void tagbody(void)
{
    LVAL *argv,arg;
    XLCONTEXT cntxt;
    int argc;

    /* establish an execution context */
    xlbegin(&cntxt,CF_GO,NIL);
    argc = xlargc;
    argv = xlargv;

    /* check for a 'go' */
    if (setjmp(cntxt.c_jmpbuf)) {
        cntxt.c_xlargc = argc;
        cntxt.c_xlargv = argv;
    }

    /* execute the body */
    while (moreargs()) {
        arg = nextarg();
        if (consp(arg))
            xleval(arg);
    }
    xlend(&cntxt);
}

/* match - get an argument and match its type */
LOCAL LVAL match(int type, LVAL *pargs)
{
    LVAL arg;

    /* make sure the argument exists */
    if (!consp(*pargs))
        toofew(*pargs);

    /* get the argument value */
    arg = car(*pargs);

    /* move the argument pointer ahead */
    *pargs = cdr(*pargs);

    /* check its type */
    if (type == LIST) {
        if (arg && ntype(arg) != CONS)
            xlerror("bad argument type",arg);
    }
    else {
        if (arg == NIL || ntype(arg) != type)
            xlerror("bad argument type",arg);
    }

    /* return the argument */
    return (arg);
}

/* evarg - get the next argument and evaluate it */
LOCAL LVAL evarg(LVAL *pargs)
{
    LVAL arg;

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

    /* make sure the argument exists */
    if (!consp(*pargs))
        toofew(*pargs);

    /* get the argument value */
    arg = car(*pargs);

    /* move the argument pointer ahead */
    *pargs = cdr(*pargs);

    /* evaluate the argument */
    arg = xleval(arg);

    /* restore the stack */
    xlpop();

    /* return the argument */
    return (arg);
}

/* evmatch - get an evaluated argument and match its type */
LOCAL LVAL evmatch(int type, LVAL *pargs)
{
    LVAL arg;

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

    /* make sure the argument exists */
    if (!consp(*pargs))
        toofew(*pargs);

    /* get the argument value */
    arg = car(*pargs);

    /* move the argument pointer ahead */
    *pargs = cdr(*pargs);

    /* evaluate the argument */
    arg = xleval(arg);

    /* check its type */
    if (type == LIST) {
        if (arg && ntype(arg) != CONS)
            xlerror("bad argument type",arg);
    }
    else {
        if (arg == NIL || ntype(arg) != type)
            xlerror("bad argument type",arg);
    }

    /* restore the stack */
    xlpop();

    /* return the argument */
    return (arg);
}

/* toofew - too few arguments */
LOCAL void toofew(LVAL args)
{
    xlerror("too few arguments",args);
}

/* toomany - too many arguments */
LOCAL void toomany(LVAL args)
{
    xlerror("too many arguments",args);
}