static Obj *apply_func(void *root, Obj **env, Obj **fn, Obj **args) {
DEFINE3(params, newenv, body);
*params = (*fn)->params;
*newenv = (*fn)->env;
*newenv = push_env(root, newenv, params, args);
*body = (*fn)->body;
return progn(root, newenv, body);
}
// (if expr expr expr ...)
static Obj *prim_if(void *root, Obj **env, Obj **list) {
if (length(*list) < 2)
error("Malformed if");
DEFINE3(cond, then, els);
*cond = (*list)->car;
*cond = eval(root, env, cond);
if (*cond != Nil) {
*then = (*list)->cdr->car;
return eval(root, env, then);
}
*els = (*list)->cdr->cdr;
return *els == Nil ? Nil : progn(root, env, els);
}
Obj *prim_if(Env *env, Obj *root, Obj **list) {
int len = list_length(*list);
if (len < 2)
error("malformed if");
VAR(cond);
VAR(then);
VAR(els);
*cond = (*list)->car;
*then = (*list)->cdr->car;
*cond = eval(env, root, cond);
if (len == 2)
return *cond != Nil ? eval(env, root, then) : Nil;
*els = (*list)->cdr->cdr;
return *cond != Nil
? eval(env, root, then)
: progn(env, root, els);
}
Obj *macroexpand(Env *env, Obj *root, Obj **obj) {
if ((*obj)->type != TCELL || (*obj)->car->type != TSYMBOL)
return *obj;
VAR(macro);
VAR(args);
VAR(body);
VAR(params);
*macro = find((*obj)->car->name, env);
if (!*macro)
return *obj;
*macro = (*macro)->cdr;
if ((*macro)->type != TMACRO)
return *obj;
*args = (*obj)->cdr;
*body = (*macro)->body;
*params = (*macro)->params;
Env newenv;
add_env(env, root, &newenv, params, args);
return progn(&newenv, root, body);
}
Obj *apply(Env *env, Obj *root, Obj **fn, Obj **args) {
if ((*fn)->type == TPRIMITIVE) {
if ((*args) != Nil && (*args)->type != TCELL)
error("argument must be a list");
return (*fn)->fn(env, root, args);
}
if ((*fn)->type == TFUNCTION) {
VAR(body);
VAR(params);
VAR(eargs);
*body = (*fn)->body;
*params = (*fn)->params;
Env newenv;
*eargs = eval_list(env, root, args);
add_env(env, root, &newenv, params, eargs);
return progn(&newenv, root, body);
}
error("not supported");
return NULL;
}
LISPTR apply(LISPTR f, LISPTR args)
{
if (symbolp(f)) {
// get the function binding of f
f = symbol_function(f);
if (consp(f)) {
// function defined as S-expr
if (car(f) == LAMBDA) {
LISPTR oldBindings = lexvars;
// bind formal arguments to evaluated actual arguments:
lexvars = bind_args(cadr(f), args, lexvars);
f = progn(cddr(f));
lexvars = oldBindings;
}
} else if (compiled_function_p(f)) {
// call compiled function with args
f = call_compiled_fn(f, args);
}
}
return f;
}
static void
progclose(Chan *c)
{
int i;
Prog *f;
Osenv *o;
Progctl *ctl;
switch(QID(c->qid)) {
case Qns:
case Qheap:
free(c->aux);
break;
case Qdbgctl:
if((c->flag & COPEN) == 0)
return;
ctl = c->aux;
acquire();
closedbgctl(ctl, progpid(PID(c->qid)));
release();
break;
case Qwait:
acquire();
i = 0;
for(;;) {
f = progn(i++);
if(f == nil)
break;
o = f->osenv;
if(o->waitq == c->aux)
o->waitq = nil;
if(o->childq == c->aux)
o->childq = nil;
}
release();
qfree(c->aux);
}
}
static int
proggen(Chan *c, char *name, Dirtab *tab, int ntab, int s, Dir *dp)
{
Qid qid;
Prog *p;
char *e;
Osenv *o;
ulong pid, path, perm, len;
USED(ntab);
if(s == DEVDOTDOT){
mkqid(&qid, Qdir, 0, QTDIR);
devdir(c, qid, "#p", 0, eve, DMDIR|0555, dp);
return 1;
}
if((ulong)c->qid.path == Qdir) {
if(name != nil){
/* ignore s and use name to find pid */
pid = strtoul(name, &e, 0);
if(pid == 0 || *e != '\0')
return -1;
acquire();
p = progpid(pid);
if(p == nil){
release();
return -1;
}
}else{
acquire();
p = progn(s);
if(p == nil) {
release();
return -1;
}
pid = p->pid;
}
o = p->osenv;
sprint(up->genbuf, "%lud", pid);
if(name != nil && strcmp(name, up->genbuf) != 0){
release();
return -1;
}
mkqid(&qid, pid<<QSHIFT, pid, QTDIR);
devdir(c, qid, up->genbuf, 0, o->user, DMDIR|0555, dp);
release();
return 1;
}
if(s >= nelem(progdir))
return -1;
tab = &progdir[s];
path = PATH(c->qid);
acquire();
p = progpid(PID(c->qid));
if(p == nil) {
release();
return -1;
}
o = p->osenv;
perm = tab->perm;
if((perm & 7) == 0)
perm = (perm|(perm>>3)|(perm>>6)) & o->pgrp->progmode;
len = tab->length;
mkqid(&qid, path|tab->qid.path, c->qid.vers, QTFILE);
devdir(c, qid, tab->name, len, o->user, perm, dp);
release();
return 1;
}
.5 -.5 -.5 # 1 \n\
.5 .5 -.5 # 2 \n\
-.5 .5 -.5 # 3 \n\
-.5 -.5 .5 # 4 \n\
.5 -.5 .5 # 5 \n\
.5 .5 .5 # 6 \n\
-.5 .5 .5 # 7 \n\
\n\
4 0 1 2 3\n\
4 4 5 6 7\n\
4 2 3 7 6\n\
4 0 1 5 4\n\
4 0 4 7 3\n\
4 1 2 6 5\n";
progn()
{
printf("(progn\n");
}
endprogn()
{
printf(")\n");
fflush(stdout);
}
Initialize()
{
extern LObject *Lpick(); /* This is defined by PICKFUNC below but must */
/* be used in the following LDefun() call */
LInit();
