mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* Primops (not yet finished).

Browse source
This commit is contained in:
Eelco Dolstra 2010-03-26 15:45:53 +00:00
parent cad8726b2c
commit 45d822f29c
1 changed files with 114 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

130
src/libexpr/eval-test.cc
View file

@ -32,10 +32,15 @@ typedef enum {
tThunk,
tLambda,
tCopy,
tBlackhole
tBlackhole,
tPrimOp,
tPrimOpApp,
} ValueType;
typedef void (* PrimOp_) (Value * * args, Value & v);
struct Value
{
ValueType type;
@ -58,6 +63,14 @@ struct Value
Expr body;
} lambda;
Value * val;
struct {
PrimOp_ fun;
unsigned int arity;
} primOp;
struct {
Value * left, * right;
unsigned int argsLeft;
} primOpApp;
};
};
@ -89,6 +102,12 @@ std::ostream & operator << (std::ostream & str, Value & v)
case tLambda:
str << "<LAMBDA>";
break;
case tPrimOp:
str << "<PRIMOP>";
break;
case tPrimOpApp:
str << "<PRIMOP-APP>";
break;
default:
abort();
}
@ -96,14 +115,14 @@ std::ostream & operator << (std::ostream & str, Value & v)
}
static void eval(Env * env, Expr e, Value & v);
static void eval(Env & env, Expr e, Value & v);
static void forceValue(Value & v)
{
if (v.type == tThunk) {
v.type = tBlackhole;
eval(v.thunk.env, v.thunk.expr, v);
eval(*v.thunk.env, v.thunk.expr, v);
}
else if (v.type == tCopy) {
forceValue(*v.val);
@ -208,7 +227,7 @@ static Env * allocEnv()
char * p1 = 0, * p2 = 0;
static void eval(Env * env, Expr e, Value & v)
static void eval(Env & env, Expr e, Value & v)
{
char c;
if (!p1) p1 = &c; else if (!p2) p2 = &c;
@ -217,7 +236,7 @@ static void eval(Env * env, Expr e, Value & v)
Sym name;
if (matchVar(e, name)) {
Value * v2 = lookupVar(env, name);
Value * v2 = lookupVar(&env, name);
forceValue(*v2);
v = *v2;
return;
@ -240,7 +259,7 @@ static void eval(Env * env, Expr e, Value & v)
Value & v2 = (*v.attrs)[name];
nrValues++;
v2.type = tThunk;
v2.thunk.env = env;
v2.thunk.env = &env;
v2.thunk.expr = e2;
}
return;
@ -249,7 +268,7 @@ static void eval(Env * env, Expr e, Value & v)
ATermList rbnds, nrbnds;
if (matchRec(e, rbnds, nrbnds)) {
Env * env2 = allocEnv();
env2->up = env;
env2->up = &env;
v.type = tAttrs;
v.attrs = &env2->bindings;
@ -280,7 +299,7 @@ static void eval(Env * env, Expr e, Value & v)
Pattern pat; Expr body; Pos pos;
if (matchFunction(e, pat, body, pos)) {
v.type = tLambda;
v.lambda.env = env;
v.lambda.env = &env;
v.lambda.pat = pat;
v.lambda.body = body;
return;
@ -289,17 +308,47 @@ static void eval(Env * env, Expr e, Value & v)
Expr fun, arg;
if (matchCall(e, fun, arg)) {
eval(env, fun, v);
if (v.type == tPrimOp || v.type == tPrimOpApp) {
if ((v.type == tPrimOp && v.primOp.arity == 1) ||
(v.type == tPrimOpApp && v.primOpApp.argsLeft == 1))
{
/* We have all the arguments, so call the primop.
First find the primop. */
Value * primOp = &v;
while (primOp->type == tPrimOpApp) primOp = primOp->primOpApp.left;
assert(primOp->type == tPrimOp);
unsigned int arity = primOp->primOp.arity;
Value vLastArg;
vLastArg.type = tThunk;
vLastArg.thunk.env = &env;
vLastArg.thunk.expr = arg;
Value * vArgs[arity];
unsigned int n = arity - 1;
vArgs[n--] = &vLastArg;
for (Value * arg = &v; arg->type == tPrimOpApp; arg = arg->primOpApp.left)
vArgs[n--] = arg->primOpApp.right;
primOp->primOp.fun(vArgs, v);
} else {
throw Error("bar");
}
return;
}
if (v.type != tLambda) throw TypeError("expected function");
Env * env2 = allocEnv();
env2->up = env;
env2->up = &env;
ATermList formals; ATerm ellipsis;
if (matchVarPat(v.lambda.pat, name)) {
Value & vArg = env2->bindings[name];
vArg.type = tThunk;
vArg.thunk.env = env;
vArg.thunk.env = &env;
vArg.thunk.expr = arg;
}
@ -352,20 +401,20 @@ static void eval(Env * env, Expr e, Value & v)
else abort();
eval(env2, v.lambda.body, v);
eval(*env2, v.lambda.body, v);
return;
}
Expr attrs;
if (matchWith(e, attrs, body, pos)) {
Env * env2 = allocEnv();
env2->up = env;
env2->up = &env;
Value & vAttrs = env2->bindings[sWith];
eval(env, attrs, vAttrs);
if (vAttrs.type != tAttrs) throw TypeError("`with' should evaluate to an attribute set");
eval(env2, body, v);
eval(*env2, body, v);
return;
}
@ -375,7 +424,7 @@ static void eval(Env * env, Expr e, Value & v)
v.list.elems = new Value[v.list.length]; // !!! check destructor
for (unsigned int n = 0; n < v.list.length; ++n, es = ATgetNext(es)) {
v.list.elems[n].type = tThunk;
v.list.elems[n].thunk.env = env;
v.list.elems[n].thunk.env = &env;
v.list.elems[n].thunk.expr = ATgetFirst(es);
}
return;
@ -416,7 +465,7 @@ static void eval(Env * env, Expr e, Value & v)
}
static void strictEval(Env * env, Expr e, Value & v)
static void strictEval(Env & env, Expr e, Value & v)
{
eval(env, e, v);
@ -432,14 +481,59 @@ static void strictEval(Env * env, Expr e, Value & v)
}
static void prim_head(Value * * args, Value & v)
{
forceValue(*args[0]);
if (args[0]->type != tList) throw TypeError("list expected");
if (args[0]->list.length == 0)
throw Error("`head' called on an empty list");
forceValue(args[0]->list.elems[0]);
v = args[0]->list.elems[0];
}
static void prim_add(Value * * args, Value & v)
{
throw Error("foo");
}
static void addPrimOp(Env & env, const string & name, unsigned int arity, PrimOp_ fun)
{
Value & v = env.bindings[toATerm(name)];
v.type = tPrimOp;
v.primOp.arity = arity;
v.primOp.fun = fun;
}
void doTest(string s)
{
Env baseEnv;
baseEnv.up = 0;
/* Add global constants such as `true' to the base environment. */
{
Value & v = baseEnv.bindings[toATerm("true")];
v.type = tBool;
v.boolean = true;
}
{
Value & v = baseEnv.bindings[toATerm("false")];
v.type = tBool;
v.boolean = false;
}
/* Add primops to the base environment. */
addPrimOp(baseEnv, "__head", 1, prim_head);
addPrimOp(baseEnv, "__add", 2, prim_add);
p1 = p2 = 0;
EvalState state;
Expr e = parseExprFromString(state, s, "/");
printMsg(lvlError, format(">>>>> %1%") % e);
Value v;
strictEval(0, e, v);
strictEval(baseEnv, e, v);
printMsg(lvlError, format("result: %1%") % v);
}
@ -478,6 +572,10 @@ void run(Strings args)
doTest("{ x = 1; y = 2; } == { x = 2; }");
doTest("{ x = [ 1 2 ]; } == { x = [ 1 ] ++ [ 2 ]; }");
doTest("1 != 1");
doTest("true");
doTest("true == false");
doTest("__head [ 1 2 3 ]");
doTest("__add 1 2");
printMsg(lvlError, format("alloced %1% values") % nrValues);
printMsg(lvlError, format("alloced %1% environments") % nrEnvs);