mal/tcl/stepA_mal.tcl

source mal_readline.tcl
source types.tcl
source reader.tcl
source printer.tcl
source env.tcl
source core.tcl

proc READ str {
    read_str $str
}

proc is_pair {ast} {
    expr {[sequential_q $ast] && [llength [obj_val $ast]] > 0}
}

proc quasiquote {ast} {
    if {![is_pair $ast]} {
        return [list_new [list [symbol_new "quote"] $ast]]
    }
    lassign [obj_val $ast] a0 a1
    if {[symbol_q $a0] && [obj_val $a0] == "unquote"} {
        return $a1
    }
    lassign [obj_val $a0] a00 a01
    set rest [list_new [lrange [obj_val $ast] 1 end]]
    if {[is_pair $a0] && [symbol_q $a00] && [obj_val $a00] == "splice-unquote"} {
        return [list_new [list [symbol_new "concat"] $a01 [quasiquote $rest]]]
    } else {
        return [list_new [list [symbol_new "cons"] [quasiquote $a0] [quasiquote $rest]]]
    }
}

proc is_macro_call {ast env} {
    if {![list_q $ast]} {
        return 0
    }
    set a0 [lindex [obj_val $ast] 0]
    if {![symbol_q $a0]} {
        return 0
    }
    set varname [obj_val $a0]
    set foundenv [$env find $varname]
    if {$foundenv == 0} {
        return 0
    }
    macro_q [$env get $varname]
}

proc macroexpand {ast env} {
    while {[is_macro_call $ast $env]} {
        set a0 [mal_first [list $ast]]
        set macro_name [obj_val $a0]
        set macro_obj [$env get $macro_name]
        set macro_args [obj_val [mal_rest [list $ast]]]

        set funcdict [obj_val $macro_obj]
        set body [dict get $funcdict body]
        set env [dict get $funcdict env]
        set binds [dict get $funcdict binds]
        set funcenv [Env new $env $binds $macro_args]
        set ast [EVAL $body $funcenv]
    }
    return $ast
}

proc eval_ast {ast env} {
    switch [obj_type $ast] {
        "symbol" {
            set varname [obj_val $ast]
            return [$env get $varname]
        }
        "list" {
            set res {}
            foreach element [obj_val $ast] {
                lappend res [EVAL $element $env]
            }
            return [list_new $res]
        }
        "vector" {
            set res {}
            foreach element [obj_val $ast] {
                lappend res [EVAL $element $env]
            }
            return [vector_new $res]
        }
        "hashmap" {
            set res [dict create]
            dict for {k v} [obj_val $ast] {
                dict set res $k [EVAL $v $env]
            }
            return [hashmap_new $res]
        }
        default { return $ast }
    }
}

proc EVAL {ast env} {
    while {true} {
        if {![list_q $ast]} {
            return [eval_ast $ast $env]
        }

        set ast [macroexpand $ast $env]
        if {![list_q $ast]} {
            return [eval_ast $ast $env]
        }

        lassign [obj_val $ast] a0 a1 a2 a3
        switch [obj_val $a0] {
            "def!" {
                set varname [obj_val $a1]
                set value [EVAL $a2 $env]
                return [$env set $varname $value]
            }
            "let*" {
                set letenv [Env new $env]
                set bindings_list [obj_val $a1]
                foreach {varnameobj varvalobj} $bindings_list {
                    $letenv set [obj_val $varnameobj] [EVAL $varvalobj $letenv]
                }
                set ast $a2
                set env $letenv
                # TCO: Continue loop
            }
            "quote" {
                return $a1
            }
            "quasiquote" {
                set ast [quasiquote $a1]
            }
            "defmacro!" {
                set varname [obj_val $a1]
                set value [EVAL $a2 $env]
                set fn [obj_val $value]
                dict set fn is_macro 1
                obj_set_val $value $fn
                return [$env set $varname $value]
            }
            "macroexpand" {
                return [macroexpand $a1 $env]
            }
            "tcl*" {
                return [string_new [eval [obj_val $a1]]]
            }
            "try*" {
                set res {}
                if { [catch { set res [EVAL $a1 $env] } exception] } {
                    set exc_var [obj_val [lindex [obj_val $a2] 1]]
                    if {$exception == "__MalException__"} {
                        set exc_value $::mal_exception_obj
                    } else {
                        set exc_value [string_new $exception]
                    }
                    set catch_env [Env new $env [list $exc_var] [list $exc_value]]
                    return [EVAL [lindex [obj_val $a2] 2] $catch_env]
                } else {
                    return $res
                }
            }
            "do" {
                set el [list_new [lrange [obj_val $ast] 1 end-1]]
                eval_ast $el $env
                set ast [lindex [obj_val $ast] end]
                # TCO: Continue loop
            }
            "if" {
                set condval [EVAL $a1 $env]
                if {[false_q $condval] || [nil_q $condval]} {
                    if {$a3 == ""} {
                        return $::mal_nil
                    }
                    set ast $a3
                } else {
                    set ast $a2
                }
                # TCO: Continue loop
            }
            "fn*" {
                set binds {}
                foreach v [obj_val $a1] {
                    lappend binds [obj_val $v]
                }
                return [function_new $a2 $env $binds]
            }
            default {
                set lst_obj [eval_ast $ast $env]
                set lst [obj_val $lst_obj]
                set f [lindex $lst 0]
                set call_args [lrange $lst 1 end]
                switch [obj_type $f] {
                    function {
                        set fn [obj_val $f]
                        set ast [dict get $fn body]
                        set env [Env new [dict get $fn env] [dict get $fn binds] $call_args]
                        # TCO: Continue loop
                    }
                    nativefunction {
                        set body [concat [list [obj_val $f]] {$a}]
                        set lambda [list {a} $body]
                        return [apply $lambda $call_args]
                    }
                    default {
                        error "Not a function"
                    }
                }
            }
        }
    }
}

proc PRINT exp {
    pr_str $exp 1
}

proc REP {str env} {
    PRINT [EVAL [READ $str] $env]
}

proc RE {str env} {
    EVAL [READ $str] $env
}

proc mal_eval {a} {
    global repl_env
    EVAL [lindex $a 0] $repl_env
}

set repl_env [Env new]
dict for {k v} $core_ns {
    $repl_env set $k $v
}

$repl_env set "eval" [nativefunction_new mal_eval]

set argv_list {}
foreach arg [lrange $argv 1 end] {
    lappend argv_list [string_new $arg]
}
$repl_env set "*ARGV*" [list_new $argv_list]

# core.mal: defined using the language itself
RE "(def! *host-language* \"tcl\")" $repl_env
RE "(def! not (fn* (a) (if a false true)))" $repl_env
RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" $repl_env
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
RE "(def! *gensym-counter* (atom 0))" $repl_env
RE "(def! gensym (fn* \[\] (symbol (str \"G__\" (swap! *gensym-counter* (fn* \[x\] (+ 1 x)))))))" $repl_env
RE "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))" $repl_env

fconfigure stdout -translation binary

set DEBUG_MODE 0
if { [array names env DEBUG] != "" && $env(DEBUG) != "0" } {
    set DEBUG_MODE 1
}

if {$argc > 0} {
    REP "(load-file \"[lindex $argv 0]\")" $repl_env
    exit
}

REP "(println (str \"Mal \[\" *host-language* \"\]\"))" $repl_env

# repl loop
while {true} {
    set res [_readline "user> "]
    if {[lindex $res 0] == "EOF"} {
        break
    }
    set line [lindex $res 1]
    if {$line == ""} {
        continue
    }
    if { [catch { puts [REP $line $repl_env] } exception] } {
        puts "Error: $exception"
        if { $DEBUG_MODE } {
            puts $::errorInfo
        }
    }
}
puts ""