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