Perl: add step5_tco

- Make all warnings fatal/exceptions.

11 files changed, 161 insertions, 11 deletions

diff --git a/docs/step_notes.txt b/docs/step_notes.txt
index 4e3cd2e..4bdbb61 100644
--- a/docs/step_notes.txt
+++ b/docs/step_notes.txt
@@ -125,13 +125,14 @@ Step Notes:
 
 - step5_tco
     - types module:
-        - function type:
+        - mal function type:
             - stores: func, exp, env, params
             - func is EVAL in native mal case, otherwise reference to
               platform function
             - if metadata support, then store exp, env, params as
               metadata
-        - update function printer to show function types
+    - printer
+        - add printing of mal function type
     - EVAL:
         - while loop around whole thing
         - cases where we directly return result of EVAL, instead set
diff --git a/perl/core.pm b/perl/core.pm
index 2f5604b..3f2215e 100644
--- a/perl/core.pm
+++ b/perl/core.pm
@@ -1,6 +1,6 @@
 package core;
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use Exporter 'import';
 our @EXPORT_OK = qw($core_ns);
 
diff --git a/perl/printer.pm b/perl/printer.pm
index d5bc306..7880798 100644
--- a/perl/printer.pm
+++ b/perl/printer.pm
@@ -1,6 +1,6 @@
 package printer;
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use feature qw(switch);
 use Exporter 'import';
 our @EXPORT_OK = qw( _pr_str );
@@ -37,6 +37,10 @@ sub _pr_str {
                 return $$obj;
             }
         }
+        when(/^Function/) {
+            return '<fn* ' . _pr_str($obj->{params}) .
+                   ' ' . _pr_str($obj->{ast}) . '>';
+        }
         when(/^CODE/)   { return '<builtin_fn* ' . $obj . '>'; }
         default         { return $$obj; }
     }
diff --git a/perl/reader.pm b/perl/reader.pm
index 35af099..6fac066 100644
--- a/perl/reader.pm
+++ b/perl/reader.pm
@@ -1,7 +1,7 @@
 package reader;
 use feature qw(switch);
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use Exporter 'import';
 our @EXPORT_OK = qw( read_str );
 
diff --git a/perl/step0_repl.pl b/perl/step0_repl.pl
index 8295cc0..d20b167 100644
--- a/perl/step0_repl.pl
+++ b/perl/step0_repl.pl
@@ -1,5 +1,5 @@
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use readline qw(readline);
 
 # read
diff --git a/perl/step1_read_print.pl b/perl/step1_read_print.pl
index 48c31ec..36956aa 100644
--- a/perl/step1_read_print.pl
+++ b/perl/step1_read_print.pl
@@ -1,5 +1,5 @@
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use readline qw(readline);
 use feature qw(switch);
 
diff --git a/perl/step2_eval.pl b/perl/step2_eval.pl
index c3910bd..a448385 100644
--- a/perl/step2_eval.pl
+++ b/perl/step2_eval.pl
@@ -1,5 +1,5 @@
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use readline qw(readline);
 use feature qw(switch);
 use Data::Dumper;
diff --git a/perl/step3_env.pl b/perl/step3_env.pl
index ac98f2d..eb4d8c6 100644
--- a/perl/step3_env.pl
+++ b/perl/step3_env.pl
@@ -1,5 +1,5 @@
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use readline qw(readline);
 use feature qw(switch);
 use Data::Dumper;
diff --git a/perl/step4_if_fn_do.pl b/perl/step4_if_fn_do.pl
index 7f7e1ab..98d3923 100644
--- a/perl/step4_if_fn_do.pl
+++ b/perl/step4_if_fn_do.pl
@@ -1,5 +1,5 @@
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use readline qw(readline);
 use feature qw(switch);
 use Data::Dumper;
diff --git a/perl/step5_tco.pl b/perl/step5_tco.pl
new file mode 100644
index 0000000..846c7c2
--- /dev/null
+++ b/perl/step5_tco.pl
@@ -0,0 +1,121 @@
+use strict;
+use warnings FATAL => qw(all);
+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) = @_;
+
+    while (1) {
+
+    #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$/) {
+            eval_ast($ast->slice(1, $#{$ast}-1), $env);
+            $ast = $ast->[$#{$ast}];
+        }
+        when (/^if$/) {
+            my $cond = EVAL($a1, $env);
+            if ($cond eq $nil || $cond eq $false) {
+                $ast = $a3 ? $a3 : $nil;
+            } else {
+                $ast = $a2;
+            }
+        }
+        when (/^fn\*$/) {
+            return Function->new(\&EVAL, $a2, $env, $a1);
+        }
+        default {
+            my $el = eval_ast($ast, $env);
+            my $f = $el->[0];
+            if ((ref $f) =~ /^Function/) {
+                $ast = $f->{ast};
+                $env = $f->gen_env($el->rest());
+            } else {
+                return &{ $f }($el->rest());
+            }
+        }
+    }
+
+    } # TCO while loop
+}
+
+# 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 44be6b9..83da6e2 100644
--- a/perl/types.pm
+++ b/perl/types.pm
@@ -1,6 +1,6 @@
 package types;
 use strict;
-use warnings;
+use warnings FATAL => qw(all);
 use feature qw(switch);
 use Exporter 'import';
 our @EXPORT_OK = qw(_sequential_Q _equal_Q
@@ -90,6 +90,7 @@ sub _symbol_Q { ref $_[0] =~ /^Symbol/ }
     package List;
     sub new  { my $class = shift; bless $_[0], $class }
     sub rest { my @arr = @{$_[0]}; List->new([@arr[1..$#arr]]); }
+    sub slice { my @arr = @{$_[0]}; List->new([@arr[$_[1]..$_[2]]]); }
 }
 
 sub _list_Q { (ref $_[0]) =~ /^List/ }
@@ -112,4 +113,27 @@ sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
     sub new  { my $class = shift; bless $_[0], $class }
 }
 
+
+# Functions
+
+{
+    package Function;
+    sub new  {
+        my $class = shift;
+        my ($eval, $ast, $env, $params) = @_;
+        bless {'eval'=>$eval,
+               'ast'=>$ast,
+               'env'=>$env,
+               'params'=>$params}, $class
+    }
+    sub gen_env {
+        my %self = %{$_[0]};
+        return Env->new($self{env}, $self{params}, $_[1]);
+    }
+    sub apply {
+        my %self = %{$_[0]};
+        return &{ $self{eval} }($self{ast}, gen_env($_[1]));
+    }
+}
+
 1;