xleval.c

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

    xlstkcheck(4);
    xlsave(oldenv);
    xlsave(oldfenv);
    xlsave(cptr);
    xlprotect(fun);     /* (RBD) Otherwise, fun is unprotected */

    /* create a new environment frame */
    oldenv = xlenv;
    oldfenv = xlfenv;
    xlenv = xlframe(closure_getenv(fun));
    xlfenv = getfenv(fun);

    /* bind the formal parameters */
    xlabind(fun,argc,argv);

    /* setup the implicit block */
    if ((name = getname(fun)))
        xlbegin(&cntxt,CF_RETURN,name);

    /* execute the block */
    if (name && setjmp(cntxt.c_jmpbuf))
        val = xlvalue;
    else
        for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
            val = xleval(car(cptr));

    /* finish the block context */
    if (name)
        xlend(&cntxt);

    /* restore the environment */
    xlenv = oldenv;
    xlfenv = oldfenv;

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

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

/* xlclose - create a function closure */
LVAL xlclose(LVAL name, LVAL type, LVAL fargs, LVAL body, LVAL env, LVAL fenv)
{
    LVAL closure,key=NULL,arg,def,svar,new,last;
    char keyname[STRMAX+2];

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

    /* create the closure object */
    closure = newclosure(name,type,env,fenv);
    setlambda(closure,fargs);
    setbody(closure,body);

    /* handle each required argument */
    last = NIL;
    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {

        /* make sure the argument is a symbol */
        if (!symbolp(arg))
            badarglist();

        /* create a new argument list entry */
        new = cons(arg,NIL);

        /* link it into the required argument list */
        if (last)
            rplacd(last,new);
        else
            setargs(closure,new);
        last = new;

        /* move the formal argument list pointer ahead */
        fargs = cdr(fargs);
    }

    /* check for the '&optional' keyword */
    if (consp(fargs) && car(fargs) == lk_optional) {
        fargs = cdr(fargs);

        /* handle each optional argument */
        last = NIL;
        while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {

            /* get the default expression and specified-p variable */
            def = svar = NIL;
            if (consp(arg)) {
                if ((def = cdr(arg))) {
                    if (consp(def)) {
                        if ((svar = cdr(def))) {
                            if (consp(svar)) {
                                svar = car(svar);
                                if (!symbolp(svar))
                                    badarglist();
                            }
                            else
                                badarglist();
                        }
                        def = car(def);
                    }
                    else
                        badarglist();
                }
                arg = car(arg);
            }

            /* make sure the argument is a symbol */
            if (!symbolp(arg))
                badarglist();

            /* create a fully expanded optional expression */
            new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);

            /* link it into the optional argument list */
            if (last)
                rplacd(last,new);
            else
                setoargs(closure,new);
            last = new;
                
            /* move the formal argument list pointer ahead */
            fargs = cdr(fargs);
        }
    }

    /* check for the '&rest' keyword */
    if (consp(fargs) && car(fargs) == lk_rest) {
        fargs = cdr(fargs);

        /* get the &rest argument */
        if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg))
            setrest(closure,arg);
        else
            badarglist();

        /* move the formal argument list pointer ahead */
        fargs = cdr(fargs);
    }

    /* check for the '&key' keyword */
    if (consp(fargs) && car(fargs) == lk_key) {
        fargs = cdr(fargs);

         /* handle each key argument */
        last = NIL;
        while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {

            /* get the default expression and specified-p variable */
            def = svar = NIL;
            if (consp(arg)) {
                if ((def = cdr(arg))) {
                    if (consp(def)) {
                        if ((svar = cdr(def))) {
                            if (consp(svar)) {
                                svar = car(svar);
                                if (!symbolp(svar))
                                    badarglist();
                            }
                            else
                                badarglist();
                        }
                        def = car(def);
                    }
                    else
                        badarglist();
                }
                arg = car(arg);
            }

            /* get the keyword and the variable */
            if (consp(arg)) {
                key = car(arg);
                if (!symbolp(key))
                    badarglist();
                if ((arg = cdr(arg))) {
                    if (consp(arg))
                        arg = car(arg);
                    else
                        badarglist();
                }
            }
            else if (symbolp(arg)) {
                strcpy(keyname,":");
                strcat(keyname,(char *) getstring(getpname(arg)));
                key = xlenter(keyname);
            }

            /* make sure the argument is a symbol */
            if (!symbolp(arg))
                badarglist();

            /* create a fully expanded key expression */
            new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);

            /* link it into the optional argument list */
            if (last)
                rplacd(last,new);
            else
                setkargs(closure,new);
            last = new;

            /* move the formal argument list pointer ahead */
            fargs = cdr(fargs);
        }
    }

    /* check for the '&allow-other-keys' keyword */
    if (consp(fargs) && car(fargs) == lk_allow_other_keys)
        fargs = cdr(fargs);     /* this is the default anyway */

    /* check for the '&aux' keyword */
    if (consp(fargs) && car(fargs) == lk_aux) {
        fargs = cdr(fargs);

        /* handle each aux argument */
        last = NIL;
        while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {

            /* get the initial value */
            def = NIL;
            if (consp(arg)) {
                if ((def = cdr(arg))) {
                    if (consp(def))
                        def = car(def);
                    else
                        badarglist();
                }
                arg = car(arg);
            }

            /* make sure the argument is a symbol */
            if (!symbolp(arg))
                badarglist();

            /* create a fully expanded aux expression */
            new = cons(cons(arg,cons(def,NIL)),NIL);

            /* link it into the aux argument list */
            if (last)
                rplacd(last,new);
            else
                setaargs(closure,new);
            last = new;

            /* move the formal argument list pointer ahead */
            fargs = cdr(fargs);
        }
    }

    /* make sure this is the end of the formal argument list */
    if (fargs)
        badarglist();

    /* restore the stack */
    xlpop();

    /* return the new closure */
    return (closure);
}

/* xlabind - bind the arguments for a function */
void xlabind(LVAL fun, int argc, LVAL *argv)
{
    LVAL *kargv,fargs,key,arg,def,svar,p;
    int rargc,kargc;
    /* protect some pointers */
    xlsave1(def);

    /* bind each required argument */
    for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
        /* make sure there is an actual argument */
        if (--argc < 0)
            xlfail("too few arguments");
        
        /* bind the formal variable to the argument value */
        xlbind(car(fargs),*argv++);
    }

    /* bind each optional argument */
    for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {

        /* get argument, default and specified-p variable */
        p = car(fargs);
        arg = car(p); p = cdr(p);
        def = car(p); p = cdr(p);
        svar = car(p);

        /* bind the formal variable to the argument value */
        if (--argc >= 0) {
            xlbind(arg,*argv++);
            if (svar) xlbind(svar,s_true);
        }

        /* bind the formal variable to the default value */
        else {
            if (def) def = xleval(def);
            xlbind(arg,def);
            if (svar) xlbind(svar,NIL);
        }
    }

    /* save the count of the &rest of the argument list */
    rargc = argc;
    
    /* handle '&rest' argument */
    if ((arg = getrest(fun))) {
        def = makearglist(argc,argv);
        xlbind(arg,def);
        argc = 0;
    }

    /* handle '&key' arguments */
    if ((fargs = getkargs(fun))) {
        for (; fargs; fargs = cdr(fargs)) {

            /* get keyword, argument, default and specified-p variable */
            p = car(fargs);
            key = car(p); p = cdr(p);
            arg = car(p); p = cdr(p);
            def = car(p); p = cdr(p);
            svar = car(p);

            /* look for the keyword in the actual argument list */
            for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
                if (*kargv == key)
                    break;

            /* bind the formal variable to the argument value */
            if (kargc >= 0) {
                xlbind(arg,*++kargv);
                if (svar) xlbind(svar,s_true);
            }

            /* bind the formal variable to the default value */
            else {
                if (def) def = xleval(def);
                xlbind(arg,def);
                if (svar) xlbind(svar,NIL);
            }
        }
        argc = 0;
    }

    /* check for the '&aux' keyword */
    for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {

        /* get argument and default */
        p = car(fargs);
        arg = car(p); p = cdr(p);
        def = car(p);

        /* bind the auxiliary variable to the initial value */
        if (def) def = xleval(def);
        xlbind(arg,def);
    }

    /* make sure there aren't too many arguments */
    if (argc > 0)
        xlfail("too many arguments");

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

/* doenter - print trace information on function entry */
LOCAL void doenter(LVAL sym, int argc, LVAL *argv)
{
    extern int xltrcindent;
    int i;
    
    /* indent to the current trace level */
    for (i = 0; i < xltrcindent; ++i)
        trcputstr(" ");
    ++xltrcindent;

    /* display the function call */
    sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
    trcputstr(buf);
    while (--argc >= 0) {
        trcprin1(*argv++);
        if (argc) trcputstr(" ");
    }
    trcputstr(")\n");
}

/* doexit - print trace information for function/macro exit */
LOCAL void doexit(LVAL sym, LVAL val)
{
    extern int xltrcindent;
    int i;
    
    /* indent to the current trace level */
    --xltrcindent;
    for (i = 0; i < xltrcindent; ++i)
        trcputstr(" ");
    
    /* display the function value */
    sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
    trcputstr(buf);
    trcprin1(val);
    trcputstr("\n");
}

/* member - is 'x' a member of 'list'? */
LOCAL int member( LVAL x,  LVAL list)
{
    for (; consp(list); list = cdr(list))
        if (x == car(list))
            return (TRUE);
    return (FALSE);
}

/* xlunbound - signal an unbound variable error */
void xlunbound(LVAL sym)
{
    xlcerror("try evaluating symbol again","unbound variable",sym);
}

/* xlfunbound - signal an unbound function error */
void xlfunbound(LVAL sym)
{
    xlcerror("try evaluating symbol again","unbound function",sym);
}

/* xlstkoverflow - signal a stack overflow error */
void xlstkoverflow(void)
{
    xlabort("evaluation stack overflow");
}

/* xlargstkoverflow - signal an argument stack overflow error */
void xlargstkoverflow(void)
{
    xlabort("argument stack overflow");
}

/* badarglist - report a bad argument list error */
LOCAL void badarglist(void)
{
    xlfail("bad formal argument list");
}