2 use warnings FATAL
=> qw(all);
3 no if $] >= 5.018, warnings
=> "experimental::smartmatch";
5 use lib dirname
(__FILE__
);
6 use readline qw(mal_readline);
7 use feature
qw(switch);
10 use types
qw($nil $true $false _sequential_Q _symbol_Q _list_Q);
14 use core qw($core_ns);
15 use interop qw(pl_to_mal);
20 return reader
::read_str
($str);
26 return _sequential_Q
($x) && scalar(@
{$x->{val
}}) > 0;
32 return List
->new([Symbol
->new("quote"), $ast]);
33 } elsif (_symbol_Q
($ast->nth(0)) && ${$ast->nth(0)} eq 'unquote') {
35 } elsif (is_pair
($ast->nth(0)) && _symbol_Q
($ast->nth(0)->nth(0)) &&
36 ${$ast->nth(0)->nth(0)} eq 'splice-unquote') {
37 return List
->new([Symbol
->new("concat"),
39 quasiquote
($ast->rest())]);
41 return List
->new([Symbol
->new("cons"),
42 quasiquote
($ast->nth(0)),
43 quasiquote
($ast->rest())]);
50 _symbol_Q
($ast->nth(0)) &&
51 $env->find(${$ast->nth(0)})) {
52 my ($f) = $env->get(${$ast->nth(0)});
53 if ((ref $f) =~ /^Function/) {
62 while (is_macro_call
($ast, $env)) {
63 my $mac = $env->get(${$ast->nth(0)});
64 $ast = $mac->apply($ast->rest());
77 my @lst = map {EVAL
($_, $env)} @
{$ast->{val
}};
78 return List
->new(\
@lst);
81 my @lst = map {EVAL
($_, $env)} @
{$ast->{val
}};
82 return Vector
->new(\
@lst);
86 foreach my $k (keys($ast->{val
})) {
87 $new_hm->{$k} = EVAL
($ast->get($k), $env);
89 return HashMap
->new($new_hm);
102 #print "EVAL: " . printer::_pr_str($ast) . "\n";
103 if (! _list_Q
($ast)) {
104 return eval_ast
($ast, $env);
108 $ast = macroexpand
($ast, $env);
109 if (! _list_Q
($ast)) { return $ast; }
111 my ($a0, $a1, $a2, $a3) = @
{$ast->{val
}};
112 given ((ref $a0) =~ /^Symbol/ ?
$$a0 : $a0) {
114 my $res = EVAL
($a2, $env);
115 return $env->set($$a1, $res);
118 my $let_env = Env
->new($env);
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));
124 # Continue loop (TCO)
129 when (/^quasiquote$/) {
130 $ast = quasiquote
($a1);
131 # Continue loop (TCO)
133 when (/^defmacro!$/) {
134 my $func = EVAL
($a2, $env);
135 $func->{ismacro
} = 1;
136 return $env->set($$a1, $func);
138 when (/^macroexpand$/) {
139 return macroexpand
($a1, $env);
146 use autodie
; # always "throw" errors
147 $ret = EVAL
($a1, $env);
151 if ($a2 && ${$a2->nth(0)} eq "catch\*") {
156 $exc = String
->new(substr $err, 0, -1);
158 return EVAL
($a2->nth(2), Env
->new($env,
159 List
->new([$a2->nth(1)]),
169 eval_ast
($ast->slice(1, $#{$ast->{val}}-1), $env);
170 $ast = $ast->nth($#{$ast->{val}});
171 # Continue loop (TCO)
174 my $cond = EVAL
($a1, $env);
175 if ($cond eq $nil || $cond eq $false) {
176 $ast = $a3 ?
$a3 : $nil;
180 # Continue loop (TCO)
183 return Function
->new(\
&EVAL
, $a2, $env, $a1);
186 my $el = eval_ast
($ast, $env);
188 if ((ref $f) =~ /^Function/) {
190 $env = $f->gen_env($el->rest());
191 # Continue loop (TCO)
193 return &{ $f }($el->rest());
204 return printer
::_pr_str
($exp);
208 my $repl_env = Env
->new();
211 return PRINT
(EVAL
(READ
($str), $repl_env));
214 # core.pl: defined using perl
215 foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
216 $repl_env->set('eval', sub { EVAL
($_[0]->nth(0), $repl_env); });
217 my @_argv = map {String
->new($_)} @ARGV[1..$#ARGV];
218 $repl_env->set('*ARGV*', List
->new(\
@_argv));
220 # core.mal: defined using the language itself
221 REP
("(def! *host-language* \"javascript\")");
222 REP
("(def! not (fn* (a) (if a false true)))");
223 REP
("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
224 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)))))))");
225 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))))))))");
228 if (scalar(@ARGV) > 0) {
229 REP
("(load-file \"" . $ARGV[0] . "\")");
232 REP
("(println (str \"Mal [\" *host-language* \"]\"))");
234 my $line = mal_readline
("user> ");
235 if (! defined $line) { last; }
240 use autodie
; # always "throw" errors
241 print(REP
($line), "\n");
246 when (/^BlankException/) {
247 # ignore and continue
251 print "Error: $err\n";