/* xcomplement - create a complementary function */
LVAL xcomplement(V)
{
LVAL val;
LVAL args, body;
LVAL newxlenv;
/* protect some pointers */
xlstkcheck(3);
xlsave(newxlenv);
xlsave(args);
xlsave(body);
/* get the argument */
val = xlgetarg();
xllastarg();
/* build the argument list (&rest x) */
args = cons(lk_rest, consa(s_x));
/* build body (not (apply s x)) */
body = consa(cons(s_not, consa(cons(s_apply, cons(s_s, consa(s_x))))));
/* create a closure for lambda expressions */
newxlenv = xlframe(newxlenv);
xlpbind(s_s, val, newxlenv);
val = xlclose(NIL,s_lambda,args,body,newxlenv,NIL);
/* unprotect pointers */
xlpopn(3);
/* return the function */
return (val);
}
/* evmethod - evaluate a method */
LOCAL LVAL evmethod(LVAL obj, LVAL msgcls, LVAL method)
{
LVAL oldenv,oldfenv,cptr,name,val=NULL;
XLCONTEXT cntxt;
/* protect some pointers */
xlstkcheck(3);
xlsave(oldenv);
xlsave(oldfenv);
xlsave(cptr);
/* create an 'object' stack entry and a new environment frame */
oldenv = xlenv;
oldfenv = xlfenv;
xlenv = cons(cons(obj,msgcls),closure_getenv(method));
xlenv = xlframe(xlenv);
xlfenv = getfenv(method);
/* bind the formal parameters */
xlabind(method,xlargc,xlargv);
/* setup the implicit block */
if ((name = getname(method)))
xlbegin(&cntxt,CF_RETURN,name);
/* execute the block */
if (name && _setjmp(cntxt.c_jmpbuf))
val = xlvalue;
else
for (cptr = getbody(method); 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(3);
/* return the result value */
return (val);
}
/* evfun - evaluate a function */
LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv)
{
LVAL oldenv,oldfenv,cptr,name,val;
XLCONTEXT cntxt;
/* protect some pointers */
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);
}
