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