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 set_rl_mode);
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)) {
110 return eval_ast
($ast, $env);
113 my ($a0, $a1, $a2, $a3) = @
{$ast->{val
}};
114 if (!$a0) { return $ast; }
115 given ((ref $a0) =~ /^Symbol/ ?
$$a0 : $a0) {
117 my $res = EVAL
($a2, $env);
118 return $env->set($a1, $res);
121 my $let_env = Env
->new($env);
122 for(my $i=0; $i < scalar(@
{$a1->{val
}}); $i+=2) {
123 $let_env->set($a1->nth($i), EVAL
($a1->nth($i+1), $let_env));
127 # Continue loop (TCO)
132 when (/^quasiquote$/) {
133 $ast = quasiquote
($a1);
134 # Continue loop (TCO)
136 when (/^defmacro!$/) {
137 my $func = EVAL
($a2, $env);
138 $func->{ismacro
} = 1;
139 return $env->set($a1, $func);
141 when (/^macroexpand$/) {
142 return macroexpand
($a1, $env);
145 return pl_to_mal
(eval(${$a1}));
152 use autodie
; # always "throw" errors
153 $ret = EVAL
($a1, $env);
157 if ($a2 && ${$a2->nth(0)} eq "catch\*") {
162 $exc = String
->new(substr $err, 0, -1);
164 return EVAL
($a2->nth(2), Env
->new($env,
165 List
->new([$a2->nth(1)]),
175 eval_ast
($ast->slice(1, $#{$ast->{val}}-1), $env);
176 $ast = $ast->nth($#{$ast->{val}});
177 # Continue loop (TCO)
180 my $cond = EVAL
($a1, $env);
181 if ($cond eq $nil || $cond eq $false) {
182 $ast = $a3 ?
$a3 : $nil;
186 # Continue loop (TCO)
189 return Function
->new(\
&EVAL
, $a2, $env, $a1);
192 my $el = eval_ast
($ast, $env);
194 if ((ref $f) =~ /^Function/) {
196 $env = $f->gen_env($el->rest());
197 # Continue loop (TCO)
199 return &{ $f }($el->rest());
210 return printer
::_pr_str
($exp);
214 my $repl_env = Env
->new();
217 return PRINT
(EVAL
(READ
($str), $repl_env));
220 # core.pl: defined using perl
221 foreach my $n (%$core_ns) {
222 $repl_env->set(Symbol
->new($n), $core_ns->{$n});
224 $repl_env->set(Symbol
->new('eval'), sub { EVAL
($_[0]->nth(0), $repl_env); });
225 my @_argv = map {String
->new($_)} @ARGV[1..$#ARGV];
226 $repl_env->set(Symbol
->new('*ARGV*'), List
->new(\
@_argv));
228 # core.mal: defined using the language itself
229 REP
("(def! *host-language* \"perl\")");
230 REP
("(def! not (fn* (a) (if a false true)))");
231 REP
("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
232 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)))))))");
233 REP
("(def! inc (fn* [x] (+ x 1)))");
234 REP
("(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))");
235 REP
("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))");
238 if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") {
242 if (scalar(@ARGV) > 0) {
243 REP
("(load-file \"" . $ARGV[0] . "\")");
246 REP
("(println (str \"Mal [\" *host-language* \"]\"))");
248 my $line = mal_readline
("user> ");
249 if (! defined $line) { last; }
254 use autodie
; # always "throw" errors
255 print(REP
($line), "\n");
260 when (/^BlankException/) {
261 # ignore and continue
265 print "Error: ".printer
::_pr_str
($err)."\n";
268 print "Error: $err\n";