1 source mal_readline.tcl
13 expr {[sequential_q
$ast] && [llength [obj_val
$ast]] > 0}
16 proc quasiquote
{ast
} {
17 if {![is_pair
$ast]} {
18 return [list_new
[list [symbol_new
"quote"] $ast]]
20 lassign
[obj_val
$ast] a0 a1
21 if {[symbol_q
$a0] && [obj_val
$a0] == "unquote"} {
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]]]
29 return [list_new
[list [symbol_new
"cons"] [quasiquote
$a0] [quasiquote
$rest]]]
33 proc is_macro_call
{ast env
} {
37 set a0
[lindex [obj_val
$ast] 0]
38 if {$a0 == "" ||
![symbol_q
$a0]} {
41 set varname
[obj_val
$a0]
42 set foundenv
[$env find
$varname]
46 macro_q
[$env get
$varname]
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]]]
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]
66 proc eval_ast
{ast env
} {
67 switch [obj_type
$ast] {
69 set varname
[obj_val
$ast]
70 return [$env get
$varname]
74 foreach element
[obj_val
$ast] {
75 lappend res
[EVAL
$element $env]
77 return [list_new
$res]
81 foreach element
[obj_val
$ast] {
82 lappend res
[EVAL
$element $env]
84 return [vector_new
$res]
88 dict
for {k v
} [obj_val
$ast] {
89 dict
set res
$k [EVAL
$v $env]
91 return [hashmap_new
$res]
93 default { return $ast }
100 return [eval_ast
$ast $env]
103 set ast
[macroexpand
$ast $env]
104 if {![list_q
$ast]} {
105 return [eval_ast
$ast $env]
108 lassign
[obj_val
$ast] a0 a1 a2 a3
112 switch [obj_val
$a0] {
114 set varname
[obj_val
$a1]
115 set value
[EVAL
$a2 $env]
116 return [$env set $varname $value]
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]
132 set ast
[quasiquote
$a1]
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]
143 return [macroexpand
$a1 $env]
146 set el
[list_new
[lrange [obj_val
$ast] 1 end-1
]]
148 set ast
[lindex [obj_val
$ast] end
]
152 set condval
[EVAL
$a1 $env]
153 if {[false_q
$condval] ||
[nil_q
$condval]} {
165 foreach v
[obj_val
$a1] {
166 lappend binds
[obj_val
$v]
168 return [function_new
$a2 $env $binds]
171 set lst_obj
[eval_ast
$ast $env]
172 set lst
[obj_val
$lst_obj]
173 set f
[lindex $lst 0]
174 set call_args
[lrange $lst 1 end
]
175 switch [obj_type
$f] {
178 set ast
[dict get
$fn body
]
179 set env
[Env new
[dict get
$fn env
] [dict get
$fn binds
] $call_args]
183 set body
[concat [list [obj_val
$f]] {$a}]
184 set lambda
[list {a
} $body]
185 return [apply
$lambda $call_args]
188 error "Not a function"
201 PRINT
[EVAL
[READ
$str] $env]
205 EVAL
[READ
$str] $env
210 EVAL
[lindex $a 0] $repl_env
213 set repl_env
[Env new
]
214 dict
for {k v
} $core_ns {
218 $repl_env set "eval" [nativefunction_new mal_eval
]
221 foreach arg
[lrange $argv 1 end
] {
222 lappend argv_list
[string_new
$arg]
224 $repl_env set "*ARGV*" [list_new
$argv_list]
226 # core.mal: defined using the language itself
227 RE
"(def! not (fn* (a) (if a false true)))" $repl_env
228 RE
"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env
229 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
231 fconfigure stdout
-translation binary
234 if { [array names env DEBUG
] != "" && $env(DEBUG
) != "0" } {
239 REP
"(load-file \"[lindex $argv 0]\")" $repl_env
245 set res
[_readline
"user> "]
246 if {[lindex $res 0] == "EOF"} {
249 set line
[lindex $res 1]
253 if { [catch { puts [REP
$line $repl_env] } exception
] } {
254 puts "Error: $exception"