mal/impls/tcl/reader.tcl

oo::class create Reader {
    variable pos tokens

    constructor {tokens_list} {
        set tokens $tokens_list
        set pos 0
    }

    method peek {} {
        lindex $tokens $pos 
    }

    method next {} {
        set token [my peek]
        incr pos
        return $token
    }
}

proc tokenize str {
    set re {[\s,]*(~@|[\[\]\{\}()'`~^@]|\"(?:\\.|[^\\\"])*\"?|;[^\n]*|[^\s\[\]\{\}('\"`~^@,;)]*)}
    set tokens {}
    foreach {_ capture} [regexp -all -inline $re $str] {
        if {[string length $capture] > 0 && [string range $capture 0 0] != ";"} {
            lappend tokens $capture
        }
    }
    return $tokens
}

proc read_tokens_list {reader start_char end_char} {
    set token [$reader next]
    if {$token != $start_char} {
        error "expected '$start_char', got EOF"
    }

    set elements {}
    set token [$reader peek]
    while {$token != $end_char} {
        if {$token == ""} {
            error "expected '$end_char', got EOF"
        }
        lappend elements [read_form $reader]
        set token [$reader peek]
    }
    $reader next
    return $elements
}

proc read_list {reader} {
    set elements [read_tokens_list $reader "(" ")"]
    list_new $elements
}

proc read_vector {reader} {
    set elements [read_tokens_list $reader "\[" "\]"]
    vector_new $elements
}

proc read_hashmap {reader} {
    set res [dict create]
    foreach {keytoken valtoken} [read_tokens_list $reader "{" "}"] {
        dict set res [obj_val $keytoken] $valtoken
    }
    hashmap_new $res
}

proc parse_string {str} {
    set res [string range $str 1 end-1]
    string map {"\\n" "\n" "\\\"" "\"" "\\\\" "\\"} $res
}

proc parse_keyword {str} {
    # Remove initial ":"
    string range $str 1 end
}

proc read_atom {reader} {
    set token [$reader next]
    switch -regexp $token {
        ^-?[0-9]+$ { return [obj_new "integer" $token] }
        ^nil$      { return $::mal_nil }
        ^true$     { return $::mal_true }
        ^false$    { return $::mal_false }
        ^:         { return [keyword_new [parse_keyword $token]] }
        ^\"(\\\\.|[^\\\\\"])*\"$
	           { return [string_new [parse_string $token]] }
        ^\"        { error "expected '\"', got EOF" }
        default    { return [symbol_new $token] }
    }
}

proc symbol_shortcut {symbol_name reader} {
    $reader next
    list_new [list [symbol_new $symbol_name] [read_form $reader]]
}

proc read_form {reader} {
    switch [$reader peek] {
        "'"     { return [symbol_shortcut "quote" $reader] }
        "`"     { return [symbol_shortcut "quasiquote" $reader] }
        "~"     { return [symbol_shortcut "unquote" $reader] }
        "~@"    { return [symbol_shortcut "splice-unquote" $reader] }
        "^"     {
            $reader next
            set meta [read_form $reader]
            return [list_new [list [symbol_new "with-meta"] [read_form $reader] $meta]]
        }
        "@"     { return [symbol_shortcut "deref" $reader] }
        "("     { return [read_list $reader] }
        ")"     { error "unexpected ')'" }
        "\["    { return [read_vector $reader] }
        "\]"    { error "unexpected '\]'" }
        "\{"    { return [read_hashmap $reader] }
        "\}"    { error "unexpected '\}'" }
        default { return [read_atom $reader] }
    }
}

proc read_str str {
    set tokens [tokenize $str]
    set reader [Reader new $tokens]
    set res [read_form $reader]
    $reader destroy
    return $res
}