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