tcl/step5_tco.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 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
  49         if {$a0 == ""} {
  50             return $ast
  51         }
  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 set repl_env [Env new]
 132 dict for {k v} $core_ns {
 133     $repl_env set $k $v
 134 }
 135
 136 # core.mal: defined using the language itself
 137 RE "(def! not (fn* (a) (if a false true)))" $repl_env
 138
 139 fconfigure stdout -translation binary
 140
 141 set DEBUG_MODE 0
 142 if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
 143     set DEBUG_MODE 1
 144 }
 145
 146 # repl loop
 147 while {true} {
 148     set res [_readline "user> "]
 149     if {[lindex $res 0] == "EOF"} {
 150         break
 151     }
 152     set line [lindex $res 1]
 153     if {$line == ""} {
 154         continue
 155     }
 156     if { [catch { puts [REP $line $repl_env] } exception] } {
 157         puts "Error: $exception"
 158         if { $DEBUG_MODE } {
 159             puts $::errorInfo
 160         }
 161     }
 162 }
 163 puts ""