perl/step6_file.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 _list_Q);
  11 use reader;
  12 use printer;
  13 use env;
  14 use core qw($core_ns);
  15
  16 # read
  17 sub READ {
  18     my $str = shift;
  19     return reader::read_str($str);
  20 }
  21
  22 # eval
  23 sub eval_ast {
  24     my($ast, $env) = @_;
  25     given (ref $ast) {
  26         when (/^Symbol/) {
  27             $env->get($ast);
  28         }
  29         when (/^List/) {
  30             my @lst = map {EVAL($_, $env)} @{$ast->{val}};
  31             return List->new(\@lst);
  32         }
  33         when (/^Vector/) {
  34             my @lst = map {EVAL($_, $env)} @{$ast->{val}};
  35             return Vector->new(\@lst);
  36         }
  37         when (/^HashMap/) {
  38             my $new_hm = {};
  39             foreach my $k (keys($ast->{val})) {
  40                 $new_hm->{$k} = EVAL($ast->get($k), $env);
  41             }
  42             return HashMap->new($new_hm);
  43         }
  44         default {
  45             return $ast;
  46         }
  47     }
  48 }
  49
  50 sub EVAL {
  51     my($ast, $env) = @_;
  52
  53     while (1) {
  54
  55     #print "EVAL: " . printer::_pr_str($ast) . "\n";
  56     if (! _list_Q($ast)) {
  57         return eval_ast($ast, $env);
  58     }
  59
  60     # apply list
  61     my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
  62     given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
  63         when (/^def!$/) {
  64             my $res = EVAL($a2, $env);
  65             return $env->set($a1, $res);
  66         }
  67         when (/^let\*$/) {
  68             my $let_env = Env->new($env);
  69             for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
  70                 $let_env->set($a1->nth($i), EVAL($a1->nth($i+1), $let_env));
  71             }
  72             $ast = $a2;
  73             $env = $let_env;
  74             # Continue loop (TCO)
  75         }
  76         when (/^do$/) {
  77             eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
  78             $ast = $ast->nth($#{$ast->{val}});
  79             # Continue loop (TCO)
  80         }
  81         when (/^if$/) {
  82             my $cond = EVAL($a1, $env);
  83             if ($cond eq $nil || $cond eq $false) {
  84                 $ast = $a3 ? $a3 : $nil;
  85             } else {
  86                 $ast = $a2;
  87             }
  88             # Continue loop (TCO)
  89         }
  90         when (/^fn\*$/) {
  91             return Function->new(\&EVAL, $a2, $env, $a1);
  92         }
  93         default {
  94             my $el = eval_ast($ast, $env);
  95             my $f = $el->nth(0);
  96             if ((ref $f) =~ /^Function/) {
  97                 $ast = $f->{ast};
  98                 $env = $f->gen_env($el->rest());
  99                 # Continue loop (TCO)
 100             } else {
 101                 return &{ $f }($el->rest());
 102             }
 103         }
 104     }
 105
 106     } # TCO while loop
 107 }
 108
 109 # print
 110 sub PRINT {
 111     my $exp = shift;
 112     return printer::_pr_str($exp);
 113 }
 114
 115 # repl
 116 my $repl_env = Env->new();
 117 sub REP {
 118     my $str = shift;
 119     return PRINT(EVAL(READ($str), $repl_env));
 120 }
 121
 122 # core.pl: defined using perl
 123 foreach my $n (%$core_ns) {
 124     $repl_env->set(Symbol->new($n), $core_ns->{$n});
 125 }
 126 $repl_env->set(Symbol->new('eval'), sub { EVAL($_[0]->nth(0), $repl_env); });
 127 my @_argv = map {String->new($_)}  @ARGV[1..$#ARGV];
 128 $repl_env->set(Symbol->new('*ARGV*'), List->new(\@_argv));
 129
 130 # core.mal: defined using the language itself
 131 REP("(def! not (fn* (a) (if a false true)))");
 132 REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
 133
 134 if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") {
 135     set_rl_mode("raw");
 136     shift @ARGV;
 137 }
 138 if (scalar(@ARGV) > 0) {
 139     REP("(load-file \"" . $ARGV[0] . "\")");
 140     exit 0;
 141 }
 142 while (1) {
 143     my $line = mal_readline("user> ");
 144     if (! defined $line) { last; }
 145     do {
 146         local $@;
 147         my $ret;
 148         eval {
 149             use autodie; # always "throw" errors
 150             print(REP($line), "\n");
 151             1;
 152         } or do {
 153             my $err = $@;
 154             given (ref $err) {
 155                 when (/^BlankException/) {
 156                     # ignore and continue
 157                 }
 158                 default {
 159                     chomp $err;
 160                     print "Error: $err\n";
 161                 }
 162             }
 163         };
 164     };
 165 }