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