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