impls/tcl/step8_macros.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 starts_with {lst sym} {
  13     if {[llength $lst] != 2} {
  14         return 0
  15     }
  16     lassign [lindex $lst 0] a0
  17     return [symbol_q $a0] && [expr {[obj_val $a0] == $sym}]
  18 }
  19 proc qq_loop {elt acc} {
  20     if {[list_q $elt] && [starts_with [obj_val $elt] "splice-unquote"]} {
  21         return [list_new [list [symbol_new "concat"] [lindex [obj_val $elt] 1] $acc]]
  22     } else {
  23         return [list_new [list [symbol_new "cons"] [quasiquote $elt] $acc]]
  24     }
  25 }
  26 proc qq_foldr {xs} {
  27     set acc [list_new []]
  28     for {set i [expr {[llength $xs] - 1}]} {0 <= $i} {incr i -1} {
  29         set acc [qq_loop [lindex $xs $i] $acc]
  30     }
  31     return $acc
  32 }
  33
  34 proc quasiquote {ast} {
  35     switch [obj_type $ast] {
  36         "symbol" {
  37             return [list_new [list [symbol_new "quote"] $ast]]
  38         }
  39         "hashmap" {
  40             return [list_new [list [symbol_new "quote"] $ast]]
  41         }
  42         "vector" {
  43             return [list_new [list [symbol_new "vec"] [qq_foldr [obj_val $ast]]]]
  44         }
  45         "list" {
  46             if {[starts_with [obj_val $ast] "unquote"]} {
  47                 return [lindex [obj_val $ast] 1]
  48             } else {
  49                 return [qq_foldr [obj_val $ast]]
  50             }
  51         }
  52         default {
  53             return $ast
  54         }
  55     }
  56 }
  57
  58 proc is_macro_call {ast env} {
  59     if {![list_q $ast]} {
  60         return 0
  61     }
  62     set a0 [lindex [obj_val $ast] 0]
  63     if {$a0 == "" || ![symbol_q $a0]} {
  64         return 0
  65     }
  66     set varname [obj_val $a0]
  67     set foundenv [$env find $varname]
  68     if {$foundenv == 0} {
  69         return 0
  70     }
  71     macro_q [$env get $varname]
  72 }
  73
  74 proc macroexpand {ast env} {
  75     while {[is_macro_call $ast $env]} {
  76         set a0 [mal_first [list $ast]]
  77         set macro_name [obj_val $a0]
  78         set macro_obj [$env get $macro_name]
  79         set macro_args [obj_val [mal_rest [list $ast]]]
  80
  81         set funcdict [obj_val $macro_obj]
  82         set body [dict get $funcdict body]
  83         set env [dict get $funcdict env]
  84         set binds [dict get $funcdict binds]
  85         set funcenv [Env new $env $binds $macro_args]
  86         set ast [EVAL $body $funcenv]
  87     }
  88     return $ast
  89 }
  90
  91 proc eval_ast {ast env} {
  92     switch [obj_type $ast] {
  93         "symbol" {
  94             set varname [obj_val $ast]
  95             return [$env get $varname]
  96         }
  97         "list" {
  98             set res {}
  99             foreach element [obj_val $ast] {
 100                 lappend res [EVAL $element $env]
 101             }
 102             return [list_new $res]
 103         }
 104         "vector" {
 105             set res {}
 106             foreach element [obj_val $ast] {
 107                 lappend res [EVAL $element $env]
 108             }
 109             return [vector_new $res]
 110         }
 111         "hashmap" {
 112             set res [dict create]
 113             dict for {k v} [obj_val $ast] {
 114                 dict set res $k [EVAL $v $env]
 115             }
 116             return [hashmap_new $res]
 117         }
 118         default { return $ast }
 119     }
 120 }
 121
 122 proc EVAL {ast env} {
 123     while {true} {
 124         if {![list_q $ast]} {
 125             return [eval_ast $ast $env]
 126         }
 127
 128         set ast [macroexpand $ast $env]
 129         if {![list_q $ast]} {
 130             return [eval_ast $ast $env]
 131         }
 132
 133         lassign [obj_val $ast] a0 a1 a2 a3
 134         if {$a0 == ""} {
 135             return $ast
 136         }
 137         switch [obj_val $a0] {
 138             "def!" {
 139                 set varname [obj_val $a1]
 140                 set value [EVAL $a2 $env]
 141                 return [$env set $varname $value]
 142             }
 143             "let*" {
 144                 set letenv [Env new $env]
 145                 set bindings_list [obj_val $a1]
 146                 foreach {varnameobj varvalobj} $bindings_list {
 147                     $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv]
 148                 }
 149                 set ast $a2
 150                 set env $letenv
 151                 # TCO: Continue loop
 152             }
 153             "quote" {
 154                 return $a1
 155             }
 156             "quasiquoteexpand" {
 157                 return [quasiquote $a1]
 158             }
 159             "quasiquote" {
 160                 set ast [quasiquote $a1]
 161             }
 162             "defmacro!" {
 163                 set varname [obj_val $a1]
 164                 set value [EVAL $a2 $env]
 165                 return [$env set $varname [macro_new $value]]
 166             }
 167             "macroexpand" {
 168                 return [macroexpand $a1 $env]
 169             }
 170             "do" {
 171                 set el [list_new [lrange [obj_val $ast] 1 end-1]]
 172                 eval_ast $el $env
 173                 set ast [lindex [obj_val $ast] end]
 174                 # TCO: Continue loop
 175             }
 176             "if" {
 177                 set condval [EVAL $a1 $env]
 178                 if {[false_q $condval] || [nil_q $condval]} {
 179                     if {$a3 == ""} {
 180                         return $::mal_nil
 181                     }
 182                     set ast $a3
 183                 } else {
 184                     set ast $a2
 185                 }
 186                 # TCO: Continue loop
 187             }
 188             "fn*" {
 189                 set binds {}
 190                 foreach v [obj_val $a1] {
 191                     lappend binds [obj_val $v]
 192                 }
 193                 return [function_new $a2 $env $binds]
 194             }
 195             default {
 196                 set lst_obj [eval_ast $ast $env]
 197                 set lst [obj_val $lst_obj]
 198                 set f [lindex $lst 0]
 199                 set call_args [lrange $lst 1 end]
 200                 switch [obj_type $f] {
 201                     function {
 202                         set fn [obj_val $f]
 203                         set ast [dict get $fn body]
 204                         set env [Env new [dict get $fn env] [dict get $fn binds] $call_args]
 205                         # TCO: Continue loop
 206                     }
 207                     nativefunction {
 208                         set body [concat [list [obj_val $f]] {$a}]
 209                         set lambda [list {a} $body]
 210                         return [apply $lambda $call_args]
 211                     }
 212                     default {
 213                         error "Not a function"
 214                     }
 215                 }
 216             }
 217         }
 218     }
 219 }
 220
 221 proc PRINT exp {
 222     pr_str $exp 1
 223 }
 224
 225 proc REP {str env} {
 226     PRINT [EVAL [READ $str] $env]
 227 }
 228
 229 proc RE {str env} {
 230     EVAL [READ $str] $env
 231 }
 232
 233 proc mal_eval {a} {
 234     global repl_env
 235     EVAL [lindex $a 0] $repl_env
 236 }
 237
 238 set repl_env [Env new]
 239 dict for {k v} $core_ns {
 240     $repl_env set $k $v
 241 }
 242
 243 $repl_env set "eval" [nativefunction_new mal_eval]
 244
 245 set argv_list {}
 246 foreach arg [lrange $argv 1 end] {
 247     lappend argv_list [string_new $arg]
 248 }
 249 $repl_env set "*ARGV*" [list_new $argv_list]
 250
 251 # core.mal: defined using the language itself
 252 RE "(def! not (fn* (a) (if a false true)))" $repl_env
 253 RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))" $repl_env
 254 RE "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" $repl_env
 255
 256 fconfigure stdout -translation binary
 257
 258 set DEBUG_MODE 0
 259 if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
 260     set DEBUG_MODE 1
 261 }
 262
 263 if {$argc > 0} {
 264     REP "(load-file \"[lindex $argv 0]\")" $repl_env
 265     exit
 266 }
 267
 268 # repl loop
 269 while {true} {
 270     set res [_readline "user> "]
 271     if {[lindex $res 0] == "EOF"} {
 272         break
 273     }
 274     set line [lindex $res 1]
 275     if {$line == ""} {
 276         continue
 277     }
 278     if { [catch { puts [REP $line $repl_env] } exception] } {
 279         puts "Error: $exception"
 280         if { $DEBUG_MODE } {
 281             puts $::errorInfo
 282         }
 283     }
 284 }
 285 puts ""