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");}