Prototype Lisp interpreter implemented in PHP.

lisp.php

<?php

/**
	This interpreter is largely a port of
	this Python implementation: http://norvig.com/lispy.html
	with several added features and a more object-oriented
	approach with a focus on embedding in other scripts
	rather than being a standalone script.
	
	This is currently a prototype/proof-of-concept
	interpreter, to be implemented in C# at a later date.
	As such, the built-in functions, syntax, and constants are
	very minimal.
*/

namespace Lispy;

function startsWith($haystack, $needle)
{
    return $needle === "" || strpos($haystack, $needle) === 0;
}

function endsWith($haystack, $needle)
{
    return $needle === "" || substr($haystack, -strlen($needle)) === $needle;
}

function array_nshift( array& $array, $n )
{
	$new = [ ];
	
	for( $i = 0; $i < $n; ++$i )
		$new[] = array_shift( $array );
	
	return $new;
}

function implode_recursive( $sep, $array )
{
    $imploded = "";
 
    foreach( $array as $item )
    {
        if( is_array( $item ) )
            $imploded .= implode_recursive( $sep, $item ) . $sep;
        else
            $imploded .= strval( $item ) . $sep;
    }
 
    return rtrim( $imploded, $sep );
}

final class Environment
{
	private static $globalInstance = null;
	
	public static function getGlobal()
	{
		if( self::$globalInstance !== null )
			return self::$globalInstance;

		$environmentVars = [
			//Math funcs
			"abs"          => function( $a ) { return abs( $a ); },
			"acos"         => function( $a ) { return acos( $a ); },
			"acosh"        => function( $a ) { return acosh( $a ); },
			"asin"         => function( $a ) { return asin( $a ); },
			"asinh"        => function( $a ) { return asinh( $a ); },
			"atan2"        => function( $a, $b ) { return atan2( $a, $b ); },
			"atan"         => function( $a ) { return atan( $a ); },
			"atanh"        => function( $a ) { return atanh( $a ); },
			"base-convert" => function( $a, $b, $c ) { return base_convert( $a, $b, $c ); },
			"bindec"       => function( $a ) { return bindec( $a ); },
			"ceil"         => function( $a ) { return ceil( $a ); },
			"cos"          => function( $a ) { return cos( $a ); },
			"cosh"         => function( $a ) { return cosh( $a ); },
			"decbin"       => function( $a ) { return decbin( $a ); },
			"dechex"       => function( $a ) { return dechex( $a ); },
			"decoct"       => function( $a ) { return decoct( $a ); },
			"deg2rad"      => function( $a ) { return deg2rad( $a ); },
			"exp"          => function( $a ) { return exp( $a ); },
			"expm1"        => function( $a ) { return expm1( $a ); },
			"floor"        => function( $a ) { return floor( $a ); },
			"fmod"         => function( $a, $b ) { return fmod( $a, $b ); },
			"hexdec"       => function( $a ) { return hexdec( $a ); },
			"hypot"        => function( $a, $b ) { return hypot( $a, $b ); },
			"is-finite"    => function( $a ) { return is_finite( $a ); },
			"is-infinite"  => function( $a ) { return is_infinite( $a ); },
			"is-nan"       => function( $a ) { return is_nan( $a ); },
			"lcg-value"    => function() { return lcg_value(); },
			"log10"        => function( $a ) { return log10( $a ); },
			"log1p"        => function( $a ) { return log1p( $a ); },
			"log"          => function( $a, $b ) { return log( $a, $b ); },
			"max"          => function( $a, $b, $c ) { return max( $a, $b, $c ); },
			"min"          => function( $a, $b, $c ) { return min( $a, $b, $c ); },
			"octdec"       => function( $a ) { return octdec( $a ); },
			//"pi"           => function() { return pi(); },
			//"pow"          => function( $a, $b ) { return pow( $a, $b ); },
			"rad2deg"      => function( $a ) { return rad2deg( $a ); },
			"round"        => function( $a, $b, $c ) { return round( $a, $b, $c ); },
			"sin"          => function( $a ) { return sin( $a ); },
			"sinh"         => function( $a ) { return sinh( $a ); },
			"sqrt"         => function( $a ) { return sqrt( $a ); },
			"tan"          => function( $a ) { return tan( $a ); },
			"tanh"         => function( $a ) { return tanh( $a ); },
			
			//vars
			"PI"    => M_PI,
			"E"     => M_E,
			"EOL"   => PHP_EOL,
			
			"nil"   => null,
			"true"  => true,
			"false" => false,
			
			//Operators
			"*" => function( $left, $right ) { return $left * $right; },
			"+" => function( $left, $right ) { return $left + $right; },
			"/" => function( $left, $right ) { return $right / $left; },
			"-" => function( $left, $right ) { return $right - $left; },
			"^" => function( $left, $right ) { return pow( $left, $right ); },
			">" => function( $left, $right ) { return $left > $right; },
			"<" => function( $left, $right ) { return $left < $right; },
			"=" => function( $left, $right ) { return $left == $right; },
			
			"<=" => function( $left, $right ) { return $left <= $right; },
			">=" => function( $left, $right ) { return $left >= $right; },
			
			"eq?" => function( $left, $right ) { return $left === $right; },
			
			"not" => function( $exp ) {
				if( is_float( $exp ) or is_int( $exp ) )
					return !( $exp == 0 );
				elseif( is_string( $exp ) )
				{
					$lower = strtolower( $exp );
					return !( $lower == "yes" or $lower == "true" );
				}
				elseif( is_bool( $exp ) )
					return !$exp;
				else
					return !false;
			},
			
			//General funcs
			"count"  => function( array $item ) { return sizeof( $item ); },
			"car"    => function( array $exp ) { return $exp[0]; },
			"cdr"    => function( array $exp ) { return array_slice( $exp, 1 ); },
			"map"    => function( callable $lambda, array $list ) { return array_map( $lambda, $list ); },
			"filter" => function( callable $lambda, array $list ) { return array_filter( $lambda, $list ); },
			"chr"    => function( $x ) { return chr( $x ); },
			"ord"    => function( $x ) { return ord( $x ); },
			"range"  => function( $x, $y, $z = 1 ) { return range( $x, $y, $z ); },
			
			"join"   => function( $delim, array $arr ) {
				return implode_recursive( $delim, $arr );
			},
			
			
			"append" => function() {
				$args = func_get_args();
				$len  = func_num_args();
				
				if( $len == 0 )
					return [ ];
				if( $len == 1 )
					return $args[0];
				elseif( $len == 2 )
					return $args[0][] = $args[1];
				elseif( $len > 2 )
				{
					for( $i = 1; $i < $len; ++$i )
						$args[0][] = $args[$i];
					
					return $args[0];
				}
			},
			
			"list?"   => function( $exp ) { return is_array( $exp ); },
			"symbol?" => function( $exp ) { return is_string( $exp ); },
			"number?" => function( $exp ) { return is_int( $exp ) or is_float( $exp ); },
			
			"null?" => function( $exp ) {
				if( is_array( $exp ) )
					return sizeof( $exp ) === 0;
				elseif( is_string( $exp ) )
					return strlen( $exp ) === 0;
				elseif( is_int( $exp ) or is_float( $exp ) )
					return $exp == 0;
				else
					return true;
			},
			
			"seed" => function() {
				$args = func_get_args();
				
				if( func_num_args() === 1 )
					mt_srand( intval( $args[0] ) );
				else
					mt_srand();
				
				return null;
			},
			
			"rand" => function() {
				if( func_num_args() >= 2 )
					list( $lo, $hi ) = func_get_args();
				else
				{
					$lo = 0;
					$hi = mt_getrandmax();
				}
				
				return mt_rand( $lo, $hi );
			},
			
			"puts" => function() {
				$args = func_get_args();
				echo implode_recursive( " ", $args ), PHP_EOL;
			},
			
			"gets" => function() {
				//support for optional prompt arg.
				if( func_num_args() === 0 )
					return fgets( STDIN );
				else
				{
					$args = func_get_args();
					echo implode_recursive( " ", $args );
					return trim( fgets( STDIN ) );
				}
			},
		];
		
		self::$globalInstance = new Environment( $environmentVars );
		return self::$globalInstance;
	}
	
	private $vars;
	
	private static $RESERVED_WORDS = [
		"dict", "define", "lambda",
		"if", "quote", "str", "set!",
		"begin"
	];
	
	//These environment variables may not be altered from userland.
	private static $BLACKLIST =[
		"E", "PI", "nil", "true", "false"
	];
	
	public function __construct( array $vars = [ ] )
	{
		if( sizeof( $vars ) > 0 )
		foreach( $vars as $k => $v )
		{
			if( !is_string( $k ) )
				throw new \Exception( "\$vars is not a valid associative array." );
			$this->CheckName( $k );
		}
		
		$this->vars = $vars;
	}
	
	public function GetVariables()
	{
		return $this->vars;
	}
	
	public function __set( $name, $val )
	{
		if( !is_string( $name ) ) //Thwart those nefarious evil-doers who would invoke this method directly.
			throw new \Exception( "stahp" );
		
		$this->CheckName( $name );
		$this->vars[$name] = $val;
	}
	
	public function __get( $name )
	{
		if( !is_string( $name ) )
			throw new \Exception( "I said stahp." );
			
		if( !array_key_exists( $name, $this->vars ) )
			throw new \Exception( "No environment variable with the name '{$name}' exists." );
		
		$this->CheckName( $name );
		return $this->vars[$name];
	}
	
	public function __call( $name, $args )
	{
		$x = $this->__get( $name );
		
		if( !is_callable( $x ) )
			throw new \Exception( "{$name} is not a function." );
		
		return call_user_func_array( $x, $args );
	}
	
	public function Register( array $vars )
	{
		foreach( $vars as $k => $v )
			$this->{ $k } = $v;
	}
	
	public function Copy()
	{
		return new Environment( $this->vars );
	}
	
	private function CheckName( $name )
	{
		$trimmed = trim( $name );
		
		if( in_array( $trimmed, self::$RESERVED_WORDS ) )
			throw new \Exception( "'{$name}' is a reserved word and may not be used as an environment variable." );
		
		if( startsWith( $trimmed, "'" ) || endsWith( $trimmed, "'" ) )
			throw new \Exception( "Environment variables may not begin or end with apostrophes." );
	}
}

final class Lispy
{
	private $ast;
	private $environment;
	
	public function __construct( Environment $env = null )
	{
		$this->environment = $env !== null ? $env : Environment::getGlobal();
	}
	
	public function Evaluate( $repr = true )
	{
		$tempEnviron = $this->environment->Copy();
		$astCpy = $this->ast;
		$result = $this->EvalImpl( $astCpy, $tempEnviron );
		return $repr ? $this->ToString( $result ) : $result;
	}
	
	public function Parse( $code )
	{
		$tokens = $this->Tokenize( $code );
		$this->ast = $this->ReadFrom( $tokens );
	}
	
	private function EvalImpl( $x, Environment& $env )
	{
		if( is_array( $x ) and sizeof( $x ) === 0 )
			return $x;
			
		if( is_string( $x ) )
		{
			//return $x[0] == "'" ? substr( $x, 1 ) : $env->{ $x };
			
			//When prefixing an apostrophe on a string, it's taken to mean "literally".
			//When an apostrophe appears alone, it is taken to mean a single ASCII whitespace.
			$val = null;
			
			if( $x === "'" )
				$val = "\x20";
			elseif( $x === "''" )
				return "'";
			elseif( $x[0] === "'" )
				$val = substr( $x, 1 );
			elseif( substr( $x, -1 ) === "'" )
				$val = substr( $x, 0, -1 ) . "\x20";
			elseif( trim( $x ) === "" )
				$val = $x; //just whitespace
			else
				$val = $env->{ $x };
			
			return $val;
		}
		elseif( !is_array( $x ) )
			return $x;
		//elseif( is_array( $x ) and !is_multi_dimensional( $x ) )
		//	return $x; //just an array const
		elseif( $x[0] === "quote" or $x[0] === "str" )
		{
			list( $_, $exp ) = array_nshift( $x, 2 );
			return $exp;
		}
		elseif( $x[0] === "if" )
		{
			list( $_, $if, $true, $else ) = array_nshift( $x, 4 );
			
			$result = $this->EvalImpl( $if, $env );
			$exp    = (bool)$result ? $true : $else;
			
			return $this->EvalImpl( [ $exp ], $env );
		}
		elseif( $x[0] === "set!" or $x[0] === "define" )
		{
			list( $_, $var, $exp ) = array_nshift( $x, 3 );
			
			if( in_array( $var, self::$BLACKLIST ) )
				throw new \Exception( "'{$var}' is a constant and may not be overwritten." );
			
			$env->{ $var } = $this->EvalImpl( $exp, $env );
		}
		elseif( $x[0] === "dict" )
		{
			list( $_, $pairs ) = array_nshift( $x, 2 );
			$pairs = $this->EvalImpl( $pairs, $env );
			
			//var_dump( $_, $pairs, $x );
			
			if( !is_array( $pairs ) )
				throw new \Exception( "dict expects an array as a parameter, " . gettype( $pairs ) . " given." );
			
			$len = sizeof( $pairs );
			if( $len % 2 !== 0 )
				throw new \Exception( "dict expects an array with a length divisible by 2, length of {$len} given." );
			
			$dict = [ ];
			for( $i = 0, $j = 1; $i < $len - 1, $j < $len; $i += 2, $j += 2 )
			{
				$k = $pairs[$i];
				$v = $pairs[$j];
				$dict[$k] = $v;
			}
			
			return $dict;
		}
		elseif( $x[0] === "lambda" )
		{
			list( $_, $vars, $exp ) = array_nshift( $x, 3 );
			return function() use ( $vars, $exp, $env ) {
				$newEnv = $env->Copy();
				$args = func_get_args();
				
				$argLen = sizeof( $args );
				$varLen = sizeof( $vars );
				
				if( $varLen != $argLen )
				{
					if( $varLen > $argLen )
						$args = array_pad( $args, $varLen, 0 );
					else
						$vars = array_pad( $vars, $argLen, 0 );
				}
				
				for( $i = 0; $i < max( $varLen, $argLen ); ++$i )
					$newEnv->{ $vars[$i] } = $args[$i];
				
				return $this->EvalImpl( $exp, $newEnv );
			};
		}
		elseif( $x[0] === "begin" )
		{
			foreach( array_slice( $x, 1 ) as $v )
				$val = $this->EvalImpl( $v, $env );
			
			return $val;
		}
		else
		{
			$exps = [ ];
			
			foreach( $x as $exp )
				$exps[] = $this->EvalImpl( $exp, $env );
			
			$proc = array_shift( $exps );
			
			if( is_callable( $proc ) )
				return call_user_func_array( $proc, $exps );
			else
			{
				array_unshift( $exps, $proc );
				return $exps;
			}
		}
	}
	
	private function Read( $code )
	{
		return $this->ReadFrom( $this->Tokenize( $code ) );
	}
	
	private function Tokenize( $code )
	{
		$code = preg_replace( "~;;(?:.*?);;~sm", "", $code );
		$code = preg_replace( "~\;(?:.*?)$~m", "", $code );
		$code = str_replace( [ "\r", "\n", "\t" ], " ", $code );
		$code = str_replace( "(", " ( ", $code );
		$code = str_replace( ")", " ) ", $code );
		$code = preg_replace( "~\s{,2}~", " ", $code );
		return array_filter( explode( " ", $code ), function( $x ) { return strlen( $x ) > 0; } );
	}
	
	private function ReadFrom( array& $tokens )
	{
		if( sizeof( $tokens ) === 0 )
			throw new \Exception( "Unexpected end of input." );
		
		$token = array_shift( $tokens );
		
		if( $token === "(" )
		{
			$L = [ ];
			
			while( $tokens[0] !== ")" )
				$L[] = $this->ReadFrom( $tokens );
			
			array_shift( $tokens );
			return $L;
		}
		elseif( $token === ")" )
			throw new \Exception( "Unexpected closing parenthesis." );
		else
			return $this->Normalize( $token );
	}
	
	private function Normalize( $exp )
	{
		if( preg_match( "~^(?:\+|-)?[0-9]+(?:e(?:\+|-)?[0-9]+)?$~i", $exp ) === 1 )
			return intval( $exp );
		elseif( preg_match( "~^(?:\+|-)?[0-9]+\.[0-9]*|(?:\+|-)?[0-9]*\.[0-9]+$~", $exp ) === 1 )
			return floatval( $exp );
		else
			return strval( $exp );
	}
	
	private function ToString( $exp )
	{
		if( !is_array( $exp ) )
			return strval( $exp );
		else
		{
			$array = [ ];
			foreach( $exp as $k => $v )
			{
				if( !is_int( $k ) )
					$array[] = is_string( $k ) ? "'" . $k : $k;
				
				$array[] = $v;
			}
		}
			return "( " . implode( " ", array_map( function( $x ) { return $this->ToString( $x ); }, $array ) ) . " )";
	}
}

rlisp.php

<?php

/**
	Simple interface for running PHP-Lisp.
*/

if( php_sapi_name() !== "cli" )
	die( "This script may only be run from the command-line." );

include( "lisp.php" );

$env = Lispy\Environment::getGlobal();
$lisp = new Lispy\Lispy( $env );

$opts = getopt( "f::r::dq", [ "file::", "raw::", "dump", "quiet" ] );

if( isset( $opts["f"] ) )
	$opts["file"] = $opts["f"];

if( isset( $opts["r"] ) )
	$opts["raw"] = $opts["r"];

if( isset( $opts["d"] ) )
	$opts["dump"] = $opts["d"];

if( isset( $opts["q"] ) )
	$opts["quiet"] == $opts["q"];

if( !isset( $opts["file"] ) and !isset( $opts["raw"] ) )
	printUsage();

if( isset( $opts["quiet"] ) and $opts["quiet"] == true )
	$env->puts = function() { };

$source = null;

if( isset( $opts["file"] ) )
{
	if( is_string( $opts["file"] ) )
		$source = file_get_contents( $opts["file"] );
	else
		printUsage();
}
else
{
	if( is_string( $opts["raw"] ) )
		$source = $opts["raw"];
	else
		printUsage();
}

$lisp->Parse( $source );
$result = null;

try
{
	$result = $lisp->Evaluate();
}
catch( Exception $e )
{
	die( sprintf( "Fatal error: %s%s", $e->getMessage(), PHP_EOL ) );
}

if( isset( $opts["dump"] ) )
	var_dump( $result );
elseif( !isset( $opt["quiet"] ) )
	print( $result );
	
function printUsage()
{
	$usage = <<<STR
Usage:
	php -f rlisp.php [--flag=option] ...
	
Options:
	-f, --file  : Absolute or relative path to PHP-Lisp source file.
	-r, --raw   : Raw source code supplied directly to the command line.
	-d, --dump  : var_dump() the result
	-q, --quiet : Do not show any output.
STR;

	die( $usage );
}