xlcont.c

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

/* xlcont - xlisp special forms */
/*	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
 */


#include "xlisp.h"

/* external variables */
extern LVAL xlvalue;
extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
extern LVAL s_svalue,s_sfunction,s_splist;
extern LVAL s_lambda,s_macro;

/* forward declarations */
FORWARD LOCAL LVAL bquote1(LVAL expr);
FORWARD LOCAL void placeform(LVAL place, LVAL value);
FORWARD LOCAL LVAL let(int pflag);
FORWARD LOCAL LVAL flet(LVAL type, int letflag);
FORWARD LOCAL LVAL prog(int pflag);
FORWARD LOCAL LVAL progx(int n);
FORWARD LOCAL LVAL doloop(int pflag);
FORWARD LOCAL LVAL evarg(LVAL *pargs);
FORWARD LOCAL LVAL match(int type, LVAL *pargs);
FORWARD LOCAL LVAL evmatch(int type, LVAL *pargs);
FORWARD LOCAL void toofew(LVAL args);
FORWARD LOCAL void toomany(LVAL args);
FORWARD LOCAL void setffunction(LVAL fun, LVAL place, LVAL value);
FORWARD LOCAL int keypresent(LVAL key, LVAL list);
FORWARD LOCAL void dobindings(LVAL list, LVAL env);
FORWARD LOCAL void tagbody(void);
FORWARD LOCAL void doupdates(LVAL list, int pflag);


/* dummy node type for a list */
#define LIST	-1

/* xquote - special form 'quote' */
LVAL xquote(void)
{
    LVAL val;
    val = xlgetarg();
    xllastarg();
    return (val);
}

/* xfunction - special form 'function' */
LVAL xfunction(void)
{
    LVAL val;

    /* get the argument */
    val = xlgetarg();
    xllastarg();

    /* create a closure for lambda expressions */
    if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
        val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);

    /* otherwise, get the value of a symbol */
    else if (symbolp(val))
        val = xlgetfunction(val);

    /* otherwise, its an error */
    else
        xlerror("not a function",val);

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

/* xbquote - back quote special form */
LVAL xbquote(void)
{
    LVAL expr;

    /* get the expression */
    expr = xlgetarg();
    xllastarg();

    /* fill in the template */
    return (bquote1(expr));
}

/* bquote1 - back quote helper function */
LOCAL LVAL bquote1(LVAL expr)
{
    LVAL val,list,last,new;

    /* handle atoms */
    if (atomp(expr))
        val = expr;

    /* handle (comma <expr>) */
    else if (car(expr) == s_comma) {
        if (atomp(cdr(expr)))
            xlfail("bad comma expression");
        val = xleval(car(cdr(expr)));
    }

    /* handle ((comma-at <expr>) ... ) */
    else if (consp(car(expr)) && car(car(expr)) == s_comat) {
        xlstkcheck(2);
        xlsave(list);
        xlsave(val);
        if (atomp(cdr(car(expr))))
            xlfail("bad comma-at expression");
        list = xleval(car(cdr(car(expr))));
        for (last = NIL; consp(list); list = cdr(list)) {
            new = consa(car(list));
            if (last)
                rplacd(last,new);
            else
                val = new;
            last = new;
        }
        if (last)
            rplacd(last,bquote1(cdr(expr)));
        else
            val = bquote1(cdr(expr));
        xlpopn(2);
    }

    /* handle any other list */
    else {
        xlsave1(val);
        val = consa(NIL);
        rplaca(val,bquote1(car(expr)));
        rplacd(val,bquote1(cdr(expr)));
        xlpop();
    }

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

/* xlambda - special form 'lambda' */
LVAL xlambda(void)
{
    LVAL fargs,arglist,val;

    /* get the formal argument list and function body */
    xlsave1(arglist);
    fargs = xlgalist();
    arglist = makearglist(xlargc,xlargv);

    /* create a new function definition */
    val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);

    /* restore the stack and return the closure */
    xlpop();
    return (val);
}

/* xgetlambda - get the lambda expression associated with a closure */
LVAL xgetlambda(void)
{
    LVAL closure;
    closure = xlgaclosure();
    return (cons(gettype(closure),
                 cons(getlambda(closure),getbody(closure))));
}

/* xsetq - special form 'setq' */
LVAL xsetq(void)
{
    LVAL sym,val;

    /* handle each pair of arguments */
    for (val = NIL; moreargs(); ) {
        sym = xlgasymbol();
        val = xleval(nextarg());
        xlsetvalue(sym,val);
    }

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

/* xpsetq - special form 'psetq' */
LVAL xpsetq(void)
{
    LVAL plist,sym,val;

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

    /* handle each pair of arguments */
    for (val = NIL; moreargs(); ) {
        sym = xlgasymbol();
        val = xleval(nextarg());
        plist = cons(cons(sym,val),plist);
    }

    /* do parallel sets */
    for (; plist; plist = cdr(plist))
        xlsetvalue(car(car(plist)),cdr(car(plist)));

    /* restore the stack */
    xlpop();

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

/* xsetf - special form 'setf' */
LVAL xsetf(void)
{
    LVAL place,value;

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

    /* handle each pair of arguments */
    while (moreargs()) {

        /* get place and value */
        place = xlgetarg();
        value = xleval(nextarg());

        /* expand macros in the place form */
        if (consp(place))
            place = xlexpandmacros(place);
        
        /* check the place form */
        if (symbolp(place))
            xlsetvalue(place,value);
        else if (consp(place))
            placeform(place,value);
        else
            xlfail("bad place form");
    }

    /* restore the stack */
    xlpop();

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

/* placeform - handle a place form other than a symbol */
LOCAL void placeform(LVAL place, LVAL value)
{
    LVAL fun,arg1,arg2;
    int i;

    /* check the function name */
    if ((fun = match(SYMBOL,&place)) == s_get) {
        xlstkcheck(2);
        xlsave(arg1);
        xlsave(arg2);
        arg1 = evmatch(SYMBOL,&place);
        arg2 = evmatch(SYMBOL,&place);
        if (place) toomany(place);
        xlputprop(arg1,value,arg2);
        xlpopn(2);
    }
    else if (fun == s_svalue) {
        arg1 = evmatch(SYMBOL,&place);
        if (place) toomany(place);
        setvalue(arg1,value);
    }
    else if (fun == s_sfunction) {
        arg1 = evmatch(SYMBOL,&place);
        if (place) toomany(place);
        setfunction(arg1,value);
    }
    else if (fun == s_splist) {
        arg1 = evmatch(SYMBOL,&place);
        if (place) toomany(place);
        setplist(arg1,value);
    }
    else if (fun == s_car) {
        arg1 = evmatch(CONS,&place);
        if (place) toomany(place);
        rplaca(arg1,value);
    }
    else if (fun == s_cdr) {
        arg1 = evmatch(CONS,&place);
        if (place) toomany(place);
        rplacd(arg1,value);
    }
    else if (fun == s_nth) {
        xlsave1(arg1);
        arg1 = evmatch(FIXNUM,&place);
        arg2 = evmatch(LIST,&place);
        if (place) toomany(place);
        for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
            arg2 = cdr(arg2);
        if (consp(arg2))
            rplaca(arg2,value);
        xlpop();
    }
    else if (fun == s_aref) {
        xlsave1(arg1);
        arg1 = evmatch(VECTOR,&place);
        arg2 = evmatch(FIXNUM,&place); i = (int)getfixnum(arg2);
        if (place) toomany(place);
        if (i < 0 || i >= getsize(arg1))
            xlerror("index out of range",arg2);
        setelement(arg1,i,value);
        xlpop();
    }
    else if ((fun = xlgetprop(fun,s_setf)))
        setffunction(fun,place,value);
    else
        xlfail("bad place form");
}

/* setffunction - call a user defined setf function */
LOCAL void setffunction(LVAL fun, LVAL place, LVAL value)
{
    LVAL *newfp;
    int argc;

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

    /* push the values of all of the place expressions and the new value */
    for (argc = 1; consp(place); place = cdr(place), ++argc)
        pusharg(xleval(car(place)));
    pusharg(value);

    /* insert the argument count and establish the call frame */
    newfp[2] = cvfixnum((FIXTYPE)argc);
    xlfp = newfp;

    /* apply the function */
    xlapply(argc);
}
                       
/* xdefun - special form 'defun' */
LVAL xdefun(void)
{
    LVAL sym,fargs,arglist;

    /* get the function symbol and formal argument list */
    xlsave1(arglist);
    sym = xlgasymbol();
    fargs = xlgalist();
    arglist = makearglist(xlargc,xlargv);

    /* make the symbol point to a new function definition */
    xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));

    /* restore the stack and return the function symbol */
    xlpop();
    return (sym);
}

/* xdefmacro - special form 'defmacro' */
LVAL xdefmacro(void)
{
    LVAL sym,fargs,arglist;

    /* get the function symbol and formal argument list */
    xlsave1(arglist);
    sym = xlgasymbol();
    fargs = xlgalist();
    arglist = makearglist(xlargc,xlargv);

    /* make the symbol point to a new function definition */
    xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));

    /* restore the stack and return the function symbol */
    xlpop();
    return (sym);
}

/* xcond - special form 'cond' */
LVAL xcond(void)
{
    LVAL list,val;

    /* find a predicate that is true */
    for (val = NIL; moreargs(); ) {

        /* get the next conditional */
        list = nextarg();

        /* evaluate the predicate part */
        if (consp(list) && (val = xleval(car(list)))) {

            /* evaluate each expression */
            for (list = cdr(list); consp(list); list = cdr(list))
                val = xleval(car(list));

            /* exit the loop */
            break;
        }
    }

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

/* xwhen - special form 'when' */
LVAL xwhen(void)
{
    LVAL val;

    /* check the test expression */
    if ((val = xleval(xlgetarg())))
        while (moreargs())
            val = xleval(nextarg());

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

/* xunless - special form 'unless' */
LVAL xunless(void)
{
    LVAL val=NIL;

    /* check the test expression */
    if (xleval(xlgetarg()) == NIL)
        while (moreargs())
            val = xleval(nextarg());

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

/* xcase - special form 'case' */
LVAL xcase(void)
{
    LVAL key,list,cases,val;

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

    /* get the key expression */
    key = xleval(nextarg());

    /* find a case that matches */
    for (val = NIL; moreargs(); ) {

        /* get the next case clause */
        list = nextarg();

        /* make sure this is a valid clause */
        if (consp(list)) {

            /* compare the key list against the key */
            if ((cases = car(list)) == s_true ||
                (listp(cases) && keypresent(key,cases)) ||
                eql(key,cases)) {

                /* evaluate each expression */
                for (list = cdr(list); consp(list); list = cdr(list))
                    val = xleval(car(list));

                /* exit the loop */
                break;
            }
        }
        else
            xlerror("bad case clause",list);
    }

    /* restore the stack */
    xlpop();

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