Perl: add step3_env

2 files changed, 146 insertions, 0 deletions

diff --git a/perl/env.pm b/perl/env.pm
new file mode 100644
index 0000000..52ee5a1
--- /dev/null
+++ b/perl/env.pm
@@ -0,0 +1,53 @@
+package reader;
+use feature qw(switch);
+use strict;
+use warnings;
+use Exporter 'import';
+
+use Data::Dumper;
+
+{
+    package Env;
+    sub new  {
+        my ($class,$outer,$binds,$exprs) = @_;
+        my $data = { __outer__ => $outer };
+        bless $data => $class
+    }
+    sub find {
+        my ($self, $key) = @_;
+        if (exists $self->{$key}) { return $self; }
+        elsif ($self->{__outer__}) { return $self->{__outer__}->find($key); }
+        else { return undef; }
+    }
+    sub set {
+        my ($self, $key, $value) = @_;
+        $self->{$key} = $value;
+        return $value
+    }
+    sub get {
+        my ($self, $key) = @_;
+        my $env = $self->find($key);
+        die "'" . $key . "' not found" unless $env;
+        return $env->{$key};
+    }
+}
+
+#my $e1 = Env->new();
+#print Dumper($e1);
+#
+#my $e2 = Env->new();
+#$e2->set('abc', 123);
+#$e2->set('def', 456);
+#print Dumper($e2);
+#
+#my $e3 = Env->new($e2);
+#$e3->set('abc', 789);
+#$e3->set('ghi', 1024);
+#print Dumper($e3);
+#
+#print Dumper($e3->find('abc'));
+#print Dumper($e3->get('abc'));
+#print Dumper($e3->find('def'));
+#print Dumper($e3->get('def'));
+
+1;
diff --git a/perl/step3_env.pl b/perl/step3_env.pl
new file mode 100644
index 0000000..ac98f2d
--- /dev/null
+++ b/perl/step3_env.pl
@@ -0,0 +1,93 @@
+use strict;
+use warnings;
+use readline qw(readline);
+use feature qw(switch);
+use Data::Dumper;
+
+use reader;
+use printer;
+use env;
+
+# read
+sub READ {
+    my $str = shift;
+    return reader::read_str($str);
+}
+
+# eval
+sub eval_ast {
+    my($ast, $env) = @_;
+    given (ref $ast) {
+        when (/^Symbol/) {
+            $env->get($$ast);
+        }
+        when (/^List/) {
+            my @lst = map {EVAL($_, $env)} @$ast;
+            return List->new(\@lst);
+        }
+        default {
+            return $ast;
+        }
+    }
+}
+
+sub EVAL {
+    my($ast, $env) = @_;
+    #print "EVAL: " . printer::_pr_str($ast) . "\n";
+    if (! ((ref $ast) =~ /^List/)) {
+        return eval_ast($ast, $env);
+    }
+
+    # apply list
+    my ($a0, $a1, $a2, $a3) = @$ast;
+    given ($$a0) {
+        when (/^def!$/) {
+            my $res = EVAL($a2, $env);
+            return $env->set($$a1, $res);
+        }
+        when (/^let\*$/) {
+            my $let_env = Env->new($env);
+            for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
+                $let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
+            }
+            return EVAL($a2, $let_env);
+        }
+        default {
+            my $el = eval_ast($ast, $env);
+            my $f = $el->[0];
+            return &{ $f }($el->rest());
+        }
+    }
+}
+
+# print
+sub PRINT {
+    my $exp = shift;
+    return printer::_pr_str($exp);
+}
+
+# repl
+my $repl_env = Env->new();
+sub REP {
+    my $str = shift;
+    return PRINT(EVAL(READ($str), $repl_env));
+}
+
+$repl_env->set('+', sub { Integer->new(${$_[0][0]} + ${$_[0][1]})} );
+$repl_env->set('-', sub { Integer->new(${$_[0][0]} - ${$_[0][1]})} );
+$repl_env->set('*', sub { Integer->new(${$_[0][0]} * ${$_[0][1]})} );
+$repl_env->set('/', sub { Integer->new(${$_[0][0]} / ${$_[0][1]})} );
+
+while (1) {
+    my $line = readline("user> ");
+    if (! defined $line) { last; }
+    eval {
+        use autodie; # always "throw" errors
+        print(REP($line), "\n");
+        1;
+    }; 
+    if (my $err = $@) {
+        chomp $err;
+        print "Error: $err\n";
+    }
+}