ValuePtr
evalIf(EnvPtr env, ValuePtr statement)
{
int length = sLength(statement);
if(length == 3) {
if(sEqP(eval(env, statement->cdr()->car()), rsFalse()) == false) {
return eval(env, statement->cdr()->cdr()->car());
}
else {
return rsUndefined();
}
}
else if(length == 4) {
if(sEqP(eval(env, statement->cdr()->car()), rsFalse()) == false) {
return eval(env, statement->cdr()->cdr()->car());
}
else {
return eval(env, statement->cdr()->cdr()->cdr()->car());
}
}
else {
CHECK_FAIL("Wrong number of arguments to if");
return rsUndefined();
}
}
ValuePtr
evalOr(EnvPtr env, ValuePtr statement)
{
ValuePtr args = statement->cdr();
while(args->isNull() == false) {
ValuePtr test = eval(env, args->car());
if(!sEqP(test, rsFalse()))
return rsTrue();
args = args->cdr();
}
return rsFalse();
}
ValuePtr
sList(EnvPtr env, ValuePtr args)
{
ValuePtr result = new PairValue();
ValuePtr current = result;
while(args->isNull() == false) {
current->car() = args->car();
ValuePtr next = new PairValue();
current->cdr() = next;
current = next;
args = args->cdr();
}
return result;
}
bool
sListP(ValuePtr data)
{
while(data->isPair() && !data->isNull())
data = data->cdr();
return data->isNull();
}
ValuePtr
apply(EnvPtr env, ValuePtr procedure, ValuePtr args)
{
if(procedure->type() == Value::NATIVE_PROCEDURE) {
NativeProcedureValue* proc = static_cast<NativeProcedureValue*>(procedure.mValue);
return (*proc->mProc)(env, args);
}
else if(procedure->type() == Value::PROCEDURE) {
EnvPtr callEnvironment = new Environment;
ProcedureValue* proc = static_cast<ProcedureValue*>(procedure.mValue);
callEnvironment->parent = proc->environment;
int iParam = 0;
while(args->isNull() == false) {
if(iParam == static_cast<int>(proc->paramList.size())) {
CHECK_FAIL("Too many arguments to procedure");
}
callEnvironment->values[proc->paramList[iParam]] = args->car();
iParam++;
args = args->cdr();
}
if(iParam != static_cast<int>(proc->paramList.size())) {
CHECK_FAIL("Too few arguments to procedure");
}
return evalSequence(callEnvironment, proc->body);
}
else {
sWrite(env, new PairValue(procedure, new PairValue()));
CHECK_FAIL("Wrong type of argument to apply: not procedure");
return NULL;
}
}
ValuePtr
sAssq(EnvPtr, ValuePtr args)
{
if(sLength(args) != 2)
CHECK_FAIL("Wrong number of arguments to assq");
ValuePtr obj = args->car();
ValuePtr alist = args->cdr()->car();
while(alist->isNull() == false) {
if(alist->isPair() == false && alist->car()->isPair() == false)
CHECK_FAIL("Malformed alist");
if(sEqP(obj, alist->car()->car())) {
return alist->car();
}
alist = alist->cdr();
}
return rsFalse();
}
bool
sPureInteger(ValuePtr args)
{
while(args->isNull() == false) {
if(!(args->car()->isNumber() && args->car()->isExact())) return false;
args = args->cdr();
}
return true;
}
ValuePtr
evalStatement(EnvPtr env, ValuePtr data)
{
ValuePtr current = data;
ValuePtr call = new PairValue();
ValuePtr callCurrent = call;
while(current->isPair() && !current->isNull()) {
callCurrent->car() = eval(env, current->car());
ValuePtr newParam = new PairValue();
callCurrent->cdr() = newParam;
callCurrent = newParam;
current = current->cdr();
}
if(current->isNull() == false) {
CHECK_FAIL("Malformed statement");
return NULL;
}
return apply(env, call);
}
ValuePtr
evalLet(EnvPtr env, ValuePtr statement)
{
EnvPtr letEnv = new Environment();
letEnv->parent = env;
ValuePtr bindings = statement->cdr()->car();
CHECK("One or more expressions", sLength(statement) >= 3);
CHECK("Let bindings are a list", sListP(bindings));
while(bindings->isNull() == false) {
CHECK("Let assignment is a list", sListP(bindings->car()));
CHECK("Let assignment is a 2 item list", sLength(bindings->car()) == 2);
ValuePtr variable = bindings->car()->car();
CHECK("Assigning to a symbol", variable->isSymbol());
ValuePtr value = eval(env, bindings->car()->cdr()->car());
letEnv->values[variable->vString()] = value;
bindings = bindings->cdr();
}
return evalSequence(letEnv, statement->cdr()->cdr());
}
ValuePtr
apply(EnvPtr env, ValuePtr statement)
{
if(!sListP(statement)) {
CHECK_FAIL("Error in apply: not list");
}
ValuePtr procedure = statement->car();
ValuePtr args = statement->cdr();
return apply(env, procedure, args);
}
ValuePtr
sStringAppend(EnvPtr env, ValuePtr args)
{
ostringstream ossStream;
while(args->isNull() == false) {
if(args->car()->isString())
ossStream << args->car()->vString();
args = args->cdr();
}
return new StringValue(ossStream.str());
}
ValuePtr
sAdd(EnvPtr env, ValuePtr args)
{
ValuePtr result = new NumberValue(0);
while(args->isNull() == false) {
if(args->car()->isNumber() && args->car()->isExact())
result->vInt() += args->car()->vInt();
args = args->cdr();
}
return result;
}
// --------------------------------------------------------------------------------
ValuePtr
evalSet(EnvPtr env, ValuePtr statement)
{
if(statement->cdr()->car()->isSymbol()) {
string name = statement->cdr()->car()->vString();
EnvPtr scope = env;
while(!(scope == NULL)) {
if(scope->values.find(name) != scope->values.end()) {
scope->values[name] = eval(env, statement->cdr()->cdr()->car());
return scope->values[name];
}
scope = scope->parent;
}
CHECK_FAIL("Variable not set in any environment");
return rsUndefined();
}
else {
CHECK_FAIL("set! not used correctly");
return NULL;
}
}
int
sLength(ValuePtr data)
{
int length = 0;
ValuePtr ptr = data;
while(ptr->isNull() == false) {
if(ptr->isPair() == false) CHECK_FAIL("Malformed list to length");
length++;
ptr = ptr->cdr();
}
return length;
}
ValuePtr
sReverse(EnvPtr, ValuePtr args)
{
CHECK("Single argument to reverse", sLength(args) == 1 && sListP(args->car()));
ValuePtr current = new PairValue();
ValuePtr rList = args->car();
while(rList->isNull() == false) {
ValuePtr next = new PairValue(rList->car(), current);
current = next;
rList = rList->cdr();
}
return current;
}
ValuePtr
sMap(EnvPtr env, ValuePtr args)
{
CHECK("Only single parameter map supported", sLength(args) == 2);
ValuePtr proc = args->car();
ValuePtr list1 = args->cdr()->car();
CHECK("Valid arguments to map", (proc->isProcedure()) && sListP(list1));
ValuePtr result = new PairValue();
ValuePtr current = result;
ValuePtr argList = new PairValue(NULL, new PairValue());
while(list1->isNull() == false) {
argList->car() = list1->car();
current->car() = apply(env, proc, argList);
ValuePtr next = new PairValue();
current->cdr() = next;
current = next;
list1 = list1->cdr();
}
return result;
}
ValuePtr
evalLambda(EnvPtr env, ValuePtr paramList, ValuePtr body)
{
ProcedureValue* proc = new ProcedureValue();
proc->environment = env;
proc->body = body;
while(paramList->isNull() == false) {
if(!paramList->car()->isSymbol())
CHECK_FAIL("Non symbol in parameter list");
proc->paramList.push_back(paramList->car()->vString());
paramList = paramList->cdr();
}
return proc;
}
ValuePtr
evalSequence(EnvPtr env, ValuePtr sequence)
{
if(!sListP(sequence)) {
CHECK_FAIL("evalSequence argument not list");
}
ValuePtr result = NULL;
while(sequence->isNull() == false) {
result = eval(env, sequence->car());
sequence = sequence->cdr();
}
if(result == NULL) {
CHECK_FAIL("Trying to evaluate undefined sequence");
}
return result;
}
ValuePtr
sForEach(EnvPtr env, ValuePtr args)
{
CHECK("Only single parameter for-each supported", sLength(args) == 2);
ValuePtr proc = args->car();
ValuePtr list1 = args->cdr()->car();
CHECK("Valid arguments to foreach", (proc->isProcedure()) && sListP(list1));
ValuePtr argList = new PairValue(NULL, new PairValue());
while(list1->isNull() == false) {
argList->car() = list1->car();
apply(env, proc, argList);
list1 = list1->cdr();
}
return rsUndefined();
}
void
TestEval::eval_simple()
{
EnvPtr env = new Environment();
env->parent = NULL;
ValuePtr value;
// bool false
value = eval(env, "#f");
CHECK("Boolean false", value->isBool() && !value->vBool());
// integer
value = eval(env, "#t");
CHECK("Boolean true", value->isBool() && value->vBool());
// integer
value = eval(env, "123");
CHECK("Integer type", value->isNumber() && value->isExact());
CHECK_EQUAL("Integer content", int, 123, value->vInt());
// double
value = eval(env, "123.456");
CHECK("Float type", value->isNumber() && !value->isExact());
CHECK_EQUAL("Float content", float, 123.456, value->vFloat());
// string
value = eval(env, "\"foobar\"");
CHECK("String type", value->isString());
CHECK_EQUAL("string content", string, "foobar", value->vString());
// Symbol
ValuePtr intValue = new NumberValue(10);
env->values["foo_symbol!"] = intValue;
value = eval(env, "foo_symbol!");
CHECK("Symbol lookup", intValue == value);
// Quote
value = eval(env, "'(foo)");
CHECK("Pair type", value->isPair());
CHECK("Empty list type", value->cdr()->isNull());
CHECK("Symbol type", value->car()->isSymbol());
CHECK_EQUAL("Symbol value", string, "foo", value->car()->vString());
}
ValuePtr
evalDefine(EnvPtr env, ValuePtr statement)
{
if(!(env->parent == NULL)) {
CHECK_FAIL("You can only use defines at the top level");
}
if(statement->cdr()->car()->isSymbol()) {
string name = statement->cdr()->car()->vString();
env->values[name] = eval(env, statement->cdr()->cdr()->car());
// FIXME: Should return undefined instead ..
return env->values[name];
}
else if(statement->cdr()->car()->isPair()) {
if(!statement->cdr()->car()->car()->isSymbol())
CHECK_FAIL("First token should be symbol for function define");
string name = statement->cdr()->car()->car()->vString();
env->values[name] = evalLambda(env, statement->cdr()->car()->cdr(), statement->cdr()->cdr());
return env->values[name];
}
else {
CHECK_FAIL("unknown first parameter to define");
return rsUndefined();
}
}
ValuePtr eEqP(EnvPtr, ValuePtr param) {return new BoolValue(sEqP(param->car(), param->cdr()->car()));}
ValuePtr
sApply(EnvPtr env, ValuePtr args)
{
CHECK("Two parameters required", sLength(args) == 2);
return apply(env, args->car(), args->cdr()->car());
}
ValuePtr
sSetCdr(EnvPtr env, ValuePtr args)
{
args->car()->cdr() = args->cdr()->car();
return rsUndefined();
}
ValuePtr
eval(EnvPtr env, ValuePtr data)
{
// Self evaluating
if(data->isBool() ||
data->isNumber() ||
data->isString()) {
return data;
}
// Symbols
else if(data->isSymbol()) {
EnvPtr current = env;
while(!(NULL == current)) {
if(current->values.find(data->vString()) != current->values.end()) {
return current->values[data->vString()];
}
current = current->parent;
}
CHECK_FAIL(string("Trying to access unknown symbol: ") + data->vString());
}
// Lists
else if(data->isPair()) {
if(!sListP(data)) {
CHECK_FAIL("Unable to evaluate non-lists");
return rsUndefined();
}
// ----------------------------------------
// Check for special forms
if(data->car()->isSymbol()) {
// ----------------------------------------
// Quote
if(data->car()->vString() == string("quote")) {
if(data->cdr()->isPair() &&
data->cdr()->cdr()->isNull())
return data->cdr()->car();
else
CHECK_FAIL("Quote error");
}
// ----------------------------------------
// Lambda
else if(data->car()->vString() == string("lambda")) {
if(sListP(data->cdr()->car())) {
return evalLambda(env, data->cdr()->car(), data->cdr()->cdr());
}
else {
CHECK_FAIL("Malformed lambda parameter sequence");
return rsUndefined();
}
}
// ----------------------------------------
// Definitions: define, set!
else if(data->car()->vString() == string("define")) {
return evalDefine(env, data);
}
else if(data->car()->vString() == string("set!")) {
return evalSet(env, data);
}
// ----------------------------------------
// Conditionals and boolean: if, cond
else if(data->car()->vString() == string("if")) {
return evalIf(env, data);
}
else if(data->car()->vString() == string("cond")) {
return evalCond(env, data);
}
else if(data->car()->vString() == string("and")) {
return evalAnd(env, data);
}
else if(data->car()->vString() == string("or")) {
return evalOr(env, data);
}
// ----------------------------------------
// Binding constructs
else if(data->car()->vString() == string("let")) {
return evalLet(env, data);
}
// ----------------------------------------
// Sequencing
else if(data->car()->vString() == string("begin")) {
return evalSequence(env, data->cdr());
}
}
// Ok, standard statement
return evalStatement(env, data);
}
else {
CHECK_FAIL("Trying to evaluate unknown type");
}
CHECK_FAIL("Eval error, this should never be reachable");
return rsUndefined();
}
ValuePtr
sCons(EnvPtr env, ValuePtr args)
{
CHECK("Number of arguments is 2", sLength(args) == 2);
return new PairValue(args->car(), args->cdr()->car());
}
