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)); }