perl/step6_file.pl

   1 use strict;
   2 use warnings;
   3 no if $] >= 5.018, warnings => "experimental::smartmatch";
   4 use feature qw(switch);
   5 use File::Basename;
   6 use lib dirname (__FILE__);
   7
   8 use Data::Dumper;
   9 use List::Util qw(pairs pairmap);
  10 use Scalar::Util qw(blessed);
  11
  12 use readline qw(mal_readline set_rl_mode);
  13 use types qw($nil $true $false _list_Q);
  14 use reader;
  15 use printer;
  16 use env;
  17 use core;
  18
  19 # read
  20 sub READ {
  21     my $str = shift;
  22     return reader::read_str($str);
  23 }
  24
  25 # eval
  26 sub eval_ast {
  27     my($ast, $env) = @_;
  28     if ($ast->isa('Mal::Symbol')) {
  29         return $env->get($ast);
  30     } elsif ($ast->isa('Mal::Sequence')) {
  31         return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
  32     } elsif ($ast->isa('Mal::HashMap')) {
  33         return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
  34     } else {
  35         return $ast;
  36     }
  37 }
  38
  39 sub EVAL {
  40     my($ast, $env) = @_;
  41
  42     while (1) {
  43
  44     #print "EVAL: " . printer::_pr_str($ast) . "\n";
  45     if (! _list_Q($ast)) {
  46         return eval_ast($ast, $env);
  47     }
  48
  49     # apply list
  50     my ($a0, $a1, $a2, $a3) = @$ast;
  51     if (!$a0) { return $ast; }
  52     given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
  53         when ('def!') {
  54             my $res = EVAL($a2, $env);
  55             return $env->set($a1, $res);
  56         }
  57         when ('let*') {
  58             my $let_env = Mal::Env->new($env);
  59             foreach my $pair (pairs @$a1) {
  60                 my ($k, $v) = @$pair;
  61                 $let_env->set($k, EVAL($v, $let_env));
  62             }
  63             $ast = $a2;
  64             $env = $let_env;
  65             # Continue loop (TCO)
  66         }
  67         when ('do') {
  68             eval_ast($ast->slice(1, $#$ast-1), $env);
  69             $ast = $ast->[$#$ast];
  70             # Continue loop (TCO)
  71         }
  72         when ('if') {
  73             my $cond = EVAL($a1, $env);
  74             if ($cond eq $nil || $cond eq $false) {
  75                 $ast = $a3 ? $a3 : $nil;
  76             } else {
  77                 $ast = $a2;
  78             }
  79             # Continue loop (TCO)
  80         }
  81         when ('fn*') {
  82             return Mal::Function->new(\&EVAL, $a2, $env, $a1);
  83         }
  84         default {
  85             my @el = @{eval_ast($ast, $env)};
  86             my $f = shift @el;
  87             if ($f->isa('Mal::Function')) {
  88                 $ast = $f->{ast};
  89                 $env = $f->gen_env(\@el);
  90                 # Continue loop (TCO)
  91             } else {
  92                 return &$f(@el);
  93             }
  94         }
  95     }
  96
  97     } # TCO while loop
  98 }
  99
 100 # print
 101 sub PRINT {
 102     my $exp = shift;
 103     return printer::_pr_str($exp);
 104 }
 105
 106 # repl
 107 my $repl_env = Mal::Env->new();
 108 sub REP {
 109     my $str = shift;
 110     return PRINT(EVAL(READ($str), $repl_env));
 111 }
 112
 113 # core.pl: defined using perl
 114 foreach my $n (keys %core::ns) {
 115     $repl_env->set(Mal::Symbol->new($n), $core::ns{$n});
 116 }
 117 $repl_env->set(Mal::Symbol->new('eval'),
 118                bless sub { EVAL($_[0], $repl_env); }, 'Mal::CoreFunction');
 119 my @_argv = map {Mal::String->new($_)}  @ARGV[1..$#ARGV];
 120 $repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv));
 121
 122 # core.mal: defined using the language itself
 123 REP(q[(def! not (fn* (a) (if a false true)))]);
 124 REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))]);
 125
 126 if (@ARGV && $ARGV[0] eq "--raw") {
 127     set_rl_mode("raw");
 128     shift @ARGV;
 129 }
 130 if (@ARGV) {
 131     REP(qq[(load-file "$ARGV[0]")]);
 132     exit 0;
 133 }
 134 while (1) {
 135     my $line = mal_readline("user> ");
 136     if (! defined $line) { last; }
 137     do {
 138         local $@;
 139         my $ret;
 140         eval {
 141             print(REP($line), "\n");
 142             1;
 143         } or do {
 144             my $err = $@;
 145             if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
 146                 # ignore and continue
 147             } else {
 148                 chomp $err;
 149                 print "Error: $err\n";
 150             }
 151         };
 152     };
 153 }