A basic LISP interpreter in Perl

Env.pm

#!/usr/bin/env perl

use strict;
use warnings;

package Env;

sub new {
  my $class  = shift;
  my $names  = shift;
  my @values = shift;
  my $outer  = shift;

#  Not sure why this doesn't work when I do it this way
#  everywhere else..
#
#  my ($names, @values, $outer) = @_;

  my $self  = {
    _map   => {},
    _outer => $outer # Outer scope. Required for nested scopes
  };

  for my $name (@$names) {
    $self->{_map}->{$name} = shift(@values);
  }

  bless $self, $class;
  return $self;
}

sub lookup {
  my ($self, $sym) = @_;
  
  while(defined $self) {
    if(defined $self->{_map}->{$sym}) {
      return $self->{_map}->{$sym};
    }

    $self = $self->{_outer};
  }
  
  return undef;
}

1;

oyster.pl

#!/usr/bin/env perl

use strict;
use warnings;

use v5.10.1;
use Scalar::Util qw(looks_like_number);
use Data::Dumper;
use Env;

package Oyster;

sub tokenize {
  my ($str) = @_;
  $str =~ s/([()])/ $1 /g;
  return split(' ', $str);
}

sub parse {
  my ($tokens) = @_;
  
  die "Unexpected end of expression" unless (0 + @$tokens) > 0;

  my $token = shift(@$tokens);
  if($token eq '(') {
    my $out = [];

    while(@$tokens[0] ne ')') {
      push(@$out, parse($tokens));
    }
    shift(@$tokens);

    return $out;
  }
  elsif($token eq ')') {
    die "Unexpected closing paren";
  }
  else {
    return $token;
  }
}

sub run {
  my ($expr, $env) = @_;
  my $type         = ref($expr);

  if($type eq "") {
    # Numbers evaluate to themselves
    if(Scalar::Util::looks_like_number($expr)) {
      return $expr;
    }

    return $env->lookup($expr);
  }

  die "Invalid expression" unless $type eq "ARRAY";

  my @args = @$expr;
  my $fn   = shift(@args);

  # Evaluation of special forms
  given($fn) {
    # (quote exprs...) => (...)
    when('quote') {
      return [@args];
    }

    # (if pred true-expr false-expr)
    when('if') {
      if(run($args[0], $env)) {
        return run($args[1], $env);
      }
      else {
        return run($args[2], $env);
      }
    }
    
    # (set! sym expr)
    when('set!') {
      my $var = $env->lookup($args[0]);
      die "Unknown symbol '$args[0]'" unless defined $var;
      $$var = run($args[1], $env);

      return "set/$args[0]";
    }

    # (define sym expr)
    when('define') {
      $env->{_map}->{$args[0]} = run($args[1], $env);
      return "define/$args[0]";
    }

    # (lambda (vars...) expr)
    when('lambda') {
      return sub {
        my $env1 = new Env($args[0], @_, $env);
        return run($args[1], $env1);
      };
    }

    # (begin exprs...)
    when('begin') {
      my @exprs = @{$args[0]};
      my $last  = pop @exprs;

      foreach $expr (@exprs) {
        run($expr, $env);
      }

      return run($last, $env);
    }

    # (sym exprs...) (User-defined function call)
    default {
      my $sub = $env->lookup($fn);
      die "Unknown function '$fn'" unless defined $sub;

      foreach my $arg (@args) {
        $arg = run($arg, $env);
      }

      return $sub->(@args);
    }
  }
}

# The top-level environment
my $global = new Env([], [], undef);
$global->{_map} = {
  "+"    => sub { my ($l, $r) = @_; return $l + $r; },
  "-"    => sub { my ($l, $r) = @_; return $l - $r; },
  "*"    => sub { my ($l, $r) = @_; return $l * $r; },
  "/"    => sub { my ($l, $r) = @_; return $l / $r; },
  "cons" => sub { my ($x, $xs) = @_; my $out = [@$xs]; unshift(@$out, $x); return $out; },
  "car"  => sub { my ($xs) = @_; return @$xs[0]; },
  "cdr"  => sub { my ($xs) = @_; my $out = [@$xs]; shift(@$out); return $out; },
};

$Data::Dumper::Terse = 1;
print "oyster v0.1\n> ";
while(<>) {
  my @tokens = tokenize($_);
  my $input  = parse([@tokens]);
  my $out    = run($input, $global);

  if(ref($out) eq "") {
    print "$out\n";
  }
  else {
    print Data::Dumper->Dump($out) . "\n";
  }

  print "> ";
}