static malValuePtr quasiquote(malValuePtr obj)
{
const malSequence* seq = isPair(obj);
if (!seq) {
return mal::list(mal::symbol("quote"), obj);
}
if (isSymbol(seq->item(0), "unquote")) {
// (qq (uq form)) -> form
checkArgsIs("unquote", 1, seq->count() - 1);
return seq->item(1);
}
const malSequence* innerSeq = isPair(seq->item(0));
if (innerSeq && isSymbol(innerSeq->item(0), "splice-unquote")) {
checkArgsIs("splice-unquote", 1, innerSeq->count() - 1);
// (qq (sq '(a b c))) -> a b c
return mal::list(
mal::symbol("concat"),
innerSeq->item(1),
quasiquote(seq->rest())
);
}
else {
// (qq (a b c)) -> (list (qq a) (qq b) (qq c))
// (qq xs ) -> (cons (qq (car xs)) (qq (cdr xs)))
return mal::list(
mal::symbol("cons"),
quasiquote(seq->first()),
quasiquote(seq->rest())
);
}
}
LISP quasiquote (LISP expr, LISP ctx, int level)
{
LISP val, tail, func, v;
if (! istype (expr, TPAIR))
return (expr);
if (istype (func = car (expr), TSYMBOL)) {
char *funcname = symname (func);
if (!strcmp (funcname, "quasiquote")) {
v = !istype (v = cdr (expr), TPAIR) ? NIL :
quasiquote (car (v), ctx, level+1);
return (cons (func, cons (v, NIL)));
}
if (!strcmp (funcname, "unquote") ||
!strcmp (funcname, "unquote-splicing")) {
if (!istype (v = cdr (expr), TPAIR))
return (level ? expr : NIL);
if (level)
return (cons (func, cons (quasiquote (car (v),
ctx, level-1), NIL)));
return (eval (car (v), &ctx));
}
}
tail = val = cons (NIL, NIL);
for (;;) {
v = car (expr);
if (! istype (v, TPAIR))
setcar (tail, v);
else if (istype (func = car (v), TSYMBOL) &&
!strcmp (symname (func), "unquote-splicing")) {
if (!istype (v = cdr (v), TPAIR)) {
if (level)
setcar (tail, car (expr));
} else if (level)
setcar (tail, cons (func,
cons (quasiquote (car (v), ctx,
level-1), NIL)));
else {
v = eval (car (v), &ctx);
if (istype (v, TPAIR)) {
LISP newtail;
setcar (tail, car (v));
setcdr (tail, copy (cdr (v), &newtail));
tail = newtail;
} else if (v != NIL) {
setcar (tail, v);
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
} else
setcar (tail, quasiquote (v, ctx, level));
if (! istype (expr = cdr (expr), TPAIR)) {
setcdr (tail, expr);
return (val);
}
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
malValuePtr EVAL(malValuePtr ast, malEnvPtr env)
{
while (1) {
const malList* list = DYNAMIC_CAST(malList, ast);
if (!list || (list->count() == 0)) {
return ast->eval(env);
}
// From here on down we are evaluating a non-empty list.
// First handle the special forms.
if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) {
String special = symbol->value();
int argCount = list->count() - 1;
if (special == "def!") {
checkArgsIs("def!", 2, argCount);
const malSymbol* id = VALUE_CAST(malSymbol, list->item(1));
return env->set(id->value(), EVAL(list->item(2), env));
}
if (special == "do") {
checkArgsAtLeast("do", 1, argCount);
for (int i = 1; i < argCount; i++) {
EVAL(list->item(i), env);
}
ast = list->item(argCount);
continue; // TCO
}
if (special == "fn*") {
checkArgsIs("fn*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
StringVec params;
for (int i = 0; i < bindings->count(); i++) {
const malSymbol* sym =
VALUE_CAST(malSymbol, bindings->item(i));
params.push_back(sym->value());
}
return mal::lambda(params, list->item(2), env);
}
if (special == "if") {
checkArgsBetween("if", 2, 3, argCount);
bool isTrue = EVAL(list->item(1), env)->isTrue();
if (!isTrue && (argCount == 2)) {
return mal::nilValue();
}
ast = list->item(isTrue ? 2 : 3);
continue; // TCO
}
if (special == "let*") {
checkArgsIs("let*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
int count = checkArgsEven("let*", bindings->count());
malEnvPtr inner(new malEnv(env));
for (int i = 0; i < count; i += 2) {
const malSymbol* var =
VALUE_CAST(malSymbol, bindings->item(i));
inner->set(var->value(), EVAL(bindings->item(i+1), inner));
}
ast = list->item(2);
env = inner;
continue; // TCO
}
if (special == "quasiquote") {
checkArgsIs("quasiquote", 1, argCount);
ast = quasiquote(list->item(1));
continue; // TCO
}
if (special == "quote") {
checkArgsIs("quote", 1, argCount);
return list->item(1);
}
}
// Now we're left with the case of a regular list to be evaluated.
std::unique_ptr<malValueVec> items(list->evalItems(env));
malValuePtr op = items->at(0);
if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) {
ast = lambda->getBody();
env = lambda->makeEnv(items->begin()+1, items->end());
continue; // TCO
}
else {
return APPLY(op, items->begin()+1, items->end(), env);
}
}
}
malValuePtr EVAL(malValuePtr ast, malEnvPtr env)
{
if (!env) {
env = replEnv;
}
while (1) {
const malList* list = DYNAMIC_CAST(malList, ast);
if (!list || (list->count() == 0)) {
return ast->eval(env);
}
ast = macroExpand(ast, env);
list = DYNAMIC_CAST(malList, ast);
if (!list || (list->count() == 0)) {
return ast->eval(env);
}
// From here on down we are evaluating a non-empty list.
// First handle the special forms.
if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) {
String special = symbol->value();
int argCount = list->count() - 1;
if (special == "def!") {
checkArgsIs("def!", 2, argCount);
const malSymbol* id = VALUE_CAST(malSymbol, list->item(1));
return env->set(id->value(), EVAL(list->item(2), env));
}
if (special == "defmacro!") {
checkArgsIs("defmacro!", 2, argCount);
const malSymbol* id = VALUE_CAST(malSymbol, list->item(1));
malValuePtr body = EVAL(list->item(2), env);
const malLambda* lambda = VALUE_CAST(malLambda, body);
return env->set(id->value(), mal::macro(*lambda));
}
if (special == "do") {
checkArgsAtLeast("do", 1, argCount);
for (int i = 1; i < argCount; i++) {
EVAL(list->item(i), env);
}
ast = list->item(argCount);
continue; // TCO
}
if (special == "fn*") {
checkArgsIs("fn*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
StringVec params;
for (int i = 0; i < bindings->count(); i++) {
const malSymbol* sym =
VALUE_CAST(malSymbol, bindings->item(i));
params.push_back(sym->value());
}
return mal::lambda(params, list->item(2), env);
}
if (special == "if") {
checkArgsBetween("if", 2, 3, argCount);
bool isTrue = EVAL(list->item(1), env)->isTrue();
if (!isTrue && (argCount == 2)) {
return mal::nilValue();
}
ast = list->item(isTrue ? 2 : 3);
continue; // TCO
}
if (special == "let*") {
checkArgsIs("let*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
int count = checkArgsEven("let*", bindings->count());
malEnvPtr inner(new malEnv(env));
for (int i = 0; i < count; i += 2) {
const malSymbol* var =
VALUE_CAST(malSymbol, bindings->item(i));
inner->set(var->value(), EVAL(bindings->item(i+1), inner));
}
ast = list->item(2);
env = inner;
continue; // TCO
}
if (special == "macroexpand") {
checkArgsIs("macroexpand", 1, argCount);
return macroExpand(list->item(1), env);
}
if (special == "quasiquote") {
checkArgsIs("quasiquote", 1, argCount);
ast = quasiquote(list->item(1));
continue; // TCO
}
if (special == "quote") {
checkArgsIs("quote", 1, argCount);
return list->item(1);
}
if (special == "try*") {
checkArgsIs("try*", 2, argCount);
malValuePtr tryBody = list->item(1);
const malList* catchBlock = VALUE_CAST(malList, list->item(2));
checkArgsIs("catch*", 2, catchBlock->count() - 1);
MAL_CHECK(VALUE_CAST(malSymbol,
catchBlock->item(0))->value() == "catch*",
"catch block must begin with catch*");
// We don't need excSym at this scope, but we want to check
// that the catch block is valid always, not just in case of
// an exception.
const malSymbol* excSym =
VALUE_CAST(malSymbol, catchBlock->item(1));
malValuePtr excVal;
try {
ast = EVAL(tryBody, env);
}
catch(String& s) {
excVal = mal::string(s);
}
catch (malEmptyInputException&) {
// Not an error, continue as if we got nil
ast = mal::nilValue();
}
catch(malValuePtr& o) {
excVal = o;
};
if (excVal) {
// we got some exception
env = malEnvPtr(new malEnv(env));
env->set(excSym->value(), excVal);
ast = catchBlock->item(2);
}
continue; // TCO
}
}
// Now we're left with the case of a regular list to be evaluated.
std::unique_ptr<malValueVec> items(list->evalItems(env));
malValuePtr op = items->at(0);
if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) {
ast = lambda->getBody();
env = lambda->makeEnv(items->begin()+1, items->end());
continue; // TCO
}
else {
return APPLY(op, items->begin()+1, items->end());
}
}
}
LISP eval (LISP expr, LISP *ctxp)
{
LISP ctx = ctxp ? *ctxp : NIL;
LISP func;
again:
if (expr == NIL)
return (NIL);
/* Если это символ, берем его значение */
if (istype (expr, TSYMBOL)) {
/* Поиск значения по контексту */
LISP pair = findatom (expr, ctx);
if (pair == NIL) {
fprintf (stderr, "unbound symbol: `%s'\n", symname (expr));
return (NIL);
}
return (cdr (pair));
}
/* Все, что не атом и не список, не вычисляется */
if (! istype (expr, TPAIR))
return (expr);
/* Перебираем специальные формы.
* quote define set! begin lambda let let* letrec if
* and or cond else => quasiquote unquote unquote-splicing
*/
/* Зарезервированные имена:
* delay do case
*/
func = car (expr);
if (istype (func, TSYMBOL)) {
char *funcname = symname (func);
if (!strcmp (funcname, "quote")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
return (car (expr));
}
if (!strcmp (funcname, "define")) {
LISP value, atom, pair, arg;
int lambda;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
lambda = istype (atom = car (expr), TPAIR);
if (lambda) {
/* define, совмещенный с lambda */
arg = cdr (atom);
atom = car (atom);
}
if (! istype (atom, TSYMBOL) ||
! istype (expr = cdr (expr), TPAIR))
return (NIL);
pair = findatom (atom, ctx);
if (pair == NIL) {
/* Расширяем контекст */
pair = cons (atom, NIL);
if (ctxp)
/* локальный контекст */
*ctxp = ctx = cons (pair, ctx);
else
/* контекст верхнего уровня */
ENV = cons (pair, ENV);
}
if (lambda)
value = closure (cons (arg, expr), ctx);
else
value = evalblock (expr, ctx);
setcdr (pair, value);
return (value);
}
if (!strcmp (funcname, "set!")) {
LISP value = NIL;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
if (istype (cdr (expr), TPAIR))
value = evalblock (cdr (expr), ctx);
setatom (car (expr), value, ctx);
return (value);
}
if (!strcmp (funcname, "begin"))
return (evalblock (cdr (expr), ctx));
if (!strcmp (funcname, "lambda")) {
LISP arg = NIL;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
return (closure (cons (arg, expr), ctx));
}
if (!strcmp (funcname, "let")) {
LISP arg = NIL, oldctx = ctx;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными */
while (istype (arg, TPAIR)) {
LISP var = car (arg);
arg = cdr (arg);
/* Значения вычисляем в старом контексте */
if (istype (var, TPAIR))
ctx = cons (cons (car (var),
evalblock (cdr (var), oldctx)),
ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "let*")) {
LISP arg = NIL;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными */
while (istype (arg, TPAIR)) {
LISP var = car (arg);
arg = cdr (arg);
/* Значения вычисляем в текущем контексте */
if (istype (var, TPAIR))
ctx = cons (cons (car (var),
evalblock (cdr (var), ctx)),
ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "letrec")) {
LISP arg = NIL, a;
if (istype (expr = cdr (expr), TPAIR)) {
arg = car (expr);
if (! istype (expr = cdr (expr), TPAIR))
expr = NIL;
}
/* Расширяем контекст новыми переменными с пустыми значениями */
for (a=arg; istype (a, TPAIR); a=cdr(a)) {
LISP var = car (a);
if (istype (var, TPAIR))
ctx = cons (cons (car (var), NIL), ctx);
else if (istype (var, TSYMBOL))
ctx = cons (cons (var, NIL), ctx);
}
/* Вычисляем значения в новом контексте */
for (a=arg; istype (a, TPAIR); a=cdr(a)) {
LISP var = car (a);
if (istype (var, TPAIR))
setatom (car (var),
evalblock (cdr (var), ctx),
ctx);
}
return (evalblock (expr, ctx));
}
if (!strcmp (funcname, "if")) {
LISP iftrue = NIL, iffalse = NIL, test;
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
test = car (expr);
if (istype (expr = cdr (expr), TPAIR)) {
iftrue = car (expr);
iffalse = cdr (expr);
}
if (eval (test, &ctx) != NIL)
return (eval (iftrue, &ctx));
return (evalblock (iffalse, ctx));
}
if (!strcmp (funcname, "and")) {
while (istype (expr = cdr (expr), TPAIR))
if (eval (car (expr), &ctx) == NIL)
return (NIL);
return (T);
}
if (!strcmp (funcname, "or")) {
while (istype (expr = cdr (expr), TPAIR))
if (eval (car (expr), &ctx) == NIL)
return (T);
return (NIL);
}
if (!strcmp (funcname, "cond")) {
LISP oldctx = ctx, test, clause;
while (istype (expr = cdr (expr), TPAIR)) {
if (! istype (clause = car (expr), TPAIR))
continue;
ctx = oldctx;
if (istype (car (clause), TSYMBOL) &&
! strcmp (symname (car (clause)), "else"))
return (evalblock (cdr (clause), ctx));
test = eval (car (clause), &ctx);
if (test == NIL ||
! istype (clause = cdr (clause), TPAIR))
continue;
if (istype (car (clause), TSYMBOL) &&
! strcmp (symname (car (clause)), "=>")) {
clause = evalblock (cdr (clause), ctx);
if (istype (clause, THARDW))
return ((*hardwval (clause)) (cons (test, NIL), ctx));
if (istype (clause, TCLOSURE))
return (evalclosure (clause, cons (test, NIL)));
return (NIL);
}
return (evalblock (clause, ctx));
}
return (NIL);
}
if (!strcmp (funcname, "quasiquote")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
return (quasiquote (car (expr), ctx, 0));
}
if (!strcmp (funcname, "unquote") ||
!strcmp (funcname, "unquote-splicing")) {
if (! istype (expr = cdr (expr), TPAIR))
return (NIL);
expr = car (expr);
goto again;
}
}
/* Вычисляем все аргументы */
expr = evallist (expr, ctx);
return (evalfunc (car (expr), cdr (expr), ctxp ? *ctxp : TOPLEVEL));
}
