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 eval_ast {ast env} { | |
13 | switch [obj_type $ast] { | |
14 | "symbol" { | |
15 | set varname [obj_val $ast] | |
16 | return [$env get $varname] | |
17 | } | |
18 | "list" { | |
19 | set res {} | |
20 | foreach element [obj_val $ast] { | |
21 | lappend res [EVAL $element $env] | |
22 | } | |
23 | return [list_new $res] | |
24 | } | |
25 | "vector" { | |
26 | set res {} | |
27 | foreach element [obj_val $ast] { | |
28 | lappend res [EVAL $element $env] | |
29 | } | |
30 | return [vector_new $res] | |
31 | } | |
32 | "hashmap" { | |
33 | set res [dict create] | |
34 | dict for {k v} [obj_val $ast] { | |
35 | dict set res $k [EVAL $v $env] | |
36 | } | |
37 | return [hashmap_new $res] | |
38 | } | |
39 | default { return $ast } | |
40 | } | |
41 | } | |
42 | ||
43 | proc EVAL {ast env} { | |
44 | while {true} { | |
45 | if {![list_q $ast]} { | |
46 | return [eval_ast $ast $env] | |
47 | } | |
48 | lassign [obj_val $ast] a0 a1 a2 a3 | |
181a55ad DM |
49 | if {$a0 == ""} { |
50 | return $ast | |
51 | } | |
54d9903c DM |
52 | switch [obj_val $a0] { |
53 | "def!" { | |
54 | set varname [obj_val $a1] | |
55 | set value [EVAL $a2 $env] | |
56 | return [$env set $varname $value] | |
57 | } | |
58 | "let*" { | |
59 | set letenv [Env new $env] | |
60 | set bindings_list [obj_val $a1] | |
61 | foreach {varnameobj varvalobj} $bindings_list { | |
62 | $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv] | |
63 | } | |
64 | set ast $a2 | |
65 | set env $letenv | |
66 | # TCO: Continue loop | |
67 | } | |
68 | "do" { | |
69 | set el [list_new [lrange [obj_val $ast] 1 end-1]] | |
70 | eval_ast $el $env | |
71 | set ast [lindex [obj_val $ast] end] | |
72 | # TCO: Continue loop | |
73 | } | |
74 | "if" { | |
75 | set condval [EVAL $a1 $env] | |
76 | if {[false_q $condval] || [nil_q $condval]} { | |
77 | if {$a3 == ""} { | |
78 | return $::mal_nil | |
79 | } | |
80 | set ast $a3 | |
81 | } else { | |
82 | set ast $a2 | |
83 | } | |
84 | # TCO: Continue loop | |
85 | } | |
86 | "fn*" { | |
87 | set binds {} | |
88 | foreach v [obj_val $a1] { | |
89 | lappend binds [obj_val $v] | |
90 | } | |
91 | return [function_new $a2 $env $binds] | |
92 | } | |
93 | default { | |
94 | set lst_obj [eval_ast $ast $env] | |
95 | set lst [obj_val $lst_obj] | |
96 | set f [lindex $lst 0] | |
97 | set call_args [lrange $lst 1 end] | |
98 | switch [obj_type $f] { | |
99 | function { | |
100 | set fn [obj_val $f] | |
101 | set ast [dict get $fn body] | |
102 | set env [Env new [dict get $fn env] [dict get $fn binds] $call_args] | |
103 | # TCO: Continue loop | |
104 | } | |
105 | nativefunction { | |
106 | set body [concat [list [obj_val $f]] {$a}] | |
107 | set lambda [list {a} $body] | |
108 | return [apply $lambda $call_args] | |
109 | } | |
110 | default { | |
111 | error "Not a function" | |
112 | } | |
113 | } | |
114 | } | |
115 | } | |
116 | } | |
117 | } | |
118 | ||
119 | proc PRINT exp { | |
120 | pr_str $exp 1 | |
121 | } | |
122 | ||
123 | proc REP {str env} { | |
124 | PRINT [EVAL [READ $str] $env] | |
125 | } | |
126 | ||
127 | proc RE {str env} { | |
128 | EVAL [READ $str] $env | |
129 | } | |
130 | ||
131 | proc mal_eval {a} { | |
132 | global repl_env | |
133 | EVAL [lindex $a 0] $repl_env | |
134 | } | |
135 | ||
136 | set repl_env [Env new] | |
137 | dict for {k v} $core_ns { | |
138 | $repl_env set $k $v | |
139 | } | |
140 | ||
141 | $repl_env set "eval" [nativefunction_new mal_eval] | |
142 | ||
143 | set argv_list {} | |
144 | foreach arg [lrange $argv 1 end] { | |
145 | lappend argv_list [string_new $arg] | |
146 | } | |
147 | $repl_env set "*ARGV*" [list_new $argv_list] | |
148 | ||
149 | # core.mal: defined using the language itself | |
150 | RE "(def! not (fn* (a) (if a false true)))" $repl_env | |
151 | RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env | |
152 | ||
153 | fconfigure stdout -translation binary | |
154 | ||
155 | set DEBUG_MODE 0 | |
156 | if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } { | |
157 | set DEBUG_MODE 1 | |
158 | } | |
159 | ||
160 | if {$argc > 0} { | |
161 | REP "(load-file \"[lindex $argv 0]\")" $repl_env | |
162 | exit | |
163 | } | |
164 | ||
165 | # repl loop | |
166 | while {true} { | |
167 | set res [_readline "user> "] | |
168 | if {[lindex $res 0] == "EOF"} { | |
169 | break | |
170 | } | |
171 | set line [lindex $res 1] | |
172 | if {$line == ""} { | |
173 | continue | |
174 | } | |
175 | if { [catch { puts [REP $line $repl_env] } exception] } { | |
176 | puts "Error: $exception" | |
177 | if { $DEBUG_MODE } { | |
178 | puts $::errorInfo | |
179 | } | |
180 | } | |
181 | } | |
182 | puts "" |