mirror of
https://github.com/peklaiho/madlisp.git
synced 2024-11-26 07:04:27 +00:00
611 lines
24 KiB
PHP
611 lines
24 KiB
PHP
<?php
|
|
/**
|
|
* MadLisp language
|
|
* @link http://madlisp.com/
|
|
* @copyright Copyright (c) 2020 Pekka Laiho
|
|
*/
|
|
|
|
namespace MadLisp;
|
|
|
|
class Evaller
|
|
{
|
|
protected Tokenizer $tokenizer;
|
|
protected Reader $reader;
|
|
protected Printer $printer;
|
|
protected bool $safemode;
|
|
|
|
protected bool $debug = false;
|
|
|
|
// Keep cache of macro names so we can skip
|
|
// macro expansion when possible.
|
|
protected array $macros = [];
|
|
|
|
public function __construct(Tokenizer $tokenizer, Reader $reader, Printer $printer, bool $safemode)
|
|
{
|
|
$this->tokenizer = $tokenizer;
|
|
$this->reader = $reader;
|
|
$this->printer = $printer;
|
|
$this->safemode = $safemode;
|
|
}
|
|
|
|
public function eval($ast, Env $env, int $depth = 1)
|
|
{
|
|
// Loop for tail call optimization
|
|
$isTco = false;
|
|
while (true) {
|
|
|
|
// Show debug output
|
|
if ($this->debug) {
|
|
printf("%s %2d : ", $isTco ? ' tco' : 'eval', $depth);
|
|
$this->printer->print($ast, true);
|
|
print("\n");
|
|
$isTco = true;
|
|
}
|
|
|
|
// Return here after macro expansion
|
|
$expandMacros = true;
|
|
beginning:
|
|
|
|
// Handle response for anything but a list
|
|
if ($ast instanceof Symbol) {
|
|
return $env->get($ast->getName());
|
|
} elseif ($ast instanceof Vector || $ast instanceof Hash) {
|
|
$newData = [];
|
|
foreach ($ast->getData() as $key => $val) {
|
|
if ($val instanceof Symbol) {
|
|
$newData[$key] = $env->get($val->getName());
|
|
} elseif ($val instanceof Collection) {
|
|
$newData[$key] = $this->eval($val, $env, $depth + 1);
|
|
} else {
|
|
$newData[$key] = $val;
|
|
}
|
|
}
|
|
return $ast::new($newData);
|
|
} elseif ($ast instanceof MList == false) {
|
|
return $ast;
|
|
}
|
|
|
|
$astData = $ast->getData();
|
|
$astLength = count($astData);
|
|
|
|
// Empty list, we can return
|
|
if ($astLength == 0) {
|
|
return $ast;
|
|
}
|
|
|
|
// Handle special forms
|
|
if ($astData[0] instanceof Symbol) {
|
|
$symbolName = $astData[0]->getName();
|
|
|
|
// Handle macro expansion and go back to beginning to check
|
|
// if ast is still something we need to evaluate or not.
|
|
if ($expandMacros && array_key_exists($symbolName, $this->macros)) {
|
|
$ast = $this->macroexpand($ast, $env);
|
|
$expandMacros = false;
|
|
goto beginning;
|
|
}
|
|
|
|
if ($symbolName == 'and') {
|
|
if ($astLength == 1) {
|
|
return true;
|
|
}
|
|
|
|
for ($i = 1; $i < $astLength - 1; $i++) {
|
|
$value = $this->eval($astData[$i], $env, $depth + 1);
|
|
if ($value == false) {
|
|
return $value;
|
|
}
|
|
}
|
|
|
|
$ast = $astData[$astLength - 1];
|
|
continue; // tco
|
|
} elseif ($symbolName == 'case' || $symbolName == 'case-strict') {
|
|
if ($astLength < 3) {
|
|
throw new MadLispException("$symbolName requires at least 2 arguments");
|
|
}
|
|
|
|
$value = $this->eval($astData[1], $env, $depth + 1);
|
|
|
|
for ($i = 2; $i < $astLength; $i++) {
|
|
if (!($astData[$i] instanceof Seq)) {
|
|
throw new MadLispException("argument to $symbolName is not seq");
|
|
}
|
|
|
|
$data = $astData[$i]->getData();
|
|
|
|
if (count($data) < 2) {
|
|
throw new MadLispException("clause for $symbolName requires at least 2 arguments");
|
|
}
|
|
|
|
if ($data[0] instanceof Symbol && $data[0]->getName() == 'else') {
|
|
$test = true;
|
|
} elseif ($symbolName == 'case') {
|
|
$test = Util::valueForCompare($value) == Util::valueForCompare($data[0]);
|
|
} else {
|
|
// Strict comparison
|
|
$test = Util::valueForCompare($value) === Util::valueForCompare($data[0]);
|
|
}
|
|
|
|
if ($test) {
|
|
// Evaluate interval expressions
|
|
for ($j = 1; $j < count($data) - 1; $j++) {
|
|
$this->eval($data[$j], $env, $depth + 1);
|
|
}
|
|
|
|
// Evaluate last expression
|
|
$ast = $data[count($data) - 1];
|
|
continue 2; // tco
|
|
}
|
|
}
|
|
|
|
// No match
|
|
return null;
|
|
} elseif ($symbolName == 'cond') {
|
|
if ($astLength < 2) {
|
|
throw new MadLispException("cond requires at least 1 argument");
|
|
}
|
|
|
|
for ($i = 1; $i < $astLength; $i++) {
|
|
if (!($astData[$i] instanceof Seq)) {
|
|
throw new MadLispException("argument to cond is not seq");
|
|
}
|
|
|
|
$data = $astData[$i]->getData();
|
|
|
|
if (count($data) < 2) {
|
|
throw new MadLispException("clause for cond requires at least 2 arguments");
|
|
}
|
|
|
|
if ($data[0] instanceof Symbol && $data[0]->getName() == 'else') {
|
|
$test = true;
|
|
} else {
|
|
$test = $this->eval($data[0], $env, $depth + 1);
|
|
}
|
|
|
|
if ($test) {
|
|
// Evaluate interval expressions
|
|
for ($j = 1; $j < count($data) - 1; $j++) {
|
|
$this->eval($data[$j], $env, $depth + 1);
|
|
}
|
|
|
|
// Evaluate last expression
|
|
$ast = $data[count($data) - 1];
|
|
continue 2; // tco
|
|
}
|
|
}
|
|
|
|
// No match
|
|
return null;
|
|
} elseif ($symbolName == 'def') {
|
|
if ($astLength != 3) {
|
|
throw new MadLispException("def requires exactly 2 arguments");
|
|
} elseif (!($astData[1] instanceof Symbol)) {
|
|
throw new MadLispException("first argument to def is not symbol");
|
|
}
|
|
|
|
$name = $astData[1]->getName();
|
|
|
|
// Do not allow reserved symbols to be defined
|
|
$reservedSymbols = ['__FILE__', '__DIR__'];
|
|
if (in_array($name, $reservedSymbols)) {
|
|
throw new MadLispException("attempt to def reserved symbol $name");
|
|
}
|
|
|
|
$value = $this->eval($astData[2], $env, $depth + 1);
|
|
|
|
// Save macros in cache
|
|
if ($value instanceof Func && $value->isMacro()) {
|
|
// value does not matter, we check for key
|
|
$this->macros[$name] = 1;
|
|
}
|
|
|
|
return $env->set($name, $value);
|
|
} elseif ($symbolName == 'do') {
|
|
if ($astLength == 1) {
|
|
return null;
|
|
}
|
|
|
|
for ($i = 1; $i < $astLength - 1; $i++) {
|
|
$this->eval($astData[$i], $env, $depth + 1);
|
|
}
|
|
|
|
$ast = $astData[$astLength - 1];
|
|
continue; // tco
|
|
} elseif ($symbolName == 'env') {
|
|
if ($astLength != 1) {
|
|
throw new MadLispException("env does not take arguments");
|
|
}
|
|
|
|
return $env;
|
|
} elseif ($symbolName == 'eval') {
|
|
if ($astLength != 2) {
|
|
throw new MadLispException("eval requires exactly 1 argument");
|
|
}
|
|
|
|
$ast = $this->eval($astData[1], $env, $depth + 1);
|
|
continue; // tco
|
|
} elseif ($symbolName == 'fn' || $symbolName == 'macro') {
|
|
if ($astLength != 3) {
|
|
throw new MadLispException("$symbolName requires exactly 2 arguments");
|
|
} elseif (!($astData[1] instanceof Seq)) {
|
|
throw new MadLispException("first argument to $symbolName is not seq");
|
|
}
|
|
|
|
$bindings = $astData[1]->getData();
|
|
foreach ($bindings as $bind) {
|
|
if (!($bind instanceof Symbol)) {
|
|
throw new MadLispException("binding key for $symbolName is not symbol");
|
|
}
|
|
}
|
|
|
|
$closure = function (...$args) use ($bindings, $env, $astData, $depth) {
|
|
$newEnv = new Env('closure', $env);
|
|
|
|
Util::bindArguments($newEnv, $bindings, $args);
|
|
|
|
return $this->eval($astData[2], $newEnv, $depth + 1);
|
|
};
|
|
|
|
return new UserFunc($closure, $astData[2], $env, $astData[1], $symbolName == 'macro');
|
|
} elseif ($symbolName == 'if') {
|
|
if ($astLength < 3 || $astLength > 4) {
|
|
throw new MadLispException("if requires 2 or 3 arguments");
|
|
}
|
|
|
|
$result = $this->eval($astData[1], $env, $depth + 1);
|
|
|
|
if ($result == true) {
|
|
$ast = $astData[2];
|
|
continue; // tco
|
|
} elseif ($astLength == 4) {
|
|
$ast = $astData[3];
|
|
continue; // tco
|
|
} else {
|
|
return null;
|
|
}
|
|
} elseif ($symbolName == 'let') {
|
|
if ($astLength < 3) {
|
|
throw new MadLispException("let requires at least 2 arguments");
|
|
} elseif (!($astData[1] instanceof Seq)) {
|
|
throw new MadLispException("first argument to let is not seq");
|
|
}
|
|
|
|
$bindings = $astData[1]->getData();
|
|
|
|
if (count($bindings) % 2 == 1) {
|
|
throw new MadLispException("uneven number of bindings for let");
|
|
}
|
|
|
|
$newEnv = new Env('let', $env);
|
|
|
|
for ($i = 0; $i < count($bindings) - 1; $i += 2) {
|
|
$key = $bindings[$i];
|
|
|
|
if (!($key instanceof Symbol)) {
|
|
throw new MadLispException("binding key for let is not symbol");
|
|
}
|
|
|
|
$val = $this->eval($bindings[$i + 1], $newEnv, $depth + 1);
|
|
$newEnv->set($key->getName(), $val);
|
|
}
|
|
|
|
// Eval interval expressions
|
|
for ($i = 2; $i < $astLength - 1; $i++) {
|
|
$this->eval($astData[$i], $newEnv, $depth + 1);
|
|
}
|
|
|
|
// Eval last expression
|
|
$ast = $astData[$astLength - 1];
|
|
$env = $newEnv;
|
|
continue; // tco
|
|
} elseif (!$this->safemode && $symbolName == 'load') {
|
|
// Load is here because we want to load into
|
|
// current $env which is hard otherwise.
|
|
|
|
// This is disabled now for safe-mode, but some
|
|
// use (maybe restricted) might need to be allowed.
|
|
|
|
if ($astLength != 2) {
|
|
throw new MadLispException("load requires exactly 1 argument");
|
|
}
|
|
|
|
// We have to evaluate the argument, it could be a function
|
|
$filename = $this->eval($astData[1], $env, $depth + 1);
|
|
|
|
if (!is_string($filename)) {
|
|
throw new MadLispException("first argument to load is not string");
|
|
}
|
|
|
|
// Replace ~ with user home directory
|
|
// Expand relative path names into absolute
|
|
$targetFile = realpath(str_replace('~', $_SERVER['HOME'], $filename));
|
|
|
|
if (!$targetFile || !is_readable($targetFile)) {
|
|
throw new MadLispException("unable to read file $filename");
|
|
}
|
|
|
|
$input = @file_get_contents($targetFile);
|
|
|
|
// Remove #! from the beginning that is used by shell scripts
|
|
if (extension_loaded('pcre')) {
|
|
$input = preg_replace('/^#![^\n\r]*[\n\r]+/', '', $input, 1);
|
|
}
|
|
|
|
// Wrap input in a do to process multiple expressions
|
|
$input = "(do $input)";
|
|
|
|
$expr = $this->reader->read($this->tokenizer->tokenize($input));
|
|
|
|
// Handle special constants
|
|
$rootEnv = $env->getRoot();
|
|
$prevFile = $rootEnv->get('__FILE__');
|
|
$prevDir = $rootEnv->get('__DIR__');
|
|
$rootEnv->set('__FILE__', $targetFile);
|
|
$rootEnv->set('__DIR__', dirname($targetFile) . \DIRECTORY_SEPARATOR);
|
|
|
|
// Evaluate the contents
|
|
$ast = $this->eval($expr, $env, $depth + 1);
|
|
|
|
// Restore the special constants to previous values
|
|
$rootEnv->set('__FILE__', $prevFile);
|
|
$rootEnv->set('__DIR__', $prevDir);
|
|
|
|
continue; // tco
|
|
} elseif ($symbolName == 'macroexpand') {
|
|
if ($astLength != 2) {
|
|
throw new MadLispException("macroexpand requires exactly 1 argument");
|
|
}
|
|
|
|
return $this->macroexpand($astData[1], $env);
|
|
} elseif ($symbolName == 'meta') {
|
|
if ($astLength != 3) {
|
|
throw new MadLispException("meta requires exactly 2 arguments");
|
|
} elseif (!is_string($astData[2])) {
|
|
throw new MadLispException("third argument to meta is not string");
|
|
}
|
|
|
|
$obj = $this->eval($astData[1], $env, $depth + 1);
|
|
$attribute = $astData[2];
|
|
|
|
if ($obj instanceof Env) {
|
|
if ($attribute == 'name') {
|
|
return $obj->getFullName();
|
|
} elseif ($attribute == 'parent') {
|
|
return $obj->getParent();
|
|
} else {
|
|
throw new MadLispException('unknown attribute for meta');
|
|
}
|
|
} elseif ($obj instanceof UserFunc) {
|
|
if ($attribute == 'args') {
|
|
return $obj->getBindings();
|
|
} elseif ($attribute == 'body') {
|
|
return $obj->getAst();
|
|
} elseif ($attribute == 'code') {
|
|
$name = $obj->isMacro() ? 'macro' : 'fn';
|
|
return new MList([new Symbol($name), $obj->getBindings(), $obj->getAst()]);
|
|
} elseif ($attribute == 'def') {
|
|
if ($astData[1] instanceof Symbol) {
|
|
$def = $obj->isMacro() ? 'defmacro' : 'defn';
|
|
return new MList([new Symbol($def), $astData[1], $obj->getBindings(), $obj->getAst()]);
|
|
} else {
|
|
throw new MadLispException('no name for def in meta');
|
|
}
|
|
} else {
|
|
throw new MadLispException('unknown attribute for meta');
|
|
}
|
|
} else {
|
|
throw new MadLispException('unknown entity for meta');
|
|
}
|
|
} elseif ($symbolName == 'or') {
|
|
if ($astLength == 1) {
|
|
return false;
|
|
}
|
|
|
|
for ($i = 1; $i < $astLength - 1; $i++) {
|
|
$value = $this->eval($astData[$i], $env, $depth + 1);
|
|
if ($value == true) {
|
|
return $value;
|
|
}
|
|
}
|
|
|
|
$ast = $astData[$astLength - 1];
|
|
continue; // tco
|
|
} elseif ($symbolName == 'quote') {
|
|
if ($astLength != 2) {
|
|
throw new MadLispException("quote requires exactly 1 argument");
|
|
}
|
|
|
|
return $astData[1];
|
|
} elseif ($symbolName == 'quasiquote') {
|
|
if ($astLength != 2) {
|
|
throw new MadLispException("quasiquote requires exactly 1 argument");
|
|
}
|
|
|
|
$ast = $this->quasiquote($astData[1]);
|
|
continue; // tco
|
|
} elseif ($symbolName == 'quasiquote-expand') {
|
|
if ($astLength != 2) {
|
|
throw new MadLispException("quasiquote-expand requires exactly 1 argument");
|
|
}
|
|
|
|
return $this->quasiquote($astData[1]);
|
|
} elseif ($symbolName == 'try') {
|
|
if ($astLength != 3) {
|
|
throw new MadLispException("try requires exactly 2 arguments");
|
|
} elseif (!($astData[2] instanceof Seq)) {
|
|
throw new MadLispException("second argument to try is not seq");
|
|
}
|
|
|
|
$catch = $astData[2]->getData();
|
|
|
|
if (count($catch) == 3 && $catch[0] instanceof Symbol &&
|
|
$catch[0]->getName() == 'catch' && $catch[1] instanceof Symbol) {
|
|
|
|
try {
|
|
return $this->eval($astData[1], $env, $depth + 1);
|
|
} catch (\Throwable $ex) {
|
|
if ($ex instanceof MadLispUserException) {
|
|
$exVal = $ex->getValue();
|
|
} else {
|
|
// Return a hash-map for PHP exceptions
|
|
$exVal = new Hash([
|
|
'type' => get_class($ex),
|
|
'file' => $ex->getFile(),
|
|
'line' => $ex->getLine(),
|
|
'message' => $ex->getMessage()
|
|
]);
|
|
}
|
|
|
|
$newEnv = new Env('catch', $env);
|
|
$newEnv->set($catch[1]->getName(), $exVal);
|
|
|
|
$env = $newEnv;
|
|
$ast = $catch[2];
|
|
continue; // tco
|
|
}
|
|
} else {
|
|
throw new MadLispException("invalid form for catch");
|
|
}
|
|
} elseif ($symbolName == 'undef') {
|
|
if ($astLength != 2) {
|
|
throw new MadLispException("undef requires exactly 1 argument");
|
|
} elseif (!($astData[1] instanceof Symbol)) {
|
|
throw new MadLispException("first argument to undef is not symbol");
|
|
}
|
|
|
|
return $env->unset($astData[1]->getName());
|
|
} elseif ($symbolName == 'while') {
|
|
if ($astLength < 3) {
|
|
throw new MadLispException("while requires at least 2 arguments");
|
|
}
|
|
|
|
$result = null;
|
|
|
|
$test = $this->eval($astData[1], $env, $depth + 1);
|
|
while ($test) {
|
|
for ($i = 2; $i < $astLength; $i++) {
|
|
$result = $this->eval($astData[$i], $env, $depth + 1);
|
|
}
|
|
$test = $this->eval($astData[1], $env, $depth + 1);
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
}
|
|
|
|
// Eval all items in list
|
|
$newData = [];
|
|
foreach ($astData as $a) {
|
|
if ($a instanceof Symbol) {
|
|
$newData[] = $env->get($a->getName());
|
|
} elseif ($a instanceof Collection) {
|
|
$newData[] = $this->eval($a, $env, $depth + 1);
|
|
} else {
|
|
$newData[] = $a;
|
|
}
|
|
}
|
|
|
|
// First item is function, rest are arguments
|
|
$func = $newData[0];
|
|
$args = array_slice($newData, 1);
|
|
|
|
if ($func instanceof CoreFunc) {
|
|
return $func->call($args);
|
|
} elseif ($func instanceof UserFunc) {
|
|
$ast = $func->getAst();
|
|
$env = $func->getEnv($args);
|
|
// tco
|
|
} else {
|
|
throw new MadLispException("eval: first item of list is not function");
|
|
}
|
|
}
|
|
}
|
|
|
|
public function getDebug(): bool
|
|
{
|
|
return $this->debug;
|
|
}
|
|
|
|
public function setDebug(bool $val): void
|
|
{
|
|
$this->debug = $val;
|
|
}
|
|
|
|
private function macroexpand($ast, Env $env)
|
|
{
|
|
while ($ast instanceof MList) {
|
|
$data = $ast->getData();
|
|
if (count($data) > 0 && $data[0] instanceof Symbol) {
|
|
$fn = $env->get($data[0]->getName(), false);
|
|
if ($fn && $fn instanceof Func && $fn->isMacro()) {
|
|
$ast = $fn->call(array_slice($data, 1));
|
|
continue;
|
|
}
|
|
}
|
|
break;
|
|
}
|
|
|
|
return $ast;
|
|
}
|
|
|
|
private function quasiquote($ast)
|
|
{
|
|
if ($ast instanceof MList) {
|
|
$data = $ast->getData();
|
|
|
|
// Check for unquote
|
|
if (count($data) > 0 && $data[0] instanceof Symbol && $data[0]->getName() == 'unquote') {
|
|
if (count($data) == 2) {
|
|
return $data[1];
|
|
} else {
|
|
throw new MadLispException("unquote requires exactly 1 argument");
|
|
}
|
|
}
|
|
|
|
return $this->quasiquoteLoop($data);
|
|
} elseif ($ast instanceof Vector) {
|
|
return new MList([
|
|
new Symbol('ltov'),
|
|
$this->quasiquoteLoop($ast->getData())
|
|
]);
|
|
} elseif ($ast instanceof Symbol || $ast instanceof Hash) {
|
|
// Quote other forms which are affected by evaluation
|
|
return new MList([
|
|
new Symbol('quote'),
|
|
$ast
|
|
]);
|
|
} else {
|
|
return $ast;
|
|
}
|
|
}
|
|
|
|
private function quasiquoteLoop(array $data): MList
|
|
{
|
|
$result = new MList();
|
|
|
|
for ($i = count($data) - 1; $i >= 0; $i--) {
|
|
$elt = $data[$i];
|
|
|
|
if ($elt instanceof MList && count($elt->getData()) > 0 && $elt->get(0) instanceof Symbol && $elt->get(0)->getName() == 'unquote-splice') {
|
|
if (count($elt->getData()) == 2) {
|
|
$result = new MList([
|
|
new Symbol('concat'),
|
|
$elt->get(1),
|
|
$result
|
|
]);
|
|
} else {
|
|
throw new MadLispException("unquote-splice requires exactly 1 argument");
|
|
}
|
|
} else {
|
|
$result = new MList([
|
|
new Symbol('cons'),
|
|
$this->quasiquote($elt),
|
|
$result
|
|
]);
|
|
}
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
}
|