mal/impls/tcl/types.tcl

oo::class create MalObj {
    variable type val meta

    constructor {obj_type obj_val {obj_meta 0}} {
        set type $obj_type
        set val $obj_val
        set meta $obj_meta
    }

    method get_type {} {
        return $type
    }

    method get_val {} {
        return $val
    }

    method get_meta {} {
        return $meta
    }

    method set_val {new_val} {
        set val $new_val
        return $new_val
    }
}

proc obj_new {obj_type obj_val {obj_meta 0}} {
    MalObj new $obj_type $obj_val $obj_meta
}

proc obj_type {obj} {
    $obj get_type
}

proc obj_val {obj} {
    $obj get_val
}

proc obj_meta {obj} {
    $obj get_meta
}

proc obj_set_val {obj new_val} {
    $obj set_val $new_val
}

set ::mal_nil [obj_new "nil" {}]
set ::mal_true [obj_new "true" {}]
set ::mal_false [obj_new "false" {}]

proc nil_q {obj} {
    expr {[obj_type $obj] == "nil"}
}

proc false_q {obj} {
    expr {[obj_type $obj] == "false"}
}

proc true_q {obj} {
    expr {[obj_type $obj] == "true"}
}

proc bool_new {val} {
    if {$val == 0} {
        return $::mal_false
    } else {
        return $::mal_true
    }
}

proc integer_new {num} {
    obj_new "integer" $num
}

proc integer_q {obj} {
    expr {[obj_type $obj] == "integer"}
}

proc symbol_new {name} {
    obj_new "symbol" $name
}

proc symbol_q {obj} {
    expr {[obj_type $obj] == "symbol"}
}

proc string_new {val} {
    obj_new "string" $val
}

proc string_q {obj} {
    expr {[obj_type $obj] == "string" && [string index [obj_val $obj] 0] != "\u029E"}
}

proc keyword_new {val} {
    string_new "\u029E$val"
}

proc keyword_q {obj} {
    expr {[obj_type $obj] == "string" && [string index [obj_val $obj] 0] == "\u029E"}
}

proc list_new {lst} {
    obj_new "list" $lst $::mal_nil
}

proc list_q {obj} {
    expr {[obj_type $obj] == "list"}
}

proc vector_new {lst} {
    obj_new "vector" $lst $::mal_nil
}

proc vector_q {obj} {
    expr {[obj_type $obj] == "vector"}
}

proc hashmap_new {lst} {
    obj_new "hashmap" $lst $::mal_nil
}

proc hashmap_q {obj} {
    expr {[obj_type $obj] == "hashmap"}
}

proc sequential_q {obj} {
    expr {[list_q $obj] || [vector_q $obj]}
}

proc sequential_equal_q {seq_a seq_b} {
    foreach obj_a [obj_val $seq_a] obj_b [obj_val $seq_b] {
        if {$obj_a == "" || $obj_b == "" || ![equal_q $obj_a $obj_b]} {
            return 0
        }
    }
    return 1
}

proc hashmap_equal_q {hashmap_a hashmap_b} {
    set dict_a [obj_val $hashmap_a]
    set dict_b [obj_val $hashmap_b]
    set keys_a [lsort [dict keys $dict_a]]
    set keys_b [lsort [dict keys $dict_b]]
    if {$keys_a != $keys_b} {
        return 0
    }
    foreach key $keys_a {
        set obj_a [dict get $dict_a $key]
        set obj_b [dict get $dict_b $key]
        if {![equal_q $obj_a $obj_b]} {
            return 0
        }
    }
    return 1
}

proc equal_q {a b} {
    if {[sequential_q $a] && [sequential_q $b]} {
        sequential_equal_q $a $b
    } elseif {[hashmap_q $a] && [hashmap_q $b]} {
        hashmap_equal_q $a $b
    } else {
        expr {[obj_type $a] == [obj_type $b] && [obj_val $a] == [obj_val $b]}
    }
}

proc nativefunction_new {name} {
    obj_new "nativefunction" $name $::mal_nil
}

proc function_new {body env binds} {
    set funcdict [dict create body $body env $env binds $binds is_macro 0]
    obj_new "function" $funcdict $::mal_nil
}

proc macro_new {funcobj} {
    set fn [obj_val $funcobj]
    set body [dict get $fn body]
    set env [dict get $fn env]
    set binds [dict get $fn binds]
    set funcdict [dict create body $body env $env binds $binds is_macro 1]
    obj_new "function" $funcdict $::mal_nil
}

proc function_q {obj} {
    expr {[obj_type $obj] == "function"}
}

proc macro_q {obj} {
    expr {[obj_type $obj] == "function" && [dict get [obj_val $obj] is_macro]}
}

proc atom_new {val} {
    obj_new "atom" $val $::mal_nil
}

proc atom_q {obj} {
    expr {[obj_type $obj] == "atom"}
}