Esempio n. 1
0
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;
    }
}
Esempio n. 2
0
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));
    }
}
Esempio n. 3
0
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));
    }
}
Esempio n. 4
0
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));
    }
}
Esempio n. 5
0
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;
    }
}
Esempio n. 6
0
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;
    }
}
Esempio n. 7
0
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);
                }
        }
    }
}
Esempio n. 8
0
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);
                }
        }
    }
}
Esempio n. 9
0
File: core.php Progetto: mdkarch/mal
}
// 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) {