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