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, tThunk,
tLambda, tLambda,
tCopy, tCopy,
tBlackhole tBlackhole,
tPrimOp,
tPrimOpApp,
} ValueType; } ValueType;
typedef void (* PrimOp_) (Value * * args, Value & v);
struct Value struct Value
{ {
ValueType type; ValueType type;
@ -58,6 +63,14 @@ struct Value
Expr body; Expr body;
} lambda; } lambda;
Value * val; 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: case tLambda:
str << "<LAMBDA>"; str << "<LAMBDA>";
break; break;
case tPrimOp:
str << "<PRIMOP>";
break;
case tPrimOpApp:
str << "<PRIMOP-APP>";
break;
default: default:
abort(); 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) static void forceValue(Value & v)
{ {
if (v.type == tThunk) { if (v.type == tThunk) {
v.type = tBlackhole; v.type = tBlackhole;
eval(v.thunk.env, v.thunk.expr, v); eval(*v.thunk.env, v.thunk.expr, v);
} }
else if (v.type == tCopy) { else if (v.type == tCopy) {
forceValue(*v.val); forceValue(*v.val);
@ -208,7 +227,7 @@ static Env * allocEnv()
char * p1 = 0, * p2 = 0; 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; char c;
if (!p1) p1 = &c; else if (!p2) p2 = &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; Sym name;
if (matchVar(e, name)) { if (matchVar(e, name)) {
Value * v2 = lookupVar(env, name); Value * v2 = lookupVar(&env, name);
forceValue(*v2); forceValue(*v2);
v = *v2; v = *v2;
return; return;
@ -240,7 +259,7 @@ static void eval(Env * env, Expr e, Value & v)
Value & v2 = (*v.attrs)[name]; Value & v2 = (*v.attrs)[name];
nrValues++; nrValues++;
v2.type = tThunk; v2.type = tThunk;
v2.thunk.env = env; v2.thunk.env = &env;
v2.thunk.expr = e2; v2.thunk.expr = e2;
} }
return; return;
@ -249,7 +268,7 @@ static void eval(Env * env, Expr e, Value & v)
ATermList rbnds, nrbnds; ATermList rbnds, nrbnds;
if (matchRec(e, rbnds, nrbnds)) { if (matchRec(e, rbnds, nrbnds)) {
Env * env2 = allocEnv(); Env * env2 = allocEnv();
env2->up = env; env2->up = &env;
v.type = tAttrs; v.type = tAttrs;
v.attrs = &env2->bindings; v.attrs = &env2->bindings;
@ -280,7 +299,7 @@ static void eval(Env * env, Expr e, Value & v)
Pattern pat; Expr body; Pos pos; Pattern pat; Expr body; Pos pos;
if (matchFunction(e, pat, body, pos)) { if (matchFunction(e, pat, body, pos)) {
v.type = tLambda; v.type = tLambda;
v.lambda.env = env; v.lambda.env = &env;
v.lambda.pat = pat; v.lambda.pat = pat;
v.lambda.body = body; v.lambda.body = body;
return; return;
@ -289,17 +308,47 @@ static void eval(Env * env, Expr e, Value & v)
Expr fun, arg; Expr fun, arg;
if (matchCall(e, fun, arg)) { if (matchCall(e, fun, arg)) {
eval(env, fun, v); 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"); if (v.type != tLambda) throw TypeError("expected function");
Env * env2 = allocEnv(); Env * env2 = allocEnv();
env2->up = env; env2->up = &env;
ATermList formals; ATerm ellipsis; ATermList formals; ATerm ellipsis;
if (matchVarPat(v.lambda.pat, name)) { if (matchVarPat(v.lambda.pat, name)) {
Value & vArg = env2->bindings[name]; Value & vArg = env2->bindings[name];
vArg.type = tThunk; vArg.type = tThunk;
vArg.thunk.env = env; vArg.thunk.env = &env;
vArg.thunk.expr = arg; vArg.thunk.expr = arg;
} }
@ -352,20 +401,20 @@ static void eval(Env * env, Expr e, Value & v)
else abort(); else abort();
eval(env2, v.lambda.body, v); eval(*env2, v.lambda.body, v);
return; return;
} }
Expr attrs; Expr attrs;
if (matchWith(e, attrs, body, pos)) { if (matchWith(e, attrs, body, pos)) {
Env * env2 = allocEnv(); Env * env2 = allocEnv();
env2->up = env; env2->up = &env;
Value & vAttrs = env2->bindings[sWith]; Value & vAttrs = env2->bindings[sWith];
eval(env, attrs, vAttrs); eval(env, attrs, vAttrs);
if (vAttrs.type != tAttrs) throw TypeError("`with' should evaluate to an attribute set"); if (vAttrs.type != tAttrs) throw TypeError("`with' should evaluate to an attribute set");
eval(env2, body, v); eval(*env2, body, v);
return; return;
} }
@ -375,7 +424,7 @@ static void eval(Env * env, Expr e, Value & v)
v.list.elems = new Value[v.list.length]; // !!! check destructor v.list.elems = new Value[v.list.length]; // !!! check destructor
for (unsigned int n = 0; n < v.list.length; ++n, es = ATgetNext(es)) { for (unsigned int n = 0; n < v.list.length; ++n, es = ATgetNext(es)) {
v.list.elems[n].type = tThunk; 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); v.list.elems[n].thunk.expr = ATgetFirst(es);
} }
return; 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); 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) 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; p1 = p2 = 0;
EvalState state; EvalState state;
Expr e = parseExprFromString(state, s, "/"); Expr e = parseExprFromString(state, s, "/");
printMsg(lvlError, format(">>>>> %1%") % e); printMsg(lvlError, format(">>>>> %1%") % e);
Value v; Value v;
strictEval(0, e, v); strictEval(baseEnv, e, v);
printMsg(lvlError, format("result: %1%") % 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; y = 2; } == { x = 2; }");
doTest("{ x = [ 1 2 ]; } == { x = [ 1 ] ++ [ 2 ]; }"); doTest("{ x = [ 1 2 ]; } == { x = [ 1 ] ++ [ 2 ]; }");
doTest("1 != 1"); 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% values") % nrValues);
printMsg(lvlError, format("alloced %1% environments") % nrEnvs); printMsg(lvlError, format("alloced %1% environments") % nrEnvs);