perl/step9_try.pl

   1 use strict;
   2 use warnings FATAL => qw(all);
   3 no if $] >= 5.018, warnings => "experimental::smartmatch";
   4 use File::Basename;
   5 use lib dirname (__FILE__);
   6 use readline qw(mal_readline set_rl_mode);
   7 use feature qw(switch);
   8 use Data::Dumper;
   9
  10 use types qw($nil $true $false _sequential_Q _symbol_Q _list_Q);
  11 use reader;
  12 use printer;
  13 use env;
  14 use core qw($core_ns);
  15 use interop qw(pl_to_mal);
  16
  17 # read
  18 sub READ {
  19     my $str = shift;
  20     return reader::read_str($str);
  21 }
  22
  23 # eval
  24 sub is_pair {
  25     my ($x) = @_;
  26     return _sequential_Q($x) && scalar(@$x) > 0;
  27 }
  28
  29 sub quasiquote {
  30     my ($ast) = @_;
  31     if (!is_pair($ast)) {
  32         return List->new([Symbol->new("quote"), $ast]);
  33     } elsif (_symbol_Q($ast->[0]) && ${$ast->[0]} eq 'unquote') {
  34         return $ast->[1];
  35     } elsif (is_pair($ast->[0]) && _symbol_Q($ast->[0]->[0]) &&
  36              ${$ast->[0]->[0]} eq 'splice-unquote') {
  37         return List->new([Symbol->new("concat"),
  38                           $ast->[0]->[1],
  39                           quasiquote($ast->rest())]);
  40     } else {
  41         return List->new([Symbol->new("cons"),
  42                           quasiquote($ast->[0]),
  43                           quasiquote($ast->rest())]);
  44     }
  45 }
  46
  47 sub is_macro_call {
  48     my ($ast, $env) = @_;
  49     if (_list_Q($ast) &&
  50         _symbol_Q($ast->[0]) &&
  51         $env->find($ast->[0])) {
  52         my ($f) = $env->get($ast->[0]);
  53         if ((ref $f) =~ /^Function/) {
  54             return $f->{ismacro};
  55         }
  56     }
  57     return 0;
  58 }
  59
  60 sub macroexpand {
  61     my ($ast, $env) = @_;
  62     while (is_macro_call($ast, $env)) {
  63         my $mac = $env->get($ast->[0]);
  64         $ast = $mac->apply($ast->rest());
  65     }
  66     return $ast;
  67 }
  68
  69
  70 sub eval_ast {
  71     my($ast, $env) = @_;
  72     given (ref $ast) {
  73         when (/^Symbol/) {
  74             $env->get($ast);
  75         }
  76         when (/^List/) {
  77             my @lst = map {EVAL($_, $env)} @$ast;
  78             return List->new(\@lst);
  79         }
  80         when (/^Vector/) {
  81             my @lst = map {EVAL($_, $env)} @$ast;
  82             return Vector->new(\@lst);
  83         }
  84         when (/^HashMap/) {
  85             my $new_hm = {};
  86             foreach my $k (keys( %{ $ast->{val} })) {
  87                 $new_hm->{$k} = EVAL($ast->get($k), $env);
  88             }
  89             return HashMap->new($new_hm);
  90         }
  91         default {
  92             return $ast;
  93         }
  94     }
  95 }
  96
  97 sub EVAL {
  98     my($ast, $env) = @_;
  99
 100     while (1) {
 101
 102     #print "EVAL: " . printer::_pr_str($ast) . "\n";
 103     if (! _list_Q($ast)) {
 104         return eval_ast($ast, $env);
 105     }
 106     @$ast or return $ast;
 107
 108     # apply list
 109     $ast = macroexpand($ast, $env);
 110     if (! _list_Q($ast)) {
 111         return eval_ast($ast, $env);
 112     }
 113
 114     my ($a0, $a1, $a2, $a3) = @$ast;
 115     if (!$a0) { return $ast; }
 116     given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
 117         when (/^def!$/) {
 118             my $res = EVAL($a2, $env);
 119             return $env->set($a1, $res);
 120         }
 121         when (/^let\*$/) {
 122             my $let_env = Env->new($env);
 123             for(my $i=0; $i < scalar(@$a1); $i+=2) {
 124                 $let_env->set($a1->[$i], EVAL($a1->[$i+1], $let_env));
 125             }
 126             $ast = $a2;
 127             $env = $let_env;
 128             # Continue loop (TCO)
 129         }
 130         when (/^quote$/) {
 131             return $a1;
 132         }
 133         when (/^quasiquote$/) {
 134             $ast = quasiquote($a1);
 135             # Continue loop (TCO)
 136         }
 137         when (/^defmacro!$/) {
 138             my $func = EVAL($a2, $env);
 139             $func->{ismacro} = 1;
 140             return $env->set($a1, $func);
 141         }
 142         when (/^macroexpand$/) {
 143             return macroexpand($a1, $env);
 144         }
 145         when (/^try\*$/) {
 146             do {
 147                 local $@;
 148                 my $ret;
 149                 eval {
 150                     use autodie; # always "throw" errors
 151                     $ret = EVAL($a1, $env);
 152                      1;
 153                 } or do {
 154                     my $err = $@;
 155                     if ($a2 && ${$a2->[0]} eq "catch\*") {
 156                         my $exc;
 157                         if (ref $err) {
 158                             $exc = $err;
 159                         } else {
 160                             $exc = String->new(substr $err, 0, -1);
 161                         }
 162                         return EVAL($a2->[2], Env->new($env,
 163                                                         List->new([$a2->[1]]),
 164                                                         List->new([$exc])));
 165                     } else {
 166                         die $err;
 167                     }
 168                 };
 169                 return $ret;
 170             };
 171         }
 172         when (/^do$/) {
 173             eval_ast($ast->slice(1, $#$ast-1), $env);
 174             $ast = $ast->[$#$ast];
 175             # Continue loop (TCO)
 176         }
 177         when (/^if$/) {
 178             my $cond = EVAL($a1, $env);
 179             if ($cond eq $nil || $cond eq $false) {
 180                 $ast = $a3 ? $a3 : $nil;
 181             } else {
 182                 $ast = $a2;
 183             }
 184             # Continue loop (TCO)
 185         }
 186         when (/^fn\*$/) {
 187             return Function->new(\&EVAL, $a2, $env, $a1);
 188         }
 189         default {
 190             my $el = eval_ast($ast, $env);
 191             my $f = $el->[0];
 192             if ((ref $f) =~ /^Function/) {
 193                 $ast = $f->{ast};
 194                 $env = $f->gen_env($el->rest());
 195                 # Continue loop (TCO)
 196             } else {
 197                 return &{ $f }($el->rest());
 198             }
 199         }
 200     }
 201
 202     } # TCO while loop
 203 }
 204
 205 # print
 206 sub PRINT {
 207     my $exp = shift;
 208     return printer::_pr_str($exp);
 209 }
 210
 211 # repl
 212 my $repl_env = Env->new();
 213 sub REP {
 214     my $str = shift;
 215     return PRINT(EVAL(READ($str), $repl_env));
 216 }
 217
 218 # core.pl: defined using perl
 219 foreach my $n (%$core_ns) {
 220     $repl_env->set(Symbol->new($n), $core_ns->{$n});
 221 }
 222 $repl_env->set(Symbol->new('eval'), sub { EVAL($_[0]->[0], $repl_env); });
 223 my @_argv = map {String->new($_)}  @ARGV[1..$#ARGV];
 224 $repl_env->set(Symbol->new('*ARGV*'), List->new(\@_argv));
 225
 226 # core.mal: defined using the language itself
 227 REP("(def! not (fn* (a) (if a false true)))");
 228 REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
 229 REP("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))");
 230
 231
 232 if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") {
 233     set_rl_mode("raw");
 234     shift @ARGV;
 235 }
 236 if (scalar(@ARGV) > 0) {
 237     REP("(load-file \"" . $ARGV[0] . "\")");
 238     exit 0;
 239 }
 240 while (1) {
 241     my $line = mal_readline("user> ");
 242     if (! defined $line) { last; }
 243     do {
 244         local $@;
 245         my $ret;
 246         eval {
 247             use autodie; # always "throw" errors
 248             print(REP($line), "\n");
 249             1;
 250         } or do {
 251             my $err = $@;
 252             given (ref $err) {
 253                 when (/^BlankException/) {
 254                     # ignore and continue
 255                 }
 256                 default {
 257                     if (ref $err) {
 258                         print "Error: ".printer::_pr_str($err)."\n";
 259                     } else {
 260                         chomp $err;
 261                         print "Error: $err\n";
 262                     }
 263                 }
 264             }
 265         };
 266     };
 267 }