Perl: add step4_if_fn_do

- Move string/printing tests to the bottom of tests/step4_if_fn_do

7 files changed, 264 insertions, 15 deletions

diff --git a/perl/core.pm b/perl/core.pm
new file mode 100644
index 0000000..2f5604b
--- /dev/null
+++ b/perl/core.pm
@@ -0,0 +1,55 @@
+package core;
+use strict;
+use warnings;
+use Exporter 'import';
+our @EXPORT_OK = qw($core_ns);
+
+use types qw(_sequential_Q _equal_Q $nil $true $false _list_Q);
+use printer qw(_pr_str);
+
+use Data::Dumper;
+
+# String functions
+
+sub pr_str {
+    return String->new(join(" ", map {_pr_str($_, 1)} @{$_[0]}));
+}
+
+sub str {
+    return String->new(join("", map {_pr_str($_, 0)} @{$_[0]}));
+}
+
+sub prn {
+    print join(" ", map {_pr_str($_, 1)} @{$_[0]}) . "\n";
+    return $nil
+}
+
+sub println {
+    print join(" ", map {_pr_str($_, 0)} @{$_[0]}) . "\n";
+    return $nil
+}
+
+
+our $core_ns = {
+    '=' =>  sub { _equal_Q($_[0][0], $_[0][1]) ? $true : $false },
+
+    'pr-str' =>  sub { pr_str($_[0]) },
+    'str' =>     sub { str($_[0]) },
+    'prn' =>     sub { prn($_[0]) },
+    'println' => sub { println($_[0]) },
+    '<' =>  sub { ${$_[0][0]} < ${$_[0][1]} ? $true : $false },
+    '<=' => sub { ${$_[0][0]} <= ${$_[0][1]} ? $true : $false },
+    '>' =>  sub { ${$_[0][0]} > ${$_[0][1]} ? $true : $false },
+    '>=' => sub { ${$_[0][0]} >= ${$_[0][1]} ? $true : $false },
+    '+' =>  sub { Integer->new(${$_[0][0]} + ${$_[0][1]})},
+    '-' =>  sub { Integer->new(${$_[0][0]} - ${$_[0][1]})},
+    '*' =>  sub { Integer->new(${$_[0][0]} * ${$_[0][1]})},
+    '/' =>  sub { Integer->new(${$_[0][0]} / ${$_[0][1]})},
+
+    'list'  => sub { $_[0] },
+    'list?' => sub { _list_Q($_[0][0]) ? $true : $false },
+    'empty?' => sub { scalar(@{$_[0][0]}) == 0 ? $true : $false },
+    'count' => sub { Integer->new(scalar(@{$_[0][0]})) },
+};
+
+1;
diff --git a/perl/env.pm b/perl/env.pm
index 52ee5a1..77d42af 100644
--- a/perl/env.pm
+++ b/perl/env.pm
@@ -11,6 +11,19 @@ use Data::Dumper;
     sub new  {
         my ($class,$outer,$binds,$exprs) = @_;
         my $data = { __outer__ => $outer };
+        if ($binds) {
+            for (my $i=0; $i<scalar(@{$binds}); $i++) {
+                if (${$binds->[$i]} eq "&") {
+                    # variable length arguments
+                    my @earr = @$exprs; # get the array
+                    my @new_arr = @earr[$i..$#earr]; # slice it
+                    $data->{${$binds->[$i+1]}} = List->new(\@new_arr);
+                    last;
+                } else {
+                    $data->{${$binds->[$i]}} = $exprs->[$i];
+                }
+            }
+        }
         bless $data => $class
     }
     sub find {
diff --git a/perl/printer.pm b/perl/printer.pm
index 94219d4..d5bc306 100644
--- a/perl/printer.pm
+++ b/perl/printer.pm
@@ -1,31 +1,42 @@
 package printer;
-use feature qw(switch);
 use strict;
 use warnings;
+use feature qw(switch);
 use Exporter 'import';
 our @EXPORT_OK = qw( _pr_str );
 
 use types qw($nil $true $false);
 
 sub _pr_str {
-    my($obj) = @_;
+    my($obj, $print_readably) = @_;
+    my($_r) = (defined $print_readably) ? $print_readably : 1;
     given (ref $obj) {
         when(/^List/) {
-            return '(' . join(' ', map {_pr_str($_)} @$obj) . ')';
+            return '(' . join(' ', map {_pr_str($_, $_r)} @$obj) . ')';
         }
         when(/^Vector/) {
-            return '[' . join(' ', map {_pr_str($_)} @$obj) . ']';
+            return '[' . join(' ', map {_pr_str($_, $_r)} @$obj) . ']';
         }
         when(/^HashMap/) {
             my @elems = ();
             foreach my $key (keys %$obj) {
-                push(@elems, _pr_str(String->new($key)));
-                push(@elems, _pr_str($obj->{$key}));
+                push(@elems, _pr_str(String->new($key), $_r));
+                push(@elems, _pr_str($obj->{$key}, $_r));
             }
 
             return '{' . join(' ', @elems) . '}';
         }
-        when(/^String/) { return '"' . $$obj . '"'; }
+        when(/^String/) {
+            if ($_r) {
+                my $str = $$obj;
+                $str =~ s/\\/\\\\/g;
+                $str =~ s/"/\\"/g;
+                $str =~ s/\n/\\n"/g;
+                return '"' . $str . '"';
+            } else {
+                return $$obj;
+            }
+        }
         when(/^CODE/)   { return '<builtin_fn* ' . $obj . '>'; }
         default         { return $$obj; }
     }
diff --git a/perl/reader.pm b/perl/reader.pm
index ecbf522..35af099 100644
--- a/perl/reader.pm
+++ b/perl/reader.pm
@@ -30,7 +30,12 @@ sub read_atom {
     my $token = $rdr->next();
     given ($token) {
         when(/^-?[0-9]+$/) { return Integer->new($token) }
-        when(/^"/) { return String->new(substr $token, 1, -1) }
+        when(/^"/) {
+            my $str = substr $token, 1, -1;
+            $str =~ s/\\"/"/g;
+            $str =~ s/\\n/\n/g;
+            return String->new($str)
+        }
         when(/^nil$/) { return $nil }
         when(/^true$/) { return $true }
         when(/^false$/) { return $false }
diff --git a/perl/step1_read_print.pl b/perl/step1_read_print.pl
index 8d96ab5..48c31ec 100644
--- a/perl/step1_read_print.pl
+++ b/perl/step1_read_print.pl
@@ -3,13 +3,13 @@ use warnings;
 use readline qw(readline);
 use feature qw(switch);
 
-use reader qw(read_str);
-use printer qw(_pr_str);
+use reader;
+use printer;
 
 # read
 sub READ {
     my $str = shift;
-    return read_str($str);
+    return reader::read_str($str);
 }
 
 # eval
@@ -21,7 +21,7 @@ sub EVAL {
 # print
 sub PRINT {
     my $exp = shift;
-    return _pr_str($exp);
+    return printer::_pr_str($exp);
 }
 
 # repl
diff --git a/perl/step4_if_fn_do.pl b/perl/step4_if_fn_do.pl
new file mode 100644
index 0000000..7f7e1ab
--- /dev/null
+++ b/perl/step4_if_fn_do.pl
@@ -0,0 +1,115 @@
+use strict;
+use warnings;
+use readline qw(readline);
+use feature qw(switch);
+use Data::Dumper;
+
+use types qw($nil $true $false);
+use reader;
+use printer;
+use env;
+use core qw($core_ns);
+
+# 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 ((ref $a0) =~ /^Symbol/ ? $$a0 : $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);
+        }
+        when (/^do$/) {
+            my $el = eval_ast($ast->rest(), $env);
+            return $el->[$#{$el}];
+        }
+        when (/^if$/) {
+            my $cond = EVAL($a1, $env);
+            if ($cond eq $nil || $cond eq $false) {
+                return $a3 ? EVAL($a3, $env) : $nil;
+            } else {
+                return EVAL($a2, $env);
+            }
+        }
+        when (/^fn\*$/) {
+            return sub {
+                #print "running fn*\n";
+                my $args = $_[0];
+                return EVAL($a2, Env->new($env, $a1, $args));
+            };
+        }
+        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));
+}
+
+# core.pl: defined using perl
+foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
+
+# core.mal: defined using the language itself
+REP("(def! not (fn* (a) (if a false true)))");
+
+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";
+    }
+}
diff --git a/perl/types.pm b/perl/types.pm
index 054c303..44be6b9 100644
--- a/perl/types.pm
+++ b/perl/types.pm
@@ -1,8 +1,51 @@
 package types;
 use strict;
 use warnings;
+use feature qw(switch);
 use Exporter 'import';
-our @EXPORT_OK = qw( $nil $true $false);
+our @EXPORT_OK = qw(_sequential_Q _equal_Q
+                    $nil $true $false
+                    _list_Q);
+
+use Data::Dumper;
+
+# General functions
+
+sub _sequential_Q {
+    return _list_Q($_[0]) || _vector_Q($_[0])
+}
+
+sub _equal_Q {
+    my ($a, $b) = @_;
+    my ($ota, $otb) = (ref $a, ref $b);
+    #my $ota = ref $a;
+    #my $otb = ref $b;
+    if (!(($ota eq $otb) || (_sequential_Q($a) && _sequential_Q($b)))) {
+        return 0;
+    }
+    given (ref $a) {
+        when (/^Symbol/) {
+            return $$a eq $$b;
+        }
+        when (/^List/ || /^Vector/) {
+            if (! scalar(@$a) == scalar(@$b)) {
+                return 0;
+            }
+            for (my $i=0; $i<scalar(@$a); $i++) {
+                if (! _equal_Q($a->[$i], $b->[$i])) {
+                    return 0;
+                }
+            }
+            return 1;
+        }
+        default {
+            return $$a eq $$b;
+        }
+    }
+    return 0;
+}
+
+# Scalars
 
 {
     package Nil;
@@ -41,21 +84,28 @@ sub _symbol_Q { ref $_[0] =~ /^Symbol/ }
 }
 
 
+# Lists
+
 {
     package List;
-    use Data::Dumper;
     sub new  { my $class = shift; bless $_[0], $class }
     sub rest { my @arr = @{$_[0]}; List->new([@arr[1..$#arr]]); }
 }
 
-sub _list_Q { ref $_[0] =~ /^Symbol/ }
+sub _list_Q { (ref $_[0]) =~ /^List/ }
+
 
+# Vectors
 
 {
     package Vector;
     sub new  { my $class = shift; bless $_[0], $class }
 }
 
+sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
+
+
+# Hash Maps
 
 {
     package HashMap;