perl/step4_if_fn_do.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     #print "EVAL: " . printer::_pr_str($ast) . "\n";
  50     if (! _list_Q($ast)) {
  51         return eval_ast($ast, $env);
  52     }
  53
  54     # apply list
  55     my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
  56     given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
  57         when (/^def!$/) {
  58             my $res = EVAL($a2, $env);
  59             return $env->set($$a1, $res);
  60         }
  61         when (/^let\*$/) {
  62             my $let_env = Env->new($env);
  63             for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
  64                 $let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
  65             }
  66             return EVAL($a2, $let_env);
  67         }
  68         when (/^do$/) {
  69             my $el = eval_ast($ast->rest(), $env);
  70             return $el->nth($#{$el->{val}});
  71         }
  72         when (/^if$/) {
  73             my $cond = EVAL($a1, $env);
  74             if ($cond eq $nil || $cond eq $false) {
  75                 return $a3 ? EVAL($a3, $env) : $nil;
  76             } else {
  77                 return EVAL($a2, $env);
  78             }
  79         }
  80         when (/^fn\*$/) {
  81             return sub {
  82                 #print "running fn*\n";
  83                 my $args = $_[0];
  84                 return EVAL($a2, Env->new($env, $a1, $args));
  85             };
  86         }
  87         default {
  88             my $el = eval_ast($ast, $env);
  89             my $f = $el->nth(0);
  90             return &{ $f }($el->rest());
  91         }
  92     }
  93 }
  94
  95 # print
  96 sub PRINT {
  97     my $exp = shift;
  98     return printer::_pr_str($exp);
  99 }
 100
 101 # repl
 102 my $repl_env = Env->new();
 103 sub REP {
 104     my $str = shift;
 105     return PRINT(EVAL(READ($str), $repl_env));
 106 }
 107
 108 # core.pl: defined using perl
 109 foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
 110
 111 # core.mal: defined using the language itself
 112 REP("(def! not (fn* (a) (if a false true)))");
 113
 114 while (1) {
 115     my $line = mal_readline("user> ");
 116     if (! defined $line) { last; }
 117     do {
 118         local $@;
 119         my $ret;
 120         eval {
 121             use autodie; # always "throw" errors
 122             print(REP($line), "\n");
 123             1;
 124         } or do {
 125             my $err = $@;
 126             given (ref $err) {
 127                 when (/^BlankException/) {
 128                     # ignore and continue
 129                 }
 130                 default {
 131                     chomp $err;
 132                     print "Error: $err\n";
 133                 }
 134             }
 135         };
 136     };
 137 }