Commit | Line | Data |
---|---|---|
54d9903c DM |
1 | source mal_readline.tcl |
2 | source types.tcl | |
3 | source reader.tcl | |
4 | source printer.tcl | |
5 | source env.tcl | |
6 | source core.tcl | |
7 | ||
8 | proc READ str { | |
9 | read_str $str | |
10 | } | |
11 | ||
12 | proc is_pair {ast} { | |
13 | expr {[sequential_q $ast] && [llength [obj_val $ast]] > 0} | |
14 | } | |
15 | ||
16 | proc quasiquote {ast} { | |
17 | if {![is_pair $ast]} { | |
18 | return [list_new [list [symbol_new "quote"] $ast]] | |
19 | } | |
20 | lassign [obj_val $ast] a0 a1 | |
21 | if {[symbol_q $a0] && [obj_val $a0] == "unquote"} { | |
22 | return $a1 | |
23 | } | |
24 | lassign [obj_val $a0] a00 a01 | |
25 | set rest [list_new [lrange [obj_val $ast] 1 end]] | |
26 | if {[is_pair $a0] && [symbol_q $a00] && [obj_val $a00] == "splice-unquote"} { | |
27 | return [list_new [list [symbol_new "concat"] $a01 [quasiquote $rest]]] | |
28 | } else { | |
29 | return [list_new [list [symbol_new "cons"] [quasiquote $a0] [quasiquote $rest]]] | |
30 | } | |
31 | } | |
32 | ||
33 | proc is_macro_call {ast env} { | |
34 | if {![list_q $ast]} { | |
35 | return 0 | |
36 | } | |
37 | set a0 [lindex [obj_val $ast] 0] | |
181a55ad | 38 | if {$a0 == "" || ![symbol_q $a0]} { |
54d9903c DM |
39 | return 0 |
40 | } | |
41 | set varname [obj_val $a0] | |
42 | set foundenv [$env find $varname] | |
43 | if {$foundenv == 0} { | |
44 | return 0 | |
45 | } | |
46 | macro_q [$env get $varname] | |
47 | } | |
48 | ||
49 | proc macroexpand {ast env} { | |
50 | while {[is_macro_call $ast $env]} { | |
51 | set a0 [mal_first [list $ast]] | |
52 | set macro_name [obj_val $a0] | |
53 | set macro_obj [$env get $macro_name] | |
54 | set macro_args [obj_val [mal_rest [list $ast]]] | |
55 | ||
56 | set funcdict [obj_val $macro_obj] | |
57 | set body [dict get $funcdict body] | |
58 | set env [dict get $funcdict env] | |
59 | set binds [dict get $funcdict binds] | |
60 | set funcenv [Env new $env $binds $macro_args] | |
61 | set ast [EVAL $body $funcenv] | |
62 | } | |
63 | return $ast | |
64 | } | |
65 | ||
66 | proc eval_ast {ast env} { | |
67 | switch [obj_type $ast] { | |
68 | "symbol" { | |
69 | set varname [obj_val $ast] | |
70 | return [$env get $varname] | |
71 | } | |
72 | "list" { | |
73 | set res {} | |
74 | foreach element [obj_val $ast] { | |
75 | lappend res [EVAL $element $env] | |
76 | } | |
77 | return [list_new $res] | |
78 | } | |
79 | "vector" { | |
80 | set res {} | |
81 | foreach element [obj_val $ast] { | |
82 | lappend res [EVAL $element $env] | |
83 | } | |
84 | return [vector_new $res] | |
85 | } | |
86 | "hashmap" { | |
87 | set res [dict create] | |
88 | dict for {k v} [obj_val $ast] { | |
89 | dict set res $k [EVAL $v $env] | |
90 | } | |
91 | return [hashmap_new $res] | |
92 | } | |
93 | default { return $ast } | |
94 | } | |
95 | } | |
96 | ||
97 | proc EVAL {ast env} { | |
98 | while {true} { | |
99 | if {![list_q $ast]} { | |
100 | return [eval_ast $ast $env] | |
101 | } | |
102 | ||
103 | set ast [macroexpand $ast $env] | |
104 | if {![list_q $ast]} { | |
6c94cd3e | 105 | return [eval_ast $ast $env] |
54d9903c DM |
106 | } |
107 | ||
108 | lassign [obj_val $ast] a0 a1 a2 a3 | |
181a55ad DM |
109 | if {$a0 == ""} { |
110 | return $ast | |
111 | } | |
54d9903c DM |
112 | switch [obj_val $a0] { |
113 | "def!" { | |
114 | set varname [obj_val $a1] | |
115 | set value [EVAL $a2 $env] | |
116 | return [$env set $varname $value] | |
117 | } | |
118 | "let*" { | |
119 | set letenv [Env new $env] | |
120 | set bindings_list [obj_val $a1] | |
121 | foreach {varnameobj varvalobj} $bindings_list { | |
122 | $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] | |
123 | } | |
124 | set ast $a2 | |
125 | set env $letenv | |
126 | # TCO: Continue loop | |
127 | } | |
128 | "quote" { | |
129 | return $a1 | |
130 | } | |
131 | "quasiquote" { | |
132 | set ast [quasiquote $a1] | |
133 | } | |
134 | "defmacro!" { | |
135 | set varname [obj_val $a1] | |
136 | set value [EVAL $a2 $env] | |
137 | set fn [obj_val $value] | |
138 | dict set fn is_macro 1 | |
139 | obj_set_val $value $fn | |
140 | return [$env set $varname $value] | |
141 | } | |
142 | "macroexpand" { | |
143 | return [macroexpand $a1 $env] | |
144 | } | |
145 | "tcl*" { | |
146 | return [string_new [eval [obj_val $a1]]] | |
147 | } | |
148 | "try*" { | |
625a6847 DM |
149 | if {$a2 == ""} { |
150 | return [EVAL $a1 $env] | |
151 | } | |
54d9903c DM |
152 | set res {} |
153 | if { [catch { set res [EVAL $a1 $env] } exception] } { | |
154 | set exc_var [obj_val [lindex [obj_val $a2] 1]] | |
155 | if {$exception == "__MalException__"} { | |
156 | set exc_value $::mal_exception_obj | |
157 | } else { | |
158 | set exc_value [string_new $exception] | |
159 | } | |
160 | set catch_env [Env new $env [list $exc_var] [list $exc_value]] | |
161 | return [EVAL [lindex [obj_val $a2] 2] $catch_env] | |
162 | } else { | |
163 | return $res | |
164 | } | |
165 | } | |
166 | "do" { | |
167 | set el [list_new [lrange [obj_val $ast] 1 end-1]] | |
168 | eval_ast $el $env | |
169 | set ast [lindex [obj_val $ast] end] | |
170 | # TCO: Continue loop | |
171 | } | |
172 | "if" { | |
173 | set condval [EVAL $a1 $env] | |
174 | if {[false_q $condval] || [nil_q $condval]} { | |
175 | if {$a3 == ""} { | |
176 | return $::mal_nil | |
177 | } | |
178 | set ast $a3 | |
179 | } else { | |
180 | set ast $a2 | |
181 | } | |
182 | # TCO: Continue loop | |
183 | } | |
184 | "fn*" { | |
185 | set binds {} | |
186 | foreach v [obj_val $a1] { | |
187 | lappend binds [obj_val $v] | |
188 | } | |
189 | return [function_new $a2 $env $binds] | |
190 | } | |
191 | default { | |
192 | set lst_obj [eval_ast $ast $env] | |
193 | set lst [obj_val $lst_obj] | |
194 | set f [lindex $lst 0] | |
195 | set call_args [lrange $lst 1 end] | |
196 | switch [obj_type $f] { | |
197 | function { | |
198 | set fn [obj_val $f] | |
199 | set ast [dict get $fn body] | |
200 | set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] | |
201 | # TCO: Continue loop | |
202 | } | |
203 | nativefunction { | |
204 | set body [concat [list [obj_val $f]] {$a}] | |
205 | set lambda [list {a} $body] | |
206 | return [apply $lambda $call_args] | |
207 | } | |
208 | default { | |
209 | error "Not a function" | |
210 | } | |
211 | } | |
212 | } | |
213 | } | |
214 | } | |
215 | } | |
216 | ||
217 | proc PRINT exp { | |
218 | pr_str $exp 1 | |
219 | } | |
220 | ||
221 | proc REP {str env} { | |
222 | PRINT [EVAL [READ $str] $env] | |
223 | } | |
224 | ||
225 | proc RE {str env} { | |
226 | EVAL [READ $str] $env | |
227 | } | |
228 | ||
229 | proc mal_eval {a} { | |
230 | global repl_env | |
231 | EVAL [lindex $a 0] $repl_env | |
232 | } | |
233 | ||
234 | set repl_env [Env new] | |
235 | dict for {k v} $core_ns { | |
236 | $repl_env set $k $v | |
237 | } | |
238 | ||
239 | $repl_env set "eval" [nativefunction_new mal_eval] | |
240 | ||
241 | set argv_list {} | |
242 | foreach arg [lrange $argv 1 end] { | |
243 | lappend argv_list [string_new $arg] | |
244 | } | |
245 | $repl_env set "*ARGV*" [list_new $argv_list] | |
246 | ||
247 | # core.mal: defined using the language itself | |
248 | RE "(def! *host-language* \"tcl\")" $repl_env | |
249 | RE "(def! not (fn* (a) (if a false true)))" $repl_env | |
250 | RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env | |
251 | RE "(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)))))))" $repl_env | |
54d9903c DM |
252 | |
253 | fconfigure stdout -translation binary | |
254 | ||
255 | set DEBUG_MODE 0 | |
256 | if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { | |
257 | set DEBUG_MODE 1 | |
258 | } | |
259 | ||
260 | if {$argc > 0} { | |
261 | REP "(load-file \"[lindex $argv 0]\")" $repl_env | |
262 | exit | |
263 | } | |
264 | ||
265 | REP "(println (str \"Mal \[\" *host-language* \"\]\"))" $repl_env | |
266 | ||
267 | # repl loop | |
268 | while {true} { | |
269 | set res [_readline "user> "] | |
270 | if {[lindex $res 0] == "EOF"} { | |
271 | break | |
272 | } | |
273 | set line [lindex $res 1] | |
274 | if {$line == ""} { | |
275 | continue | |
276 | } | |
277 | if { [catch { puts [REP $line $repl_env] } exception] } { | |
dd7a4f55 JM |
278 | if {$exception == "__MalException__"} { |
279 | set res [pr_str $::mal_exception_obj 1] | |
280 | puts "Error: $res" | |
281 | } else { | |
282 | puts "Error: $exception" | |
283 | } | |
54d9903c DM |
284 | if { $DEBUG_MODE } { |
285 | puts $::errorInfo | |
286 | } | |
287 | } | |
288 | } | |
289 | puts "" |