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->($ast->rest());
  65     }
  66     return $ast;
  67 }
  68
  69
  70 sub eval_ast {
  71     my($ast, $env) = @_;
  72     if ($ast->isa('Symbol')) {
  73         return $env->get($ast);
  74     } elsif ($ast->isa('List')) {
  75         my @lst = map {EVAL($_, $env)} @$ast;
  76         return List->new(\@lst);
  77     } elsif ($ast->isa('Vector')) {
  78         my @lst = map {EVAL($_, $env)} @$ast;
  79         return Vector->new(\@lst);
  80     } elsif ($ast->isa('HashMap')) {
  81         my $new_hm = {};
  82         foreach my $k (keys( %{ $ast->{val} })) {
  83             $new_hm->{$k} = EVAL($ast->get($k), $env);
  84         }
  85         return HashMap->new($new_hm);
  86     } else {
  87         return $ast;
  88     }
  89 }
  90
  91 sub EVAL {
  92     my($ast, $env) = @_;
  93
  94     while (1) {
  95
  96     #print "EVAL: " . printer::_pr_str($ast) . "\n";
  97     if (! _list_Q($ast)) {
  98         return eval_ast($ast, $env);
  99     }
 100     @$ast or return $ast;
 101
 102     # apply list
 103     $ast = macroexpand($ast, $env);
 104     if (! _list_Q($ast)) {
 105         return eval_ast($ast, $env);
 106     }
 107
 108     my ($a0, $a1, $a2, $a3) = @$ast;
 109     if (!$a0) { return $ast; }
 110     given ($a0->isa('Symbol') ? $$a0 : $a0) {
 111         when (/^def!$/) {
 112             my $res = EVAL($a2, $env);
 113             return $env->set($a1, $res);
 114         }
 115         when (/^let\*$/) {
 116             my $let_env = Env->new($env);
 117             for(my $i=0; $i < scalar(@$a1); $i+=2) {
 118                 $let_env->set($a1->[$i], EVAL($a1->[$i+1], $let_env));
 119             }
 120             $ast = $a2;
 121             $env = $let_env;
 122             # Continue loop (TCO)
 123         }
 124         when (/^quote$/) {
 125             return $a1;
 126         }
 127         when (/^quasiquote$/) {
 128             $ast = quasiquote($a1);
 129             # Continue loop (TCO)
 130         }
 131         when (/^defmacro!$/) {
 132             my $func = EVAL($a2, $env);
 133             $func->{ismacro} = 1;
 134             return $env->set($a1, $func);
 135         }
 136         when (/^macroexpand$/) {
 137             return macroexpand($a1, $env);
 138         }
 139         when (/^try\*$/) {
 140             do {
 141                 local $@;
 142                 my $ret;
 143                 eval {
 144                     use autodie; # always "throw" errors
 145                     $ret = EVAL($a1, $env);
 146                      1;
 147                 } or do {
 148                     my $err = $@;
 149                     if ($a2 && ${$a2->[0]} eq "catch\*") {
 150                         my $exc;
 151                         if (ref $err) {
 152                             $exc = $err;
 153                         } else {
 154                             $exc = String->new(substr $err, 0, -1);
 155                         }
 156                         return EVAL($a2->[2], Env->new($env,
 157                                                         List->new([$a2->[1]]),
 158                                                         List->new([$exc])));
 159                     } else {
 160                         die $err;
 161                     }
 162                 };
 163                 return $ret;
 164             };
 165         }
 166         when (/^do$/) {
 167             eval_ast($ast->slice(1, $#$ast-1), $env);
 168             $ast = $ast->[$#$ast];
 169             # Continue loop (TCO)
 170         }
 171         when (/^if$/) {
 172             my $cond = EVAL($a1, $env);
 173             if ($cond eq $nil || $cond eq $false) {
 174                 $ast = $a3 ? $a3 : $nil;
 175             } else {
 176                 $ast = $a2;
 177             }
 178             # Continue loop (TCO)
 179         }
 180         when (/^fn\*$/) {
 181             return Function->new(\&EVAL, $a2, $env, $a1);
 182         }
 183         default {
 184             my $el = eval_ast($ast, $env);
 185             my $f = $el->[0];
 186             if ((ref $f) =~ /^Function/) {
 187                 $ast = $f->{ast};
 188                 $env = $f->gen_env($el->rest());
 189                 # Continue loop (TCO)
 190             } else {
 191                 return &{ $f }($el->rest());
 192             }
 193         }
 194     }
 195
 196     } # TCO while loop
 197 }
 198
 199 # print
 200 sub PRINT {
 201     my $exp = shift;
 202     return printer::_pr_str($exp);
 203 }
 204
 205 # repl
 206 my $repl_env = Env->new();
 207 sub REP {
 208     my $str = shift;
 209     return PRINT(EVAL(READ($str), $repl_env));
 210 }
 211
 212 # core.pl: defined using perl
 213 foreach my $n (%$core_ns) {
 214     $repl_env->set(Symbol->new($n), $core_ns->{$n});
 215 }
 216 $repl_env->set(Symbol->new('eval'), sub { EVAL($_[0]->[0], $repl_env); });
 217 my @_argv = map {String->new($_)}  @ARGV[1..$#ARGV];
 218 $repl_env->set(Symbol->new('*ARGV*'), List->new(\@_argv));
 219
 220 # core.mal: defined using the language itself
 221 REP(q[(def! not (fn* (a) (if a false true)))]);
 222 REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))]);
 223 REP(q[(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)))))))]);
 224
 225
 226 if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") {
 227     set_rl_mode("raw");
 228     shift @ARGV;
 229 }
 230 if (scalar(@ARGV) > 0) {
 231     REP(qq[(load-file "$ARGV[0]")]);
 232     exit 0;
 233 }
 234 while (1) {
 235     my $line = mal_readline("user> ");
 236     if (! defined $line) { last; }
 237     do {
 238         local $@;
 239         my $ret;
 240         eval {
 241             use autodie; # always "throw" errors
 242             print(REP($line), "\n");
 243             1;
 244         } or do {
 245             my $err = $@;
 246             given (ref $err) {
 247                 when (/^BlankException/) {
 248                     # ignore and continue
 249                 }
 250                 default {
 251                     if (ref $err) {
 252                         print "Error: ".printer::_pr_str($err)."\n";
 253                     } else {
 254                         chomp $err;
 255                         print "Error: $err\n";
 256                     }
 257                 }
 258             }
 259         };
 260     };
 261 }