tcl/step7_quote.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 eval_ast {ast env} {
  34     switch [obj_type $ast] {
  35         "symbol" {
  36             set varname [obj_val $ast]
  37             return [$env get $varname]
  38         }
  39         "list" {
  40             set res {}
  41             foreach element [obj_val $ast] {
  42                 lappend res [EVAL $element $env]
  43             }
  44             return [list_new $res]
  45         }
  46         "vector" {
  47             set res {}
  48             foreach element [obj_val $ast] {
  49                 lappend res [EVAL $element $env]
  50             }
  51             return [vector_new $res]
  52         }
  53         "hashmap" {
  54             set res [dict create]
  55             dict for {k v} [obj_val $ast] {
  56                 dict set res $k [EVAL $v $env]
  57             }
  58             return [hashmap_new $res]
  59         }
  60         default { return $ast }
  61     }
  62 }
  63
  64 proc EVAL {ast env} {
  65     while {true} {
  66         if {![list_q $ast]} {
  67             return [eval_ast $ast $env]
  68         }
  69         lassign [obj_val $ast] a0 a1 a2 a3
  70         switch [obj_val $a0] {
  71             "def!" {
  72                 set varname [obj_val $a1]
  73                 set value [EVAL $a2 $env]
  74                 return [$env set $varname $value]
  75             }
  76             "let*" {
  77                 set letenv [Env new $env]
  78                 set bindings_list [obj_val $a1]
  79                 foreach {varnameobj varvalobj} $bindings_list {
  80                     $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv]
  81                 }
  82                 set ast $a2
  83                 set env $letenv
  84                 # TCO: Continue loop
  85             }
  86             "quote" {
  87                 return $a1
  88             }
  89             "quasiquote" {
  90                 set ast [quasiquote $a1]
  91             }
  92             "do" {
  93                 set el [list_new [lrange [obj_val $ast] 1 end-1]]
  94                 eval_ast $el $env
  95                 set ast [lindex [obj_val $ast] end]
  96                 # TCO: Continue loop
  97             }
  98             "if" {
  99                 set condval [EVAL $a1 $env]
 100                 if {[false_q $condval] || [nil_q $condval]} {
 101                     if {$a3 == ""} {
 102                         return $::mal_nil
 103                     }
 104                     set ast $a3
 105                 } else {
 106                     set ast $a2
 107                 }
 108                 # TCO: Continue loop
 109             }
 110             "fn*" {
 111                 set binds {}
 112                 foreach v [obj_val $a1] {
 113                     lappend binds [obj_val $v]
 114                 }
 115                 return [function_new $a2 $env $binds]
 116             }
 117             default {
 118                 set lst_obj [eval_ast $ast $env]
 119                 set lst [obj_val $lst_obj]
 120                 set f [lindex $lst 0]
 121                 set call_args [lrange $lst 1 end]
 122                 switch [obj_type $f] {
 123                     function {
 124                         set fn [obj_val $f]
 125                         set ast [dict get $fn body]
 126                         set env [Env new [dict get $fn env] [dict get $fn binds] $call_args]
 127                         # TCO: Continue loop
 128                     }
 129                     nativefunction {
 130                         set body [concat [list [obj_val $f]] {$a}]
 131                         set lambda [list {a} $body]
 132                         return [apply $lambda $call_args]
 133                     }
 134                     default {
 135                         error "Not a function"
 136                     }
 137                 }
 138             }
 139         }
 140     }
 141 }
 142
 143 proc PRINT exp {
 144     pr_str $exp 1
 145 }
 146
 147 proc REP {str env} {
 148     PRINT [EVAL [READ $str] $env]
 149 }
 150
 151 proc RE {str env} {
 152     EVAL [READ $str] $env
 153 }
 154
 155 proc mal_eval {a} {
 156     global repl_env
 157     EVAL [lindex $a 0] $repl_env
 158 }
 159
 160 set repl_env [Env new]
 161 dict for {k v} $core_ns {
 162     $repl_env set $k $v
 163 }
 164
 165 $repl_env set "eval" [nativefunction_new mal_eval]
 166
 167 set argv_list {}
 168 foreach arg [lrange $argv 1 end] {
 169     lappend argv_list [string_new $arg]
 170 }
 171 $repl_env set "*ARGV*" [list_new $argv_list]
 172
 173 # core.mal: defined using the language itself
 174 RE "(def! not (fn* (a) (if a false true)))" $repl_env
 175 RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env
 176
 177 fconfigure stdout -translation binary
 178
 179 set DEBUG_MODE 0
 180 if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
 181     set DEBUG_MODE 1
 182 }
 183
 184 if {$argc > 0} {
 185     REP "(load-file \"[lindex $argv 0]\")" $repl_env
 186     exit
 187 }
 188
 189 # repl loop
 190 while {true} {
 191     set res [_readline "user> "]
 192     if {[lindex $res 0] == "EOF"} {
 193         break
 194     }
 195     set line [lindex $res 1]
 196     if {$line == ""} {
 197         continue
 198     }
 199     if { [catch { puts [REP $line $repl_env] } exception] } {
 200         puts "Error: $exception"
 201         if { $DEBUG_MODE } {
 202             puts $::errorInfo
 203         }
 204     }
 205 }
 206 puts ""