Simple Scheme interpreter in Perl(inspired by lis.py http://norvig.com/lispy.html)

lis.pl

#!perl
use strict;
use warnings;

package Lispl;

use Scalar::Util qw(blessed looks_like_number);
use List::Util qw(reduce);

my $global_env;

sub tokenize {
    my $s = shift;
    $s =~ s/([()])/ $1 /g;
    return [ grep { $_ } split /\s/, $s ];
}

sub read_from {
    my $tokens = shift;

    if (scalar @{$tokens} == 0) {
        die "unexpected EOF while reading\n";
    }

    my $token = shift @{$tokens};
    if ($token eq '(') {
        my @L;
        while ($tokens->[0] ne ')') {
            push @L, read_from($tokens);
        }
        shift @{$tokens}; # pop off ')'
        return [ @L ];
    } elsif ($token eq ')') {
        die "unexpected ')'\n";
    } else {
        return atom($token);
    }
}

sub atom {
    my $token = shift;

    if (looks_like_number($token)) {
        return $token;
    } else {
        return Lispl::Symbol->new($token);
    }
}

sub read {
    my $s = shift;
    return read_from(tokenize($s));
}

*parse = \&read;

sub evaluate {
    my ($x, $env) = @_;
    $env ||= $global_env;

    if (blessed $x && $x->isa("Lispl::Symbol")) {
        return $env->find("$x")->{"$x"};
    } elsif (ref $x eq 'ARRAY') {
        if ($x->[0] eq 'quote') {
            my (undef, $exp) = @{$x};
            return $exp;
        } elsif ($x->[0] eq 'if') {
            my (undef, $test, $conseq, $alt) = @{$x};
            return evaluate( evaluate($test, $env) ? $conseq : $alt);
        } elsif ($x->[0] eq 'set!') {
            my (undef, $var, $exp) = @{$x};
            $env->find("$var", 1)->{"$var"} = evaluate($exp, $env);
            return "$var";
        } elsif ($x->[0] eq 'define') {
            my (undef, $var, $exp) = @{$x};
            $env->{binding}->{$var} = evaluate($exp, $env);
        } elsif ($x->[0] eq 'lambda') {
            my (undef, $vars, $exp) = @{$x};
            return sub {
                evaluate($exp, Lispl::Env->new($vars, [ @_ ], $env));
            };
        } elsif ($x->[0] eq 'begin') {
            my $val;
            for my $exp (@{$x}[1..(scalar @{$x} - 1)]) {
                $val = evaluate($exp, $env);
            }
            return $val;
        } else {
            my @exps = map { evaluate($_, $env) } @{$x};
            my $proc = shift @exps;
            return $proc->(@exps);
        }
    } else {
        $x;
    }
}

sub add_globals {
    my $env = shift;

    no warnings 'once'; # for suppress reduce's $a, $b warning
    $env->merge({
        '+'       => sub { reduce { $a + $b } @_ },
        '-'       => sub { reduce { $a - $b } @_ },
        '*'       => sub { reduce { $a * $b } @_ },
        '/'       => sub { reduce { $a / $b } @_ },
        'not'     => sub { !$_[0] },
        '>'       => sub { $_[0] > $_[1] ? 1 : 0},
        '<'       => sub { $_[0] < $_[1] ? 1 : 0},
        '>='      => sub { $_[0] >= $_[1] ? 1 : 0},
        '<='      => sub { $_[0] <= $_[1] ? 1 : 0},
        '='       => sub { $_[0] == $_[1] ? 1 : 0},
        'equal?'  => sub {
            if ($_[0] =~ /^\w+$/ && $_[1] =~ /^\w+$/) {
                $_[0] eq $_[1] ? 1 : 0;
            } else {
                $_[0] == $_[1] ? 1 : 0;
            }
        },
        'eq?'     => sub { $_[0] == $_[1] },
        'length'  => sub {
            if (ref $_[0] eq 'ARRAY') {
                scalar @{$_[0]};
            } else {
                length $_[0];
            }
        },
        'cons'    => sub { [$_[0], $_[1]] },
        'car'     => sub { $_[0]->[0] },
        'cdr'     => sub { [ @{$_[0]}[1..(scalar @{$_[0]} - 1)] ] },
        'append'  => sub {
            reduce {
                my @a = ref $a eq 'ARRAY' ? @{$a} : $a;
                my @b = ref $b eq 'ARRAY' ? @{$b} : $b;
                return [ @a, @b ];
            } @_;
        },
        'list'    => sub { [ @_ ] },
        'list?'   => sub { ref $_[0] eq 'ARRAY' ? 1 : 0 },
        'null?'   => sub {
            (ref $_[0] eq 'ARRAY' && scalar @{$_[0]} == 0) ? 1 : 0;
        },
        'symbol?' => sub {
            (blessed $_[0] && $_[0]->isa("Lispl::Symbol")) ? 1 : 0;
        },
    });

    return $env;
}

$global_env = add_globals( Lispl::Env->new );

sub to_string {
    my $exp = shift;

    if (ref $exp eq 'ARRAY') {
        return '(' . join(' ', map { to_string($_) } @{$exp}) .')';
    } else {
        return "$exp";
    }
}

sub repl {
    local $| = 1;
    while (1) {
        print "lis.pl> " if -t STDIN;
        chomp(my $input = <STDIN>);
        next if !$input || $input =~ m/^\s+$/;

        eval {
            my $val = evaluate(parse($input));
            print "$input => " unless -t STDIN;
            print to_string($val), "\n" if defined $val;
        };
        if (my $e = $@) {
            print "$input ===>  " unless -t STDIN;
            print $e, "\n";
        };

        last if eof STDIN;
    }

    print "bye\n" if -t STDIN;
}

package
    Lispl::Env;

sub new {
    my ($class, $params, $args, $outer) = @_;
    $params ||= [];
    $args   ||= [];

    bless {
        binding => _zip($params, $args),
        outer   => $outer,
    }, $class;
}

sub find {
    my ($self, $key, $is_set) = @_;
    if (defined $is_set || exists $self->{binding}->{$key}) {
        $self->{binding};
    } else {
        unless ($self->{outer}) {
            die "Not found symbol '$key'\n";
        }
        $self->{outer}->find($key);
    }
}

sub merge {
    my ($self, $env) = @_;
    $self->{binding} = { %{$self->{binding}}, %{$env} };
}

sub _zip {
    my ($a, $b) = @_;
    my ($len_a, $len_b) = (scalar @{$a}, scalar @{$b});
    my $max = $len_a >= $len_b ? $len_a : $len_b;

    return {
        map {
            $a->[$_] => $b->[$_];
        } 0..($max-1)
    };
}

package
    Lispl::Symbol;

use overload
    '""' => sub { ${$_[0]} },
    fallback => 1;

sub new {
    my ($class, $str) = @_;
    bless \$str, $class;
}

package main;
Lispl::repl;

test.txt

12345678
(quote 12345678)
(quote lispl)
(quote (a b c))
(+ 1 2 3 4 5 6 7 8 9 10)
(- 2 1 0)
(* 3 3 3)
(/ 50 5 10)
(not 0)
(> 1 2)
(< 3 1)
(>= 1 1)
(<= 2 2)
(= 10 10)
(equal? (quote aaa) (quote aaa))
(equal? 100 80)
(length (quote aaa))
(length (quote (a b c d e)))
(car (quote (a b)))
(cdr (quote (a b)))
(append (quote (a b)) (quote c) (quote d) (quote (e f)))
(list 1 2 3 4 5 (quote (a b c)) 6 7 8 9 10)
(list? 1)
(list? (quote (1)))
(null? (quote ()))
(null? (quote (1)))
(null? 10)
(symbol? 10)
(symbol? (quote a))
(if (- 10 5) (quote then) (quote else))
(if 0 (quote then) (quote else))

(set! var (quote lispl))
var
(define myadd (lambda (a b) (+ a b)))
(myadd 10 20)
(begin (define mysub1 (lambda (a) (- a 1))) (set! var (mysub1 100)) var)
(not-defined a b)
)
var