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] | |
38 | if {![symbol_q $a0]} { | |
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 | |
109 | switch [obj_val $a0] { | |
110 | "def!" { | |
111 | set varname [obj_val $a1] | |
112 | set value [EVAL $a2 $env] | |
113 | return [$env set $varname $value] | |
114 | } | |
115 | "let*" { | |
116 | set letenv [Env new $env] | |
117 | set bindings_list [obj_val $a1] | |
118 | foreach {varnameobj varvalobj} $bindings_list { | |
119 | $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] | |
120 | } | |
121 | set ast $a2 | |
122 | set env $letenv | |
123 | # TCO: Continue loop | |
124 | } | |
125 | "quote" { | |
126 | return $a1 | |
127 | } | |
128 | "quasiquote" { | |
129 | set ast [quasiquote $a1] | |
130 | } | |
131 | "defmacro!" { | |
132 | set varname [obj_val $a1] | |
133 | set value [EVAL $a2 $env] | |
134 | set fn [obj_val $value] | |
135 | dict set fn is_macro 1 | |
136 | obj_set_val $value $fn | |
137 | return [$env set $varname $value] | |
138 | } | |
139 | "macroexpand" { | |
140 | return [macroexpand $a1 $env] | |
141 | } | |
142 | "do" { | |
143 | set el [list_new [lrange [obj_val $ast] 1 end-1]] | |
144 | eval_ast $el $env | |
145 | set ast [lindex [obj_val $ast] end] | |
146 | # TCO: Continue loop | |
147 | } | |
148 | "if" { | |
149 | set condval [EVAL $a1 $env] | |
150 | if {[false_q $condval] || [nil_q $condval]} { | |
151 | if {$a3 == ""} { | |
152 | return $::mal_nil | |
153 | } | |
154 | set ast $a3 | |
155 | } else { | |
156 | set ast $a2 | |
157 | } | |
158 | # TCO: Continue loop | |
159 | } | |
160 | "fn*" { | |
161 | set binds {} | |
162 | foreach v [obj_val $a1] { | |
163 | lappend binds [obj_val $v] | |
164 | } | |
165 | return [function_new $a2 $env $binds] | |
166 | } | |
167 | default { | |
168 | set lst_obj [eval_ast $ast $env] | |
169 | set lst [obj_val $lst_obj] | |
170 | set f [lindex $lst 0] | |
171 | set call_args [lrange $lst 1 end] | |
172 | switch [obj_type $f] { | |
173 | function { | |
174 | set fn [obj_val $f] | |
175 | set ast [dict get $fn body] | |
176 | set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] | |
177 | # TCO: Continue loop | |
178 | } | |
179 | nativefunction { | |
180 | set body [concat [list [obj_val $f]] {$a}] | |
181 | set lambda [list {a} $body] | |
182 | return [apply $lambda $call_args] | |
183 | } | |
184 | default { | |
185 | error "Not a function" | |
186 | } | |
187 | } | |
188 | } | |
189 | } | |
190 | } | |
191 | } | |
192 | ||
193 | proc PRINT exp { | |
194 | pr_str $exp 1 | |
195 | } | |
196 | ||
197 | proc REP {str env} { | |
198 | PRINT [EVAL [READ $str] $env] | |
199 | } | |
200 | ||
201 | proc RE {str env} { | |
202 | EVAL [READ $str] $env | |
203 | } | |
204 | ||
205 | proc mal_eval {a} { | |
206 | global repl_env | |
207 | EVAL [lindex $a 0] $repl_env | |
208 | } | |
209 | ||
210 | set repl_env [Env new] | |
211 | dict for {k v} $core_ns { | |
212 | $repl_env set $k $v | |
213 | } | |
214 | ||
215 | $repl_env set "eval" [nativefunction_new mal_eval] | |
216 | ||
217 | set argv_list {} | |
218 | foreach arg [lrange $argv 1 end] { | |
219 | lappend argv_list [string_new $arg] | |
220 | } | |
221 | $repl_env set "*ARGV*" [list_new $argv_list] | |
222 | ||
223 | # core.mal: defined using the language itself | |
224 | RE "(def! not (fn* (a) (if a false true)))" $repl_env | |
225 | RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env | |
226 | 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 | |
227 | RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" $repl_env | |
228 | ||
229 | fconfigure stdout -translation binary | |
230 | ||
231 | set DEBUG_MODE 0 | |
232 | if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { | |
233 | set DEBUG_MODE 1 | |
234 | } | |
235 | ||
236 | if {$argc > 0} { | |
237 | REP "(load-file \"[lindex $argv 0]\")" $repl_env | |
238 | exit | |
239 | } | |
240 | ||
241 | # repl loop | |
242 | while {true} { | |
243 | set res [_readline "user> "] | |
244 | if {[lindex $res 0] == "EOF"} { | |
245 | break | |
246 | } | |
247 | set line [lindex $res 1] | |
248 | if {$line == ""} { | |
249 | continue | |
250 | } | |
251 | if { [catch { puts [REP $line $repl_env] } exception] } { | |
252 | puts "Error: $exception" | |
253 | if { $DEBUG_MODE } { | |
254 | puts $::errorInfo | |
255 | } | |
256 | } | |
257 | } | |
258 | puts "" |