function _equal_Q($a, $b)
{
$ota = gettype($a) === "object" ? get_class($a) : gettype($a);
$otb = gettype($b) === "object" ? get_class($b) : gettype($b);
if (!($ota === $otb or _sequential_Q($a) and _sequential_Q($b))) {
return false;
} elseif (_symbol_Q($a)) {
#print "ota: $ota, otb: $otb\n";
return $a->value === $b->value;
} elseif (_list_Q($a) or _vector_Q($a)) {
if ($a->count() !== $b->count()) {
return false;
}
for ($i = 0; $i < $a->count(); $i++) {
if (!_equal_Q($a[$i], $b[$i])) {
return false;
}
}
return true;
} elseif (_hash_map_Q($a)) {
if ($a->count() !== $b->count()) {
return false;
}
$hm1 = $a->getArrayCopy();
$hm2 = $b->getArrayCopy();
foreach (array_keys($hm1) as $k) {
if ($hm1[$k] !== $hm2[$k]) {
return false;
}
}
return true;
} else {
return $a === $b;
}
}
function MAL_EVAL($ast, $env)
{
#echo "MAL_EVAL: " . _pr_str($ast) . "\n";
if (!_list_Q($ast)) {
return eval_ast($ast, $env);
}
if ($ast->count() === 0) {
return $ast;
}
// apply list
$a0 = $ast[0];
$a0v = _symbol_Q($a0) ? $a0->value : $a0;
switch ($a0v) {
case "def!":
$res = MAL_EVAL($ast[2], $env);
return $env->set($ast[1], $res);
case "let*":
$a1 = $ast[1];
$let_env = new Env($env);
for ($i = 0; $i < count($a1); $i += 2) {
$let_env->set($a1[$i], MAL_EVAL($a1[$i + 1], $let_env));
}
return MAL_EVAL($ast[2], $let_env);
default:
$el = eval_ast($ast, $env);
$f = $el[0];
return call_user_func_array($f, array_slice($el->getArrayCopy(), 1));
}
}
function _pr_str($obj, $print_readably = True)
{
if (_list_Q($obj)) {
$ret = array();
foreach ($obj as $e) {
array_push($ret, _pr_str($e, $print_readably));
}
return "(" . implode(" ", $ret) . ")";
} elseif (_vector_Q($obj)) {
$ret = array();
foreach ($obj as $e) {
array_push($ret, _pr_str($e, $print_readably));
}
return "[" . implode(" ", $ret) . "]";
} elseif (_hash_map_Q($obj)) {
$ret = array();
foreach (array_keys($obj->getArrayCopy()) as $k) {
$ret[] = _pr_str($k, $print_readably);
$ret[] = _pr_str($obj[$k], $print_readably);
}
return "{" . implode(" ", $ret) . "}";
} elseif (is_string($obj)) {
if (strpos($obj, chr(0x7f)) === 0) {
return ":" . substr($obj, 1);
} elseif ($print_readably) {
$obj = preg_replace('/"/', '\\"', preg_replace('/\\\\/', '\\\\\\\\', $obj));
return '"' . $obj . '"';
} else {
return $obj;
}
} elseif (is_integer($obj)) {
return $obj;
} elseif ($obj === NULL) {
return "nil";
} elseif ($obj === true) {
return "true";
} elseif ($obj === false) {
return "false";
} elseif (_symbol_Q($obj)) {
return $obj->value;
} elseif (_atom_Q($obj)) {
return "(atom " . _pr_str($obj->value, $print_readably) . ")";
} elseif (_function_Q($obj)) {
return "(fn* [...] ...)";
} elseif (is_callable($obj)) {
// only step4 and below
return "#<function ...>";
} else {
throw new Exception("_pr_str unknown type: " . gettype($obj));
}
}
function MAL_EVAL($ast, $env)
{
#echo "MAL_EVAL: " . _pr_str($ast) . "\n";
if (!_list_Q($ast)) {
return eval_ast($ast, $env);
}
if ($ast->count() === 0) {
return $ast;
}
// apply list
$a0 = $ast[0];
$a0v = _symbol_Q($a0) ? $a0->value : $a0;
switch ($a0v) {
case "def!":
$res = MAL_EVAL($ast[2], $env);
return $env->set($ast[1], $res);
case "let*":
$a1 = $ast[1];
$let_env = new Env($env);
for ($i = 0; $i < count($a1); $i += 2) {
$let_env->set($a1[$i], MAL_EVAL($a1[$i + 1], $let_env));
}
return MAL_EVAL($ast[2], $let_env);
case "do":
#$el = eval_ast(array_slice($ast->getArrayCopy(), 1), $env);
$el = eval_ast($ast->slice(1), $env);
return $el[count($el) - 1];
case "if":
$cond = MAL_EVAL($ast[1], $env);
if ($cond === NULL || $cond === false) {
if (count($ast) === 4) {
return MAL_EVAL($ast[3], $env);
} else {
return NULL;
}
} else {
return MAL_EVAL($ast[2], $env);
}
case "fn*":
return function () use($env, $ast) {
$fn_env = new Env($env, $ast[1], func_get_args());
return MAL_EVAL($ast[2], $fn_env);
};
default:
$el = eval_ast($ast, $env);
$f = $el[0];
return call_user_func_array($f, array_slice($el->getArrayCopy(), 1));
}
}
function _equal_Q($a, $b)
{
$ota = gettype($a) === "object" ? get_class($a) : gettype($a);
$otb = gettype($b) === "object" ? get_class($b) : gettype($b);
if (!($ota === $otb or _sequential_Q($a) and _sequential_Q($b))) {
return false;
} elseif (_symbol_Q($a)) {
#print "ota: $ota, otb: $otb\n";
return $a->value === $b->value;
} elseif (_list_Q($a) or _vector_Q($a)) {
if ($a->count() !== $b->count()) {
return false;
}
for ($i = 0; $i < $a->count(); $i++) {
if (!_equal_Q($a[$i], $b[$i])) {
return false;
}
}
return true;
} else {
return $a === $b;
}
}
function eval_ast($ast, $env)
{
if (_symbol_Q($ast)) {
return $env[$ast->value];
} elseif (_sequential_Q($ast)) {
if (_list_Q($ast)) {
$el = _list();
} else {
$el = _vector();
}
foreach ($ast as $a) {
$el[] = MAL_EVAL($a, $env);
}
return $el;
} elseif (_hash_map_Q($ast)) {
$new_hm = _hash_map();
foreach (array_keys($ast->getArrayCopy()) as $key) {
$new_hm[$key] = MAL_EVAL($ast[$key], $env);
}
return $new_hm;
} else {
return $ast;
}
}
function MAL_EVAL($ast, $env)
{
while (true) {
#echo "MAL_EVAL: " . _pr_str($ast) . "\n";
if (!_list_Q($ast)) {
return eval_ast($ast, $env);
}
// apply list
$ast = macroexpand($ast, $env);
if (!_list_Q($ast)) {
return eval_ast($ast, $env);
}
if ($ast->count() === 0) {
return $ast;
}
$a0 = $ast[0];
$a0v = _symbol_Q($a0) ? $a0->value : $a0;
switch ($a0v) {
case "def!":
$res = MAL_EVAL($ast[2], $env);
return $env->set($ast[1], $res);
case "let*":
$a1 = $ast[1];
$let_env = new Env($env);
for ($i = 0; $i < count($a1); $i += 2) {
$let_env->set($a1[$i], MAL_EVAL($a1[$i + 1], $let_env));
}
$ast = $ast[2];
$env = $let_env;
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "quote":
return $ast[1];
case "quasiquote":
$ast = quasiquote($ast[1]);
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "defmacro!":
$func = MAL_EVAL($ast[2], $env);
$func->ismacro = true;
return $env->set($ast[1], $func);
case "macroexpand":
return macroexpand($ast[1], $env);
case "do":
eval_ast($ast->slice(1, -1), $env);
$ast = $ast[count($ast) - 1];
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "if":
$cond = MAL_EVAL($ast[1], $env);
if ($cond === NULL || $cond === false) {
if (count($ast) === 4) {
$ast = $ast[3];
} else {
$ast = NULL;
}
} else {
$ast = $ast[2];
}
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "fn*":
return _function('MAL_EVAL', 'native', $ast[2], $env, $ast[1]);
default:
$el = eval_ast($ast, $env);
$f = $el[0];
$args = array_slice($el->getArrayCopy(), 1);
if ($f->type === 'native') {
$ast = $f->ast;
$env = $f->gen_env($args);
// Continue loop (TCO)
} else {
return $f->apply($args);
}
}
}
}
function MAL_EVAL($ast, $env)
{
while (true) {
#echo "MAL_EVAL: " . _pr_str($ast) . "\n";
if (!_list_Q($ast)) {
return eval_ast($ast, $env);
}
// apply list
$ast = macroexpand($ast, $env);
if (!_list_Q($ast)) {
return eval_ast($ast, $env);
}
if ($ast->count() === 0) {
return $ast;
}
$a0 = $ast[0];
$a0v = _symbol_Q($a0) ? $a0->value : $a0;
switch ($a0v) {
case "def!":
$res = MAL_EVAL($ast[2], $env);
return $env->set($ast[1], $res);
case "let*":
$a1 = $ast[1];
$let_env = new Env($env);
for ($i = 0; $i < count($a1); $i += 2) {
$let_env->set($a1[$i], MAL_EVAL($a1[$i + 1], $let_env));
}
$ast = $ast[2];
$env = $let_env;
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "quote":
return $ast[1];
case "quasiquote":
$ast = quasiquote($ast[1]);
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "defmacro!":
$func = MAL_EVAL($ast[2], $env);
$func->ismacro = true;
return $env->set($ast[1], $func);
case "macroexpand":
return macroexpand($ast[1], $env);
case "php*":
$res = eval($ast[1]);
switch (gettype($res)) {
case "array":
if ($res !== array_values($res)) {
$new_res = _hash_map();
$new_res->exchangeArray($res);
return $new_res;
} else {
return call_user_func_array('_list', $res);
}
default:
return $res;
}
case "try*":
$a1 = $ast[1];
$a2 = $ast[2];
if ($a2[0]->value === "catch*") {
try {
return MAL_EVAL($a1, $env);
} catch (Error $e) {
$catch_env = new Env($env, array($a2[1]), array($e->obj));
return MAL_EVAL($a2[2], $catch_env);
} catch (Exception $e) {
$catch_env = new Env($env, array($a2[1]), array($e->getMessage()));
return MAL_EVAL($a2[2], $catch_env);
}
} else {
return MAL_EVAL($a1, $env);
}
case "do":
eval_ast($ast->slice(1, -1), $env);
$ast = $ast[count($ast) - 1];
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "if":
$cond = MAL_EVAL($ast[1], $env);
if ($cond === NULL || $cond === false) {
if (count($ast) === 4) {
$ast = $ast[3];
} else {
$ast = NULL;
}
} else {
$ast = $ast[2];
}
break;
// Continue loop (TCO)
// Continue loop (TCO)
case "fn*":
return _function('MAL_EVAL', 'native', $ast[2], $env, $ast[1]);
default:
$el = eval_ast($ast, $env);
$f = $el[0];
$args = array_slice($el->getArrayCopy(), 1);
if ($f->type === 'native') {
$ast = $f->ast;
$env = $f->gen_env($args);
// Continue loop (TCO)
} else {
return $f->apply($args);
}
}
}
}
}
// core_ns is namespace of type functions
$core_ns = array('=' => function ($a, $b) {
return _equal_Q($a, $b);
}, 'throw' => function ($a) {
return mal_throw($a);
}, 'nil?' => function ($a) {
return _nil_Q($a);
}, 'true?' => function ($a) {
return _true_Q($a);
}, 'false?' => function ($a) {
return _false_Q($a);
}, 'symbol' => function () {
return call_user_func_array('_symbol', func_get_args());
}, 'symbol?' => function ($a) {
return _symbol_Q($a);
}, 'keyword' => function () {
return call_user_func_array('_keyword', func_get_args());
}, 'keyword?' => function ($a) {
return _keyword_Q($a);
}, 'string?' => function ($a) {
return _string_Q($a);
}, 'pr-str' => function () {
return call_user_func_array('pr_str', func_get_args());
}, 'str' => function () {
return call_user_func_array('str', func_get_args());
}, 'prn' => function () {
return call_user_func_array('prn', func_get_args());
}, 'println' => function () {
return call_user_func_array('println', func_get_args());
}, 'readline' => function ($a) {