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