perl/step4_if_fn_do.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     if ($ast->isa('Symbol')) {
  26         return $env->get($ast);
  27     } elsif ($ast->isa('List')) {
  28         my @lst = map {EVAL($_, $env)} @$ast;
  29         return List->new(\@lst);
  30     } elsif ($ast->isa('Vector')) {
  31         my @lst = map {EVAL($_, $env)} @$ast;
  32         return Vector->new(\@lst);
  33     } elsif ($ast->isa('HashMap')) {
  34         my $new_hm = {};
  35         foreach my $k (keys( %{ $ast->{val} })) {
  36             $new_hm->{$k} = EVAL($ast->get($k), $env);
  37         }
  38         return HashMap->new($new_hm);
  39     } else {
  40         return $ast;
  41     }
  42 }
  43
  44 sub EVAL {
  45     my($ast, $env) = @_;
  46     #print "EVAL: " . printer::_pr_str($ast) . "\n";
  47     if (! _list_Q($ast)) {
  48         return eval_ast($ast, $env);
  49     }
  50
  51     # apply list
  52     my ($a0, $a1, $a2, $a3) = @$ast;
  53     if (!$a0) { return $ast; }
  54     given ($a0->isa('Symbol') ? $$a0 : $a0) {
  55         when (/^def!$/) {
  56             my $res = EVAL($a2, $env);
  57             return $env->set($a1, $res);
  58         }
  59         when (/^let\*$/) {
  60             my $let_env = Env->new($env);
  61             for(my $i=0; $i < scalar(@$a1); $i+=2) {
  62                 $let_env->set($a1->[$i], EVAL($a1->[$i+1], $let_env));
  63             }
  64             return EVAL($a2, $let_env);
  65         }
  66         when (/^do$/) {
  67             my $el = eval_ast($ast->rest(), $env);
  68             return $el->[$#$el];
  69         }
  70         when (/^if$/) {
  71             my $cond = EVAL($a1, $env);
  72             if ($cond eq $nil || $cond eq $false) {
  73                 return $a3 ? EVAL($a3, $env) : $nil;
  74             } else {
  75                 return EVAL($a2, $env);
  76             }
  77         }
  78         when (/^fn\*$/) {
  79             return sub {
  80                 #print "running fn*\n";
  81                 my $args = $_[0];
  82                 return EVAL($a2, Env->new($env, $a1, $args));
  83             };
  84         }
  85         default {
  86             my $el = eval_ast($ast, $env);
  87             my $f = $el->[0];
  88             return &{ $f }($el->rest());
  89         }
  90     }
  91 }
  92
  93 # print
  94 sub PRINT {
  95     my $exp = shift;
  96     return printer::_pr_str($exp);
  97 }
  98
  99 # repl
 100 my $repl_env = Env->new();
 101 sub REP {
 102     my $str = shift;
 103     return PRINT(EVAL(READ($str), $repl_env));
 104 }
 105
 106 # core.pl: defined using perl
 107 foreach my $n (%$core_ns) {
 108     $repl_env->set(Symbol->new($n), $core_ns->{$n});
 109 }
 110
 111 # core.mal: defined using the language itself
 112 REP(q[(def! not (fn* (a) (if a false true)))]);
 113
 114 if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") {
 115     set_rl_mode("raw");
 116 }
 117 while (1) {
 118     my $line = mal_readline("user> ");
 119     if (! defined $line) { last; }
 120     do {
 121         local $@;
 122         my $ret;
 123         eval {
 124             use autodie; # always "throw" errors
 125             print(REP($line), "\n");
 126             1;
 127         } or do {
 128             my $err = $@;
 129             given (ref $err) {
 130                 when (/^BlankException/) {
 131                     # ignore and continue
 132                 }
 133                 default {
 134                     chomp $err;
 135                     print "Error: $err\n";
 136                 }
 137             }
 138         };
 139     };
 140 }