tcl/step4_if_fn_do.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     if {![list_q $ast]} {
  45         return [eval_ast $ast $env]
  46     }
  47     lassign [obj_val $ast] a0 a1 a2 a3
  48     switch [obj_val $a0] {
  49         "def!" {
  50             set varname [obj_val $a1]
  51             set value [EVAL $a2 $env]
  52             return [$env set $varname $value]
  53         }
  54         "let*" {
  55             set letenv [Env new $env]
  56             set bindings_list [obj_val $a1]
  57             foreach {varnameobj varvalobj} $bindings_list {
  58                 $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv]
  59             }
  60             return [EVAL $a2 $letenv]
  61         }
  62         "do" {
  63             set el [list_new [lrange [obj_val $ast] 1 end-1]]
  64             eval_ast $el $env
  65             return [EVAL [lindex [obj_val $ast] end] $env]
  66         }
  67         "if" {
  68             set condval [EVAL $a1 $env]
  69             if {[false_q $condval] || [nil_q $condval]} {
  70                 if {$a3 == ""} {
  71                     return $::mal_nil
  72                 }
  73                 return [EVAL $a3 $env]
  74             }
  75             return [EVAL $a2 $env]
  76         }
  77         "fn*" {
  78             set binds {}
  79             foreach v [obj_val $a1] {
  80                 lappend binds [obj_val $v]
  81             }
  82             return [function_new $a2 $env $binds]
  83         }
  84         default {
  85             set lst_obj [eval_ast $ast $env]
  86             set lst [obj_val $lst_obj]
  87             set f [lindex $lst 0]
  88             set call_args [lrange $lst 1 end]
  89             switch [obj_type $f] {
  90                 function {
  91                     set funcdict [obj_val $f]
  92                     set body [dict get $funcdict body]
  93                     set env [dict get $funcdict env]
  94                     set binds [dict get $funcdict binds]
  95                     set funcenv [Env new $env $binds $call_args]
  96                     return [EVAL $body $funcenv]
  97                 }
  98                 nativefunction {
  99                     set body [concat [list [obj_val $f]] {$a}]
 100                     set lambda [list {a} $body]
 101                     return [apply $lambda $call_args]
 102                 }
 103                 default {
 104                     error "Not a function"
 105                 }
 106             }
 107         }
 108     }
 109 }
 110
 111 proc PRINT exp {
 112     pr_str $exp 1
 113 }
 114
 115 proc REP {str env} {
 116     PRINT [EVAL [READ $str] $env]
 117 }
 118
 119 proc RE {str env} {
 120     EVAL [READ $str] $env
 121 }
 122
 123 set repl_env [Env new]
 124 dict for {k v} $core_ns {
 125     $repl_env set $k $v
 126 }
 127
 128 # core.mal: defined using the language itself
 129 RE "(def! not (fn* (a) (if a false true)))" $repl_env
 130
 131 fconfigure stdout -translation binary
 132
 133 set DEBUG_MODE 0
 134 if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
 135     set DEBUG_MODE 1
 136 }
 137
 138 # repl loop
 139 while {true} {
 140     set res [_readline "user> "]
 141     if {[lindex $res 0] == "EOF"} {
 142         break
 143     }
 144     set line [lindex $res 1]
 145     if {$line == ""} {
 146         continue
 147     }
 148     if { [catch { puts [REP $line $repl_env] } exception] } {
 149         puts "Error: $exception"
 150         if { $DEBUG_MODE } {
 151             puts $::errorInfo
 152         }
 153     }
 154 }
 155 puts ""