Commit | Line | Data |
---|---|---|
16354bb4 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__); | |
89bd4de1 | 6 | use readline qw(mal_readline); |
16354bb4 JM |
7 | use feature qw(switch); |
8 | use Data::Dumper; | |
9 | ||
10 | use types qw($nil $true $false _sequential_Q _symbol_Q _list_Q); | |
11 | use reader; | |
12 | use printer; | |
13 | use env; | |
14 | use core qw($core_ns); | |
15 | use interop qw(pl_to_mal); | |
16 | ||
17 | # read | |
18 | sub READ { | |
19 | my $str = shift; | |
20 | return reader::read_str($str); | |
21 | } | |
22 | ||
23 | # eval | |
24 | sub is_pair { | |
25 | my ($x) = @_; | |
89bd4de1 | 26 | return _sequential_Q($x) && scalar(@{$x->{val}}) > 0; |
16354bb4 JM |
27 | } |
28 | ||
29 | sub quasiquote { | |
30 | my ($ast) = @_; | |
31 | if (!is_pair($ast)) { | |
32 | return List->new([Symbol->new("quote"), $ast]); | |
89bd4de1 JM |
33 | } elsif (_symbol_Q($ast->nth(0)) && ${$ast->nth(0)} eq 'unquote') { |
34 | return $ast->nth(1); | |
35 | } elsif (is_pair($ast->nth(0)) && _symbol_Q($ast->nth(0)->nth(0)) && | |
36 | ${$ast->nth(0)->nth(0)} eq 'splice-unquote') { | |
16354bb4 | 37 | return List->new([Symbol->new("concat"), |
89bd4de1 | 38 | $ast->nth(0)->nth(1), |
16354bb4 JM |
39 | quasiquote($ast->rest())]); |
40 | } else { | |
41 | return List->new([Symbol->new("cons"), | |
89bd4de1 | 42 | quasiquote($ast->nth(0)), |
16354bb4 JM |
43 | quasiquote($ast->rest())]); |
44 | } | |
45 | } | |
46 | ||
47 | sub is_macro_call { | |
48 | my ($ast, $env) = @_; | |
49 | if (_list_Q($ast) && | |
89bd4de1 JM |
50 | _symbol_Q($ast->nth(0)) && |
51 | $env->find(${$ast->nth(0)})) { | |
52 | my ($f) = $env->get(${$ast->nth(0)}); | |
16354bb4 JM |
53 | if ((ref $f) =~ /^Function/) { |
54 | return $f->{ismacro}; | |
55 | } | |
56 | } | |
57 | return 0; | |
58 | } | |
59 | ||
60 | sub macroexpand { | |
61 | my ($ast, $env) = @_; | |
62 | while (is_macro_call($ast, $env)) { | |
89bd4de1 | 63 | my $mac = $env->get(${$ast->nth(0)}); |
16354bb4 JM |
64 | $ast = $mac->apply($ast->rest()); |
65 | } | |
66 | return $ast; | |
67 | } | |
68 | ||
69 | ||
70 | sub eval_ast { | |
71 | my($ast, $env) = @_; | |
72 | given (ref $ast) { | |
73 | when (/^Symbol/) { | |
74 | $env->get($$ast); | |
75 | } | |
76 | when (/^List/) { | |
89bd4de1 | 77 | my @lst = map {EVAL($_, $env)} @{$ast->{val}}; |
16354bb4 JM |
78 | return List->new(\@lst); |
79 | } | |
89bd4de1 JM |
80 | when (/^Vector/) { |
81 | my @lst = map {EVAL($_, $env)} @{$ast->{val}}; | |
82 | return Vector->new(\@lst); | |
83 | } | |
84 | when (/^HashMap/) { | |
85 | my $new_hm = {}; | |
86 | foreach my $k (keys($ast->{val})) { | |
87 | $new_hm->{$k} = EVAL($ast->get($k), $env); | |
88 | } | |
89 | return HashMap->new($new_hm); | |
90 | } | |
16354bb4 JM |
91 | default { |
92 | return $ast; | |
93 | } | |
94 | } | |
95 | } | |
96 | ||
97 | sub EVAL { | |
98 | my($ast, $env) = @_; | |
99 | ||
100 | while (1) { | |
101 | ||
102 | #print "EVAL: " . printer::_pr_str($ast) . "\n"; | |
103 | if (! _list_Q($ast)) { | |
104 | return eval_ast($ast, $env); | |
105 | } | |
106 | ||
107 | # apply list | |
108 | $ast = macroexpand($ast, $env); | |
109 | if (! _list_Q($ast)) { return $ast; } | |
110 | ||
89bd4de1 | 111 | my ($a0, $a1, $a2, $a3) = @{$ast->{val}}; |
16354bb4 JM |
112 | given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) { |
113 | when (/^def!$/) { | |
114 | my $res = EVAL($a2, $env); | |
115 | return $env->set($$a1, $res); | |
116 | } | |
117 | when (/^let\*$/) { | |
118 | my $let_env = Env->new($env); | |
89bd4de1 JM |
119 | for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) { |
120 | $let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env)); | |
16354bb4 | 121 | } |
89bd4de1 JM |
122 | $ast = $a2; |
123 | $env = $let_env; | |
6301e0b6 | 124 | # Continue loop (TCO) |
16354bb4 JM |
125 | } |
126 | when (/^quote$/) { | |
127 | return $a1; | |
128 | } | |
129 | when (/^quasiquote$/) { | |
6301e0b6 JM |
130 | $ast = quasiquote($a1); |
131 | # Continue loop (TCO) | |
16354bb4 JM |
132 | } |
133 | when (/^defmacro!$/) { | |
134 | my $func = EVAL($a2, $env); | |
135 | $func->{ismacro} = 1; | |
136 | return $env->set($$a1, $func); | |
137 | } | |
138 | when (/^macroexpand$/) { | |
139 | return macroexpand($a1, $env); | |
140 | } | |
141 | when (/^pl\*$/) { | |
142 | return pl_to_mal(eval(${$a1})); | |
143 | } | |
144 | when (/^try\*$/) { | |
89bd4de1 JM |
145 | do { |
146 | local $@; | |
147 | my $ret; | |
148 | eval { | |
149 | use autodie; # always "throw" errors | |
150 | $ret = EVAL($a1, $env); | |
151 | 1; | |
152 | } or do { | |
153 | my $err = $@; | |
154 | if ($a2 && ${$a2->nth(0)} eq "catch\*") { | |
155 | my $exc; | |
156 | if (ref $err) { | |
157 | $exc = $err; | |
158 | } else { | |
159 | $exc = String->new(substr $err, 0, -1); | |
160 | } | |
161 | return EVAL($a2->nth(2), Env->new($env, | |
162 | List->new([$a2->nth(1)]), | |
163 | List->new([$exc]))); | |
16354bb4 | 164 | } else { |
89bd4de1 | 165 | die $err; |
16354bb4 | 166 | } |
89bd4de1 JM |
167 | }; |
168 | return $ret; | |
169 | }; | |
16354bb4 JM |
170 | } |
171 | when (/^do$/) { | |
89bd4de1 JM |
172 | eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env); |
173 | $ast = $ast->nth($#{$ast->{val}}); | |
6301e0b6 | 174 | # Continue loop (TCO) |
16354bb4 JM |
175 | } |
176 | when (/^if$/) { | |
177 | my $cond = EVAL($a1, $env); | |
178 | if ($cond eq $nil || $cond eq $false) { | |
179 | $ast = $a3 ? $a3 : $nil; | |
180 | } else { | |
181 | $ast = $a2; | |
182 | } | |
6301e0b6 | 183 | # Continue loop (TCO) |
16354bb4 JM |
184 | } |
185 | when (/^fn\*$/) { | |
186 | return Function->new(\&EVAL, $a2, $env, $a1); | |
187 | } | |
188 | default { | |
189 | my $el = eval_ast($ast, $env); | |
89bd4de1 | 190 | my $f = $el->nth(0); |
16354bb4 JM |
191 | if ((ref $f) =~ /^Function/) { |
192 | $ast = $f->{ast}; | |
193 | $env = $f->gen_env($el->rest()); | |
6301e0b6 | 194 | # Continue loop (TCO) |
16354bb4 JM |
195 | } else { |
196 | return &{ $f }($el->rest()); | |
197 | } | |
198 | } | |
199 | } | |
200 | ||
201 | } # TCO while loop | |
202 | } | |
203 | ||
204 | ||
205 | sub PRINT { | |
206 | my $exp = shift; | |
207 | return printer::_pr_str($exp); | |
208 | } | |
209 | ||
210 | # repl | |
211 | my $repl_env = Env->new(); | |
212 | sub REP { | |
213 | my $str = shift; | |
214 | return PRINT(EVAL(READ($str), $repl_env)); | |
215 | } | |
216 | ||
217 | # core.pl: defined using perl | |
218 | foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); } | |
89bd4de1 | 219 | $repl_env->set('eval', sub { EVAL($_[0]->nth(0), $repl_env); }); |
16354bb4 JM |
220 | my @_argv = map {String->new($_)} @ARGV[1..$#ARGV]; |
221 | $repl_env->set('*ARGV*', List->new(\@_argv)); | |
222 | ||
223 | # core.mal: defined using the language itself | |
89bd4de1 | 224 | REP("(def! *host-language* \"javascript\")"); |
16354bb4 JM |
225 | REP("(def! not (fn* (a) (if a false true)))"); |
226 | REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"); | |
89bd4de1 JM |
227 | REP("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"); |
228 | REP("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"); | |
16354bb4 | 229 | |
89bd4de1 JM |
230 | |
231 | if (scalar(@ARGV) > 0) { | |
16354bb4 JM |
232 | REP("(load-file \"" . $ARGV[0] . "\")"); |
233 | exit 0; | |
234 | } | |
89bd4de1 | 235 | REP("(println (str \"Mal [\" *host-language* \"]\"))"); |
16354bb4 | 236 | while (1) { |
89bd4de1 | 237 | my $line = mal_readline("user> "); |
16354bb4 | 238 | if (! defined $line) { last; } |
89bd4de1 JM |
239 | do { |
240 | local $@; | |
241 | my $ret; | |
242 | eval { | |
243 | use autodie; # always "throw" errors | |
244 | print(REP($line), "\n"); | |
245 | 1; | |
246 | } or do { | |
247 | my $err = $@; | |
248 | given (ref $err) { | |
249 | when (/^BlankException/) { | |
250 | # ignore and continue | |
251 | } | |
252 | default { | |
253 | chomp $err; | |
254 | print "Error: $err\n"; | |
255 | } | |
256 | } | |
257 | }; | |
258 | }; | |
16354bb4 | 259 | } |