perl/step5_tco.pl

   1 use strict;
   2 use warnings FATAL => qw(all);
   3 use readline qw(mal_readline);
   4 use feature qw(switch);
   5 use Data::Dumper;
   6
   7 use types qw($nil $true $false _list_Q);
   8 use reader;
   9 use printer;
  10 use env;
  11 use core qw($core_ns);
  12
  13 # read
  14 sub READ {
  15     my $str = shift;
  16     return reader::read_str($str);
  17 }
  18
  19 # eval
  20 sub eval_ast {
  21     my($ast, $env) = @_;
  22     given (ref $ast) {
  23         when (/^Symbol/) {
  24             $env->get($$ast);
  25         }
  26         when (/^List/) {
  27             my @lst = map {EVAL($_, $env)} @{$ast->{val}};
  28             return List->new(\@lst);
  29         }
  30         when (/^Vector/) {
  31             my @lst = map {EVAL($_, $env)} @{$ast->{val}};
  32             return Vector->new(\@lst);
  33         }
  34         when (/^HashMap/) {
  35             my $new_hm = {};
  36             foreach my $k (keys($ast->{val})) {
  37                 $new_hm->{$k} = EVAL($ast->get($k), $env);
  38             }
  39             return HashMap->new($new_hm);
  40         }
  41         default {
  42             return $ast;
  43         }
  44     }
  45 }
  46
  47 sub EVAL {
  48     my($ast, $env) = @_;
  49
  50     while (1) {
  51
  52     #print "EVAL: " . printer::_pr_str($ast) . "\n";
  53     if (! _list_Q($ast)) {
  54         return eval_ast($ast, $env);
  55     }
  56
  57     # apply list
  58     my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
  59     given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
  60         when (/^def!$/) {
  61             my $res = EVAL($a2, $env);
  62             return $env->set($$a1, $res);
  63         }
  64         when (/^let\*$/) {
  65             my $let_env = Env->new($env);
  66             for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
  67                 $let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
  68             }
  69             $ast = $a2;
  70             $env = $let_env;
  71             # Continue loop (TCO)
  72         }
  73         when (/^do$/) {
  74             eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
  75             $ast = $ast->nth($#{$ast->{val}});
  76             # Continue loop (TCO)
  77         }
  78         when (/^if$/) {
  79             my $cond = EVAL($a1, $env);
  80             if ($cond eq $nil || $cond eq $false) {
  81                 $ast = $a3 ? $a3 : $nil;
  82             } else {
  83                 $ast = $a2;
  84             }
  85             # Continue loop (TCO)
  86         }
  87         when (/^fn\*$/) {
  88             return Function->new(\&EVAL, $a2, $env, $a1);
  89         }
  90         default {
  91             my $el = eval_ast($ast, $env);
  92             my $f = $el->nth(0);
  93             if ((ref $f) =~ /^Function/) {
  94                 $ast = $f->{ast};
  95                 $env = $f->gen_env($el->rest());
  96                 # Continue loop (TCO)
  97             } else {
  98                 return &{ $f }($el->rest());
  99             }
 100         }
 101     }
 102
 103     } # TCO while loop
 104 }
 105
 106 # print
 107 sub PRINT {
 108     my $exp = shift;
 109     return printer::_pr_str($exp);
 110 }
 111
 112 # repl
 113 my $repl_env = Env->new();
 114 sub REP {
 115     my $str = shift;
 116     return PRINT(EVAL(READ($str), $repl_env));
 117 }
 118
 119 # core.pl: defined using perl
 120 foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
 121
 122 # core.mal: defined using the language itself
 123 REP("(def! not (fn* (a) (if a false true)))");
 124
 125 while (1) {
 126     my $line = mal_readline("user> ");
 127     if (! defined $line) { last; }
 128     do {
 129         local $@;
 130         my $ret;
 131         eval {
 132             use autodie; # always "throw" errors
 133             print(REP($line), "\n");
 134             1;
 135         } or do {
 136             my $err = $@;
 137             given (ref $err) {
 138                 when (/^BlankException/) {
 139                     # ignore and continue
 140                 }
 141                 default {
 142                     chomp $err;
 143                     print "Error: $err\n";
 144                 }
 145             }
 146         };
 147     };
 148 }