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);
  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 (! $ast->isa('Mal::List')) {
  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                 return EVAL($a2, Mal::Env->new($env, $a1, \@_));
  78             });
  79         }
  80         default {
  81             my @el = @{eval_ast($ast, $env)};
  82             my $f = shift @el;
  83             return &$f(@el);
  84         }
  85     }
  86 }
  87
  88 # print
  89 sub PRINT {
  90     my $exp = shift;
  91     return printer::_pr_str($exp);
  92 }
  93
  94 # repl
  95 my $repl_env = Mal::Env->new();
  96 sub REP {
  97     my $str = shift;
  98     return PRINT(EVAL(READ($str), $repl_env));
  99 }
 100
 101 # core.pl: defined using perl
 102 foreach my $n (keys %core::ns) {
 103     $repl_env->set(Mal::Symbol->new($n), $core::ns{$n});
 104 }
 105
 106 # core.mal: defined using the language itself
 107 REP(q[(def! not (fn* (a) (if a false true)))]);
 108
 109 if (@ARGV && $ARGV[0] eq "--raw") {
 110     set_rl_mode("raw");
 111 }
 112 while (1) {
 113     my $line = mal_readline("user> ");
 114     if (! defined $line) { last; }
 115     do {
 116         local $@;
 117         my $ret;
 118         eval {
 119             print(REP($line), "\n");
 120             1;
 121         } or do {
 122             my $err = $@;
 123             if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
 124                 # ignore and continue
 125             } else {
 126                 chomp $err;
 127                 print "Error: $err\n";
 128             }
 129         };
 130     };
 131 }