tcl/step9_try.tcl

   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 {$a0 == "" || ![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]} {
 105             return [eval_ast $ast $env]
 106         }
 107
 108         lassign [obj_val $ast] a0 a1 a2 a3
 109         if {$a0 == ""} {
 110             return $ast
 111         }
 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             "try*" {
 146                 set res {}
 147                 if { [catch { set res [EVAL $a1 $env] } exception] } {
 148                     set exc_var [obj_val [lindex [obj_val $a2] 1]]
 149                     if {$exception == "__MalException__"} {
 150                         set exc_value $::mal_exception_obj
 151                     } else {
 152                         set exc_value [string_new $exception]
 153                     }
 154                     set catch_env [Env new $env [list $exc_var] [list $exc_value]]
 155                     return [EVAL [lindex [obj_val $a2] 2] $catch_env]
 156                 } else {
 157                     return $res
 158                 }
 159             }
 160             "do" {
 161                 set el [list_new [lrange [obj_val $ast] 1 end-1]]
 162                 eval_ast $el $env
 163                 set ast [lindex [obj_val $ast] end]
 164                 # TCO: Continue loop
 165             }
 166             "if" {
 167                 set condval [EVAL $a1 $env]
 168                 if {[false_q $condval] || [nil_q $condval]} {
 169                     if {$a3 == ""} {
 170                         return $::mal_nil
 171                     }
 172                     set ast $a3
 173                 } else {
 174                     set ast $a2
 175                 }
 176                 # TCO: Continue loop
 177             }
 178             "fn*" {
 179                 set binds {}
 180                 foreach v [obj_val $a1] {
 181                     lappend binds [obj_val $v]
 182                 }
 183                 return [function_new $a2 $env $binds]
 184             }
 185             default {
 186                 set lst_obj [eval_ast $ast $env]
 187                 set lst [obj_val $lst_obj]
 188                 set f [lindex $lst 0]
 189                 set call_args [lrange $lst 1 end]
 190                 switch [obj_type $f] {
 191                     function {
 192                         set fn [obj_val $f]
 193                         set ast [dict get $fn body]
 194                         set env [Env new [dict get $fn env] [dict get $fn binds] $call_args]
 195                         # TCO: Continue loop
 196                     }
 197                     nativefunction {
 198                         set body [concat [list [obj_val $f]] {$a}]
 199                         set lambda [list {a} $body]
 200                         return [apply $lambda $call_args]
 201                     }
 202                     default {
 203                         error "Not a function"
 204                     }
 205                 }
 206             }
 207         }
 208     }
 209 }
 210
 211 proc PRINT exp {
 212     pr_str $exp 1
 213 }
 214
 215 proc REP {str env} {
 216     PRINT [EVAL [READ $str] $env]
 217 }
 218
 219 proc RE {str env} {
 220     EVAL [READ $str] $env
 221 }
 222
 223 proc mal_eval {a} {
 224     global repl_env
 225     EVAL [lindex $a 0] $repl_env
 226 }
 227
 228 set repl_env [Env new]
 229 dict for {k v} $core_ns {
 230     $repl_env set $k $v
 231 }
 232
 233 $repl_env set "eval" [nativefunction_new mal_eval]
 234
 235 set argv_list {}
 236 foreach arg [lrange $argv 1 end] {
 237     lappend argv_list [string_new $arg]
 238 }
 239 $repl_env set "*ARGV*" [list_new $argv_list]
 240
 241 # core.mal: defined using the language itself
 242 RE "(def! not (fn* (a) (if a false true)))" $repl_env
 243 RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env
 244 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
 245 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
 246
 247 fconfigure stdout -translation binary
 248
 249 set DEBUG_MODE 0
 250 if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
 251     set DEBUG_MODE 1
 252 }
 253
 254 if {$argc > 0} {
 255     REP "(load-file \"[lindex $argv 0]\")" $repl_env
 256     exit
 257 }
 258
 259 # repl loop
 260 while {true} {
 261     set res [_readline "user> "]
 262     if {[lindex $res 0] == "EOF"} {
 263         break
 264     }
 265     set line [lindex $res 1]
 266     if {$line == ""} {
 267         continue
 268     }
 269     if { [catch { puts [REP $line $repl_env] } exception] } {
 270         puts "Error: $exception"
 271         if { $DEBUG_MODE } {
 272             puts $::errorInfo
 273         }
 274     }
 275 }
 276 puts ""