Commit | Line | Data |
---|---|---|
074cd748 JM |
1 | use strict; |
2 | use warnings FATAL => qw(all); | |
89bd4de1 | 3 | use readline qw(mal_readline); |
074cd748 JM |
4 | use feature qw(switch); |
5 | use Data::Dumper; | |
6 | ||
89bd4de1 | 7 | use types qw($nil $true $false _list_Q); |
074cd748 JM |
8 | use reader; |
9 | use printer; | |
10 | use env; | |
11 | use core qw($core_ns); | |
12 | ||
13 | # read | |
14 | sub READ { | |
15 | my $str = shift; | |
16 | return reader::read_str($str); | |
17 | } | |
18 | ||
19 | # eval | |
20 | sub eval_ast { | |
21 | my($ast, $env) = @_; | |
22 | given (ref $ast) { | |
23 | when (/^Symbol/) { | |
24 | $env->get($$ast); | |
25 | } | |
26 | when (/^List/) { | |
89bd4de1 | 27 | my @lst = map {EVAL($_, $env)} @{$ast->{val}}; |
074cd748 JM |
28 | return List->new(\@lst); |
29 | } | |
89bd4de1 JM |
30 | when (/^Vector/) { |
31 | my @lst = map {EVAL($_, $env)} @{$ast->{val}}; | |
32 | return Vector->new(\@lst); | |
33 | } | |
34 | when (/^HashMap/) { | |
35 | my $new_hm = {}; | |
36 | foreach my $k (keys($ast->{val})) { | |
37 | $new_hm->{$k} = EVAL($ast->get($k), $env); | |
38 | } | |
39 | return HashMap->new($new_hm); | |
40 | } | |
074cd748 JM |
41 | default { |
42 | return $ast; | |
43 | } | |
44 | } | |
45 | } | |
46 | ||
47 | sub EVAL { | |
48 | my($ast, $env) = @_; | |
49 | ||
50 | while (1) { | |
51 | ||
52 | #print "EVAL: " . printer::_pr_str($ast) . "\n"; | |
89bd4de1 | 53 | if (! _list_Q($ast)) { |
074cd748 JM |
54 | return eval_ast($ast, $env); |
55 | } | |
56 | ||
57 | # apply list | |
89bd4de1 | 58 | my ($a0, $a1, $a2, $a3) = @{$ast->{val}}; |
074cd748 JM |
59 | given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) { |
60 | when (/^def!$/) { | |
61 | my $res = EVAL($a2, $env); | |
62 | return $env->set($$a1, $res); | |
63 | } | |
64 | when (/^let\*$/) { | |
65 | my $let_env = Env->new($env); | |
89bd4de1 JM |
66 | for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) { |
67 | $let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env)); | |
074cd748 | 68 | } |
89bd4de1 JM |
69 | $ast = $a2; |
70 | $env = $let_env; | |
6301e0b6 | 71 | # Continue loop (TCO) |
074cd748 JM |
72 | } |
73 | when (/^do$/) { | |
89bd4de1 JM |
74 | eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env); |
75 | $ast = $ast->nth($#{$ast->{val}}); | |
6301e0b6 | 76 | # Continue loop (TCO) |
074cd748 JM |
77 | } |
78 | when (/^if$/) { | |
79 | my $cond = EVAL($a1, $env); | |
80 | if ($cond eq $nil || $cond eq $false) { | |
81 | $ast = $a3 ? $a3 : $nil; | |
82 | } else { | |
83 | $ast = $a2; | |
84 | } | |
6301e0b6 | 85 | # Continue loop (TCO) |
074cd748 JM |
86 | } |
87 | when (/^fn\*$/) { | |
88 | return Function->new(\&EVAL, $a2, $env, $a1); | |
89 | } | |
90 | default { | |
91 | my $el = eval_ast($ast, $env); | |
89bd4de1 | 92 | my $f = $el->nth(0); |
074cd748 JM |
93 | if ((ref $f) =~ /^Function/) { |
94 | $ast = $f->{ast}; | |
95 | $env = $f->gen_env($el->rest()); | |
6301e0b6 | 96 | # Continue loop (TCO) |
074cd748 JM |
97 | } else { |
98 | return &{ $f }($el->rest()); | |
99 | } | |
100 | } | |
101 | } | |
102 | ||
103 | } # TCO while loop | |
104 | } | |
105 | ||
106 | ||
107 | sub PRINT { | |
108 | my $exp = shift; | |
109 | return printer::_pr_str($exp); | |
110 | } | |
111 | ||
112 | # repl | |
113 | my $repl_env = Env->new(); | |
114 | sub REP { | |
115 | my $str = shift; | |
116 | return PRINT(EVAL(READ($str), $repl_env)); | |
117 | } | |
118 | ||
119 | # core.pl: defined using perl | |
120 | foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); } | |
89bd4de1 | 121 | $repl_env->set('eval', sub { EVAL($_[0]->nth(0), $repl_env); }); |
074cd748 JM |
122 | my @_argv = map {String->new($_)} @ARGV[1..$#ARGV]; |
123 | $repl_env->set('*ARGV*', List->new(\@_argv)); | |
124 | ||
125 | # core.mal: defined using the language itself | |
126 | REP("(def! not (fn* (a) (if a false true)))"); | |
127 | REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"); | |
128 | ||
89bd4de1 | 129 | if (scalar(@ARGV) > 0) { |
074cd748 JM |
130 | REP("(load-file \"" . $ARGV[0] . "\")"); |
131 | exit 0; | |
132 | } | |
133 | while (1) { | |
89bd4de1 | 134 | my $line = mal_readline("user> "); |
074cd748 | 135 | if (! defined $line) { last; } |
89bd4de1 JM |
136 | do { |
137 | local $@; | |
138 | my $ret; | |
139 | eval { | |
140 | use autodie; # always "throw" errors | |
141 | print(REP($line), "\n"); | |
142 | 1; | |
143 | } or do { | |
144 | my $err = $@; | |
145 | given (ref $err) { | |
146 | when (/^BlankException/) { | |
147 | # ignore and continue | |
148 | } | |
149 | default { | |
150 | chomp $err; | |
151 | print "Error: $err\n"; | |
152 | } | |
153 | } | |
154 | }; | |
155 | }; | |
074cd748 | 156 | } |