Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

lisp evaluator

by sleepingsquirrel (Hermit)
on Jan 17, 2005 at 21:02 UTC ( #422819=snippet: print w/ replies, xml ) Need Help??

Description: Here's a perl version of the lisp evaluator from Paul Graham's The Roots of Lisp. Update: Added another test case, fixed a bug in the code, discovered a strange way to cause a segfault (uncomment out the "die" statement below).
#!/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);
    }
}


Comment on lisp evaluator
Download Code
Re: lisp evaluator
by metaperl (Curate) on Jan 17, 2005 at 21:26 UTC

Back to Snippets Section

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://422819]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (12)
As of 2014-10-20 13:07 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (76 votes), past polls