perl/step7_quote.pl

   1 use strict;
   2 use warnings FATAL => "recursion";
   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 _sequential_Q _symbol_Q _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 is_pair {
  27     my ($x) = @_;
  28     return _sequential_Q($x) && @$x;
  29 }
  30
  31 sub quasiquote {
  32     my ($ast) = @_;
  33     if (!is_pair($ast)) {
  34         return Mal::List->new([Mal::Symbol->new("quote"), $ast]);
  35     } elsif (_symbol_Q($ast->[0]) && ${$ast->[0]} eq 'unquote') {
  36         return $ast->[1];
  37     } elsif (is_pair($ast->[0]) && _symbol_Q($ast->[0]->[0]) &&
  38              ${$ast->[0]->[0]} eq 'splice-unquote') {
  39         return Mal::List->new([Mal::Symbol->new("concat"),
  40                           $ast->[0]->[1],
  41                           quasiquote($ast->rest())]);
  42     } else {
  43         return Mal::List->new([Mal::Symbol->new("cons"),
  44                           quasiquote($ast->[0]),
  45                           quasiquote($ast->rest())]);
  46     }
  47 }
  48
  49 sub eval_ast {
  50     my($ast, $env) = @_;
  51     if ($ast->isa('Mal::Symbol')) {
  52         return $env->get($ast);
  53     } elsif ($ast->isa('Mal::Sequence')) {
  54         return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
  55     } elsif ($ast->isa('Mal::HashMap')) {
  56         return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
  57     } else {
  58         return $ast;
  59     }
  60 }
  61
  62 sub EVAL {
  63     my($ast, $env) = @_;
  64
  65     while (1) {
  66
  67     #print "EVAL: " . printer::_pr_str($ast) . "\n";
  68     if (! _list_Q($ast)) {
  69         return eval_ast($ast, $env);
  70     }
  71
  72     # apply list
  73     my ($a0, $a1, $a2, $a3) = @$ast;
  74     if (!$a0) { return $ast; }
  75     given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
  76         when ('def!') {
  77             my $res = EVAL($a2, $env);
  78             return $env->set($a1, $res);
  79         }
  80         when ('let*') {
  81             my $let_env = Mal::Env->new($env);
  82             foreach my $pair (pairs @$a1) {
  83                 my ($k, $v) = @$pair;
  84                 $let_env->set($k, EVAL($v, $let_env));
  85             }
  86             $ast = $a2;
  87             $env = $let_env;
  88             # Continue loop (TCO)
  89         }
  90         when ('quote') {
  91             return $a1;
  92         }
  93         when ('quasiquote') {
  94             $ast = quasiquote($a1);
  95             # Continue loop (TCO)
  96         }
  97         when ('do') {
  98             eval_ast($ast->slice(1, $#$ast-1), $env);
  99             $ast = $ast->[$#$ast];
 100             # Continue loop (TCO)
 101         }
 102         when ('if') {
 103             my $cond = EVAL($a1, $env);
 104             if ($cond eq $nil || $cond eq $false) {
 105                 $ast = $a3 ? $a3 : $nil;
 106             } else {
 107                 $ast = $a2;
 108             }
 109             # Continue loop (TCO)
 110         }
 111         when ('fn*') {
 112             return Mal::Function->new(\&EVAL, $a2, $env, $a1);
 113         }
 114         default {
 115             my @el = @{eval_ast($ast, $env)};
 116             my $f = shift @el;
 117             if ($f->isa('Mal::Function')) {
 118                 $ast = $f->{ast};
 119                 $env = $f->gen_env(\@el);
 120                 # Continue loop (TCO)
 121             } else {
 122                 return &$f(@el);
 123             }
 124         }
 125     }
 126
 127     } # TCO while loop
 128 }
 129
 130 # print
 131 sub PRINT {
 132     my $exp = shift;
 133     return printer::_pr_str($exp);
 134 }
 135
 136 # repl
 137 my $repl_env = Mal::Env->new();
 138 sub REP {
 139     my $str = shift;
 140     return PRINT(EVAL(READ($str), $repl_env));
 141 }
 142
 143 # core.pl: defined using perl
 144 foreach my $n (keys %core::ns) {
 145     $repl_env->set(Mal::Symbol->new($n), $core::ns{$n});
 146 }
 147 $repl_env->set(Mal::Symbol->new('eval'),
 148                bless sub { EVAL($_[0], $repl_env); }, 'Mal::CoreFunction');
 149 my @_argv = map {Mal::String->new($_)}  @ARGV[1..$#ARGV];
 150 $repl_env->set(Mal::Symbol->new('*ARGV*'), Mal::List->new(\@_argv));
 151
 152 # core.mal: defined using the language itself
 153 REP(q[(def! not (fn* (a) (if a false true)))]);
 154 REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))]);
 155
 156 if (@ARGV && $ARGV[0] eq "--raw") {
 157     set_rl_mode("raw");
 158     shift @ARGV;
 159 }
 160 if (@ARGV) {
 161     REP(qq[(load-file "$ARGV[0]")]);
 162     exit 0;
 163 }
 164 while (1) {
 165     my $line = mal_readline("user> ");
 166     if (! defined $line) { last; }
 167     do {
 168         local $@;
 169         my $ret;
 170         eval {
 171             print(REP($line), "\n");
 172             1;
 173         } or do {
 174             my $err = $@;
 175             if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
 176                 # ignore and continue
 177             } else {
 178                 chomp $err;
 179                 print "Error: $err\n";
 180             }
 181         };
 182     };
 183 }