#!/usr/bin/perl -w
#
# Evaluate lisp expressions
#
# From Paul Graham's _The Roots of Lisp_
# http://paulgraham.com/rootsoflisp.html
#
# Pretty close to a direct transliteration,
# not simplified to make comparison easier.

use re 'eval'; #use recursive regex for parsing
use strict;

# From the paper, a lisp expressions is either an atom, which is
# a sequence of letters, or a list of zero or more expressions,
# separated by whitespace and enclosed by parentheses.
my $atom = qr{[a-zA-Z]+};
my $exp; $exp = qr{\(\)|$atom|\((??{$exp})(?:\s+(??{$exp}))*\)}s;

# Something to test the evaluator with
my @tests = (
"(quote A)","(quote (D E F))","(atom (quote B))","(atom (quote (c b a)
+))",
"(eq (quote a) (quote a))","(eq (quote b) (quote a))","(eq (quote ()) 
+(quote ()))",
"(car (quote (a b c)))","(cdr (quote (a b c)))",
"(cons (quote a) (quote (b c (d))))",
"(cond ((atom (quote (a b))) (quote TRUE)) 
       ((atom (quote a)) (quote NOT)))",
"((lambda (x) (cons x (quote (a b)))) (quote z))",
# 3+2?
"((label add (lambda (x y) 
               (cond ((eq (car x) (quote ())) y) 
                     ((quote t) (add (cdr x) (cons (quote s) y)))))) 
               (quote (s s s ())) (quote (s s ())))",
# Fibonacci
"((label fib (lambda (n)
    (cond ((eq (car n) (quote ())) (quote (s ())))
          ((eq (car (cdr n)) (quote ())) (quote (s ())))
          ((quote t) ((label add (lambda (x y) 
                        (cond ((eq (car x) (quote ())) y) 
                              ((quote t) (add (cdr x) (cons (quote s) 
+y)))))) 
                         (fib (cdr n)) (fib (cdr (cdr n)))))))) 
    (quote (s s s s s ())))");

for (@tests)
{  
    print "$_ => ";
    print ev($_,())."\n";
}


sub ev
{
    local $_ = shift; my %a = @_;
    
    if(atom($_) eq "t")
    {  
        return $a{$_}; 
    }
    elsif(/^\(($exp)(.*)\)$/s and atom($1) eq "t")
    {
        if(/^\(quote\s+($exp)\)$/s)
        {
            return $1;
        }
        elsif(/^\(atom\s+($exp)\)$/s)
        {
            return atom(ev($1,%a));
        }
        elsif(/^\(eq\s+($exp)\s*($exp)\)$/s)
        {
            my $a = ev($1,%a);
            my $c = ev($2,%a);
            return "t" if ($a eq $c and atom($a));
            return "()";
        }
        elsif(/^\(car\s+($exp)\)$/s)
        {
            my $x = ev($1, %a);
            $x =~ /^\(($exp).*\)$/s;
            return $1;
        }
        elsif(/^\(cdr\s+($exp)\)$/s)
        {   
            my $x = ev($1, %a);
            $x =~ /^\($exp\s+(.*)\)$/s;
            return "($1)";
        }
        elsif(/^\(cons\s+($exp)\s+($exp)\)$/s)
        {
            my $h = ev($1, %a);
            my $t = ev($2, %a);
            $t=~/^\((.*)\)$/;
            return "($h $1)";
        }
        elsif(/^\(cond\s+(.*)\)$/s)
        {
            return evcon($1, %a);
        }
        else
        {   
            /^\(($exp)\s+(.*)\)$/s;
            return ev("($a{$1} $2)",%a);
        }
    }
    elsif(/^\(\(label\s+($atom)\s*\((lambda\s+$exp\s*$exp)\)\s*\)\s*(.
+*)\)$/s)
    {
        $a{$1}="($2)";
        return ev("($1 $3)",%a);
    }
    elsif(/^\(\(lambda\s+($exp)\s+($exp)\)\s*(.*)\)$/s)
    {
        my ($params, $f, $vals) = ($1,$2,$3);
        $vals =~ s/($exp)\s*/ev($1,%a)." "/ges;
        $vals =~ s/\s$//s; #strip off trailing space
        $vals = "($vals)";
        my %b = evlis($params,$vals,%a);
        return ev($f, %b);
    }
    else
    {
        # Uncommenting this line causes a segfault on perl5.8.4
        # even if nothing ever gets here.  Strange...
        #die "Syntax Error: $_\n";
    }
}

sub atom 
{
    my $x = shift;
    return "t" if $x=~/^$atom$/;
    return "t" if $x=~/^()$/;
    return "()";
}

sub evlis
{
    my ($p, $v, %a) = @_;

    if($p=~/^\(($exp)\s*(.*)\)$/s)
    {
        my ($h, $t) = ($1,$2);
        if($v=~/^\(($exp)\s*(.*)\)$/s)
        {
            $a{$h} = $1;
            return evlis("($t)","($2)",%a);
        }
    }
    
    return %a;
}

sub evcon
{
    my $c = shift; my %a = @_;
    my ($h, $t) = $c=~/^($exp)\s*(.*)$/s;
    my ($p, $q) = $h=~/^\(($exp)\s+(.*)\)$/s;
    if(ev($p,%a) eq "t")
    {
        return ev($q,%a);
    }
    else
    {
        return evcon($t,%a);
    }
}
[download]