Commit | Line | Data |
---|---|---|
fd637e03 JM |
1 | use strict; |
2 | use warnings FATAL => qw(all); | |
01c97316 | 3 | no if $] >= 5.018, warnings => "experimental::smartmatch"; |
f26bc011 JM |
4 | use File::Basename; |
5 | use lib dirname (__FILE__); | |
b8ee29b2 | 6 | use readline qw(mal_readline set_rl_mode); |
fd637e03 JM |
7 | use feature qw(switch); |
8 | use Data::Dumper; | |
9 | ||
89bd4de1 | 10 | use types qw($nil $true $false _sequential_Q _symbol_Q _list_Q); |
fd637e03 JM |
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 is_pair { | |
24 | my ($x) = @_; | |
89bd4de1 | 25 | return _sequential_Q($x) && scalar(@{$x->{val}}) > 0; |
fd637e03 JM |
26 | } |
27 | ||
28 | sub quasiquote { | |
29 | my ($ast) = @_; | |
30 | if (!is_pair($ast)) { | |
31 | return List->new([Symbol->new("quote"), $ast]); | |
89bd4de1 JM |
32 | } elsif (_symbol_Q($ast->nth(0)) && ${$ast->nth(0)} eq 'unquote') { |
33 | return $ast->nth(1); | |
34 | } elsif (is_pair($ast->nth(0)) && _symbol_Q($ast->nth(0)->nth(0)) && | |
35 | ${$ast->nth(0)->nth(0)} eq 'splice-unquote') { | |
fd637e03 | 36 | return List->new([Symbol->new("concat"), |
89bd4de1 | 37 | $ast->nth(0)->nth(1), |
fd637e03 JM |
38 | quasiquote($ast->rest())]); |
39 | } else { | |
40 | return List->new([Symbol->new("cons"), | |
89bd4de1 | 41 | quasiquote($ast->nth(0)), |
fd637e03 JM |
42 | quasiquote($ast->rest())]); |
43 | } | |
44 | } | |
45 | ||
46 | sub eval_ast { | |
47 | my($ast, $env) = @_; | |
48 | given (ref $ast) { | |
49 | when (/^Symbol/) { | |
b8ee29b2 | 50 | $env->get($ast); |
fd637e03 JM |
51 | } |
52 | when (/^List/) { | |
89bd4de1 | 53 | my @lst = map {EVAL($_, $env)} @{$ast->{val}}; |
fd637e03 JM |
54 | return List->new(\@lst); |
55 | } | |
89bd4de1 JM |
56 | when (/^Vector/) { |
57 | my @lst = map {EVAL($_, $env)} @{$ast->{val}}; | |
58 | return Vector->new(\@lst); | |
59 | } | |
60 | when (/^HashMap/) { | |
61 | my $new_hm = {}; | |
62 | foreach my $k (keys($ast->{val})) { | |
63 | $new_hm->{$k} = EVAL($ast->get($k), $env); | |
64 | } | |
65 | return HashMap->new($new_hm); | |
66 | } | |
fd637e03 JM |
67 | default { |
68 | return $ast; | |
69 | } | |
70 | } | |
71 | } | |
72 | ||
73 | sub EVAL { | |
74 | my($ast, $env) = @_; | |
75 | ||
76 | while (1) { | |
77 | ||
78 | #print "EVAL: " . printer::_pr_str($ast) . "\n"; | |
89bd4de1 | 79 | if (! _list_Q($ast)) { |
fd637e03 JM |
80 | return eval_ast($ast, $env); |
81 | } | |
82 | ||
83 | # apply list | |
89bd4de1 | 84 | my ($a0, $a1, $a2, $a3) = @{$ast->{val}}; |
fd637e03 JM |
85 | given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) { |
86 | when (/^def!$/) { | |
87 | my $res = EVAL($a2, $env); | |
b8ee29b2 | 88 | return $env->set($a1, $res); |
fd637e03 JM |
89 | } |
90 | when (/^let\*$/) { | |
91 | my $let_env = Env->new($env); | |
89bd4de1 | 92 | for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) { |
b8ee29b2 | 93 | $let_env->set($a1->nth($i), EVAL($a1->nth($i+1), $let_env)); |
fd637e03 | 94 | } |
89bd4de1 JM |
95 | $ast = $a2; |
96 | $env = $let_env; | |
6301e0b6 | 97 | # Continue loop (TCO) |
fd637e03 JM |
98 | } |
99 | when (/^quote$/) { | |
100 | return $a1; | |
101 | } | |
102 | when (/^quasiquote$/) { | |
6301e0b6 JM |
103 | $ast = quasiquote($a1); |
104 | # Continue loop (TCO) | |
fd637e03 JM |
105 | } |
106 | when (/^do$/) { | |
89bd4de1 JM |
107 | eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env); |
108 | $ast = $ast->nth($#{$ast->{val}}); | |
6301e0b6 | 109 | # Continue loop (TCO) |
fd637e03 JM |
110 | } |
111 | when (/^if$/) { | |
112 | my $cond = EVAL($a1, $env); | |
113 | if ($cond eq $nil || $cond eq $false) { | |
114 | $ast = $a3 ? $a3 : $nil; | |
115 | } else { | |
116 | $ast = $a2; | |
117 | } | |
6301e0b6 | 118 | # Continue loop (TCO) |
fd637e03 JM |
119 | } |
120 | when (/^fn\*$/) { | |
121 | return Function->new(\&EVAL, $a2, $env, $a1); | |
122 | } | |
123 | default { | |
124 | my $el = eval_ast($ast, $env); | |
89bd4de1 | 125 | my $f = $el->nth(0); |
fd637e03 JM |
126 | if ((ref $f) =~ /^Function/) { |
127 | $ast = $f->{ast}; | |
128 | $env = $f->gen_env($el->rest()); | |
6301e0b6 | 129 | # Continue loop (TCO) |
fd637e03 JM |
130 | } else { |
131 | return &{ $f }($el->rest()); | |
132 | } | |
133 | } | |
134 | } | |
135 | ||
136 | } # TCO while loop | |
137 | } | |
138 | ||
139 | ||
140 | sub PRINT { | |
141 | my $exp = shift; | |
142 | return printer::_pr_str($exp); | |
143 | } | |
144 | ||
145 | # repl | |
146 | my $repl_env = Env->new(); | |
147 | sub REP { | |
148 | my $str = shift; | |
149 | return PRINT(EVAL(READ($str), $repl_env)); | |
150 | } | |
151 | ||
152 | # core.pl: defined using perl | |
b8ee29b2 JM |
153 | foreach my $n (%$core_ns) { |
154 | $repl_env->set(Symbol->new($n), $core_ns->{$n}); | |
155 | } | |
156 | $repl_env->set(Symbol->new('eval'), sub { EVAL($_[0]->nth(0), $repl_env); }); | |
fd637e03 | 157 | my @_argv = map {String->new($_)} @ARGV[1..$#ARGV]; |
b8ee29b2 | 158 | $repl_env->set(Symbol->new('*ARGV*'), List->new(\@_argv)); |
fd637e03 JM |
159 | |
160 | # core.mal: defined using the language itself | |
161 | REP("(def! not (fn* (a) (if a false true)))"); | |
162 | REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"); | |
163 | ||
b8ee29b2 JM |
164 | if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") { |
165 | set_rl_mode("raw"); | |
166 | shift @ARGV; | |
167 | } | |
89bd4de1 | 168 | if (scalar(@ARGV) > 0) { |
fd637e03 JM |
169 | REP("(load-file \"" . $ARGV[0] . "\")"); |
170 | exit 0; | |
171 | } | |
172 | while (1) { | |
89bd4de1 | 173 | my $line = mal_readline("user> "); |
fd637e03 | 174 | if (! defined $line) { last; } |
89bd4de1 JM |
175 | do { |
176 | local $@; | |
177 | my $ret; | |
178 | eval { | |
179 | use autodie; # always "throw" errors | |
180 | print(REP($line), "\n"); | |
181 | 1; | |
182 | } or do { | |
183 | my $err = $@; | |
184 | given (ref $err) { | |
185 | when (/^BlankException/) { | |
186 | # ignore and continue | |
187 | } | |
188 | default { | |
189 | chomp $err; | |
190 | print "Error: $err\n"; | |
191 | } | |
192 | } | |
193 | }; | |
194 | }; | |
fd637e03 | 195 | } |