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;
}
}
sExpression *apply(sExpression *procOrLambda, sExpression *argument, sEnvironment *env){
if(isPrimitiveProc(procOrLambda))
{
sProc *cfunc = toProc(procOrLambda);
return applyProc(cfunc, argument);
}
else if(isLambdaType(procOrLambda))
{
sLambda *lambd = toLambda(procOrLambda);
sList *body = lambd->body;
sList *arguments;
sList *parameters;
if(isList(argument)){
//可変長引数のため
parameters = checkParameters(lambd->parameters, toList(argument));
arguments = checkArguments(parameters, toList(argument), lambd->isVarArgument);
}else{
parameters = lambd->parameters;
arguments = toList(cons(argument, &sNull));
}
sEnvironment *env = extendEnvironment(parameters, arguments, lambd->frame);
if(isList(car(body))){
return evalSequence(body, env);
}else{
return eval(newExp(body, LIST_TAG), env);
}
}
return &sNull;
}
sExpression *evalSequence(sList *exps, sEnvironment *env){
if(isLastExp(exps)){
return eval(firstExp(exps), env);
}else{
eval(firstExp(exps), env);
return evalSequence(restExp(exps), env);
}
}
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
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();
}
