perl/stepA_mal.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 ('pl*') {
 135             return pl_to_mal(eval(${$a1}));
 136         }
 137         when ('try*') {
 138             do {
 139                 local $@;
 140                 my $ret;
 141                 eval {
 142                     use autodie; # always "throw" errors
 143                     $ret = EVAL($a1, $env);
 144                      1;
 145                 } or do {
 146                     my $err = $@;
 147                     if ($a2 && ${$a2->[0]} eq 'catch*') {
 148                         my $exc;
 149                         if (ref $err) {
 150                             $exc = $err;
 151                         } else {
 152                             $exc = Mal::String->new(substr $err, 0, -1);
 153                         }
 154                         my $catch_env =
 155                             Mal::Env->new($env, Mal::List->new([$a2->[1]]),
 156                                                 Mal::List->new([$exc]));
 157                         return EVAL($a2->[2], $catch_env);
 158                     } else {
 159                         die $err;
 160                     }
 161                 };
 162                 return $ret;
 163             };
 164         }
 165         when ('do') {
 166             eval_ast($ast->slice(1, $#$ast-1), $env);
 167             $ast = $ast->[$#$ast];
 168             # Continue loop (TCO)
 169         }
 170         when ('if') {
 171             my $cond = EVAL($a1, $env);
 172             if ($cond eq $nil || $cond eq $false) {
 173                 $ast = $a3 ? $a3 : $nil;
 174             } else {
 175                 $ast = $a2;
 176             }
 177             # Continue loop (TCO)
 178         }
 179         when ('fn*') {
 180             return Mal::Function->new(\&EVAL, $a2, $env, $a1);
 181         }
 182         default {
 183             my @el = @{eval_ast($ast, $env)};
 184             my $f = shift @el;
 185             if ($f->isa('Mal::Function')) {
 186                 $ast = $f->{ast};
 187                 $env = $f->gen_env(\@el);
 188                 # Continue loop (TCO)
 189             } else {
 190                 return &$f(@el);
 191             }
 192         }
 193     }
 194
 195     } # TCO while loop
 196 }
 197
 198 # print
 199 sub PRINT {
 200     my $exp = shift;
 201     return printer::_pr_str($exp);
 202 }
 203
 204 # repl
 205 my $repl_env = Mal::Env->new();
 206 sub REP {
 207     my $str = shift;
 208     return PRINT(EVAL(READ($str), $repl_env));
 209 }
 210
 211 # core.pl: defined using perl
 212 foreach my $n (keys %core::ns) {
 213     $repl_env->set(Mal::Symbol->new($n), $core::ns{$n});
 214 }
 215 $repl_env->set(Mal::Symbol->new('eval'),
 216                bless sub { EVAL($_[0], $repl_env); }, 'Mal::CoreFunction');
 217 my @_argv = map {Mal::String->new($_)}  @ARGV[1..$#ARGV];
 218 $repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv));
 219
 220 # core.mal: defined using the language itself
 221 REP(q[(def! *host-language* "perl")]);
 222 REP(q[(def! not (fn* (a) (if a false true)))]);
 223 REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))]);
 224 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)))))))]);
 225
 226 if (@ARGV && $ARGV[0] eq "--raw") {
 227     set_rl_mode("raw");
 228     shift @ARGV;
 229 }
 230 if (@ARGV) {
 231     REP(qq[(load-file "$ARGV[0]")]);
 232     exit 0;
 233 }
 234 REP(q[(println (str "Mal [" *host-language* "]"))]);
 235 while (1) {
 236     my $line = mal_readline("user> ");
 237     if (! defined $line) { last; }
 238     do {
 239         local $@;
 240         my $ret;
 241         eval {
 242             use autodie; # always "throw" errors
 243             print(REP($line), "\n");
 244             1;
 245         } or do {
 246             my $err = $@;
 247             if ($err->isa('Mal::BlankException')) {
 248                 # ignore and continue
 249             } else {
 250                 if (ref $err) {
 251                     print "Error: ".printer::_pr_str($err)."\n";
 252                 } else {
 253                     chomp $err;
 254                     print "Error: $err\n";
 255                 }
 256             }
 257         };
 258     };
 259 }