tcl/step3_env.tcl

   1 source mal_readline.tcl
   2 source types.tcl
   3 source reader.tcl
   4 source printer.tcl
   5 source env.tcl
   6
   7 proc READ str {
   8     read_str $str
   9 }
  10
  11 proc eval_ast {ast env} {
  12     switch [obj_type $ast] {
  13         "symbol" {
  14             set varname [obj_val $ast]
  15             return [$env get $varname]
  16         }
  17         "list" {
  18             set res {}
  19             foreach element [obj_val $ast] {
  20                 lappend res [EVAL $element $env]
  21             }
  22             return [list_new $res]
  23         }
  24         "vector" {
  25             set res {}
  26             foreach element [obj_val $ast] {
  27                 lappend res [EVAL $element $env]
  28             }
  29             return [vector_new $res]
  30         }
  31         "hashmap" {
  32             set res [dict create]
  33             dict for {k v} [obj_val $ast] {
  34                 dict set res $k [EVAL $v $env]
  35             }
  36             return [hashmap_new $res]
  37         }
  38         default { return $ast }
  39     }
  40 }
  41
  42 proc EVAL {ast env} {
  43     if {![list_q $ast]} {
  44         return [eval_ast $ast $env]
  45     }
  46     set a0 [lindex [obj_val $ast] 0]
  47     if {$a0 == ""} {
  48         return $ast
  49     }
  50     set a1 [lindex [obj_val $ast] 1]
  51     set a2 [lindex [obj_val $ast] 2]
  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             return [EVAL $a2 $letenv]
  65         }
  66         default {
  67             set lst_obj [eval_ast $ast $env]
  68             set lst [obj_val $lst_obj]
  69             set f [lindex $lst 0]
  70             set call_args [lrange $lst 1 end]
  71             return [apply $f $call_args]
  72         }
  73     }
  74 }
  75
  76 proc PRINT exp {
  77     pr_str $exp 1
  78 }
  79
  80 proc REP {str env} {
  81     PRINT [EVAL [READ $str] $env]
  82 }
  83
  84 proc mal_add {a} {
  85     integer_new [expr {[obj_val [lindex $a 0]] + [obj_val [lindex $a 1]]}]
  86 }
  87
  88 proc mal_sub {a} {
  89     integer_new [expr {[obj_val [lindex $a 0]] - [obj_val [lindex $a 1]]}]
  90 }
  91
  92 proc mal_mul {a} {
  93     integer_new [expr {[obj_val [lindex $a 0]] * [obj_val [lindex $a 1]]}]
  94 }
  95
  96 proc mal_div {a} {
  97     integer_new [expr {[obj_val [lindex $a 0]] / [obj_val [lindex $a 1]]}]
  98 }
  99
 100 set repl_env [Env new]
 101 $repl_env set "+" {{a} {mal_add $a}}
 102 $repl_env set "-" {{a} {mal_sub $a}}
 103 $repl_env set "*" {{a} {mal_mul $a}}
 104 $repl_env set "/" {{a} {mal_div $a}}
 105
 106 fconfigure stdout -translation binary
 107
 108 # repl loop
 109 while {true} {
 110     set res [_readline "user> "]
 111     if {[lindex $res 0] == "EOF"} {
 112         break
 113     }
 114     set line [lindex $res 1]
 115     if {$line == ""} {
 116         continue
 117     }
 118     if { [catch { puts [REP $line $repl_env] } exception] } {
 119         puts "Error: $exception"
 120     }
 121 }
 122 puts ""