package require struct
# Исходный текст.
set input_buffer {}
# Память. Список байтов.
set output_buffer {}
# Созданные слова.
array set dict {}
# Адрес последнего определенного слова.
set last_word 0
# Стек для условий и циклов.
::struct::stack stack
# Слова - единичные инструкции.
lappend istr      DUP    +      AND    OR     =      <      U<     NIP    DROP   NOT    1-
lappend istr_code 0x6081 0x6203 0x6303 0x6403 0x6703 0x6803 0x6F03 0x6003 0x6103 0x6600 0x6A00
lappend istr      1<<    1>>    swap_bytes A@     SWAP   DEPTH  R@     OVER   >R     R>     {;}    EXIT
lappend istr_code 0x6D00 0x6900 0x6500     0x6C00 0x6180 0x6E81 0x6BC1 0x6181 0x6147 0x6BCD 0x700C 0x700C

if {$argc != 2} {
    puts {Incorrect command line arguments.}
    exit
}

set input_filename [lindex $argv 0]
set output_filename [lindex $argv 1]

proc append_byte {byte} {
    global output_buffer
    lappend output_buffer $byte
}

proc append_word {word} {
    global output_buffer
    lappend output_buffer [expr {$word & 0xFF}]
    lappend output_buffer [expr {($word >> 8) & 0xFF}]
}

# Если слово является инструкцией процессора, то компилирует его и возвращает true,
# если не является инструкцией процессора, то возвращает false.
proc istr_compile {word} {
    global istr istr_code
    if {$word == "A!"} {
        append_word 24867
        append_word 24835
        return true
    } else {
        set pos [lsearch $istr $word]
        if {$pos < 0} {
            return false
        } else {
            append_word [lindex $istr_code $pos]
            return true
        }
    }
}

# Компиляция ранее определенного слова или предопределенного слова (инструкции).
# Если слово есть в словаре, возвращает true, иначе возвращает false.
proc compile_word {word} {
    global dict
    if {[istr_compile $word]} {
        return true
    } else {
        if {[info exists dict($word)]} {
            append_word [expr {($dict($word) >> 1) | 0x4000}]
            return true
        } else {
            return false
        }
    }
}

proc compile_literal {number} {
    set num [expr {$number & 0xFFFF}]
    if {$num > 0x7FFF} {
        append_word [expr {~$num | 0x8000}]
        compile_word "NOT"
    } else {
        append_word [expr {$num | 0x8000}]
    }
}

proc parse_word {} {
    global input_buffer
    set input_buffer [string trimleft $input_buffer " \t\n"]
    regexp {^([^\s\t\n]*)(.*)} $input_buffer buf word input_buffer
    return $word
}

# Адрес начала незанятой памяти.
proc here {} {
    global output_buffer
    return [llength $output_buffer]
}

# Формат заголовка:
# выравнивающий байт (при нечетной длине имени)
# имя (побайтно)
# терминирующий нулевой байт
# признак immediate - 1байт (по умолчанию 0)
# адрес предыдущего слова - 2 байта.
proc new_word {name} {
    global dict last_word
    append_byte 0
    if {[string bytelength $name] % 2 != 1} {
        # Выравнивающий байт.
        append_byte 0
    }
    foreach char [split $name {}] {
        append_byte [scan $char %c]
    }
    # Терминирующий байт.
    append_byte 0
    # Байт признака.
    append_byte 0
    # Адрес предыдущего слова.
    append_word $last_word
    set last_word [here]
    # Добавление в словарь.
    set dict($name) [here]
}

proc read_word {addr} {
    global output_buffer
    set wordL [lindex $output_buffer $addr]
    set wordH [lindex $output_buffer $addr+1]
    return [expr {$wordL | ($wordH << 8)}]
}

proc replace_word {addr word} {
    global output_buffer
    set wordL [expr {$word & 0xFF}]
    set wordH [expr {($word >> 8) & 0xFF}]
    set output_buffer [lreplace $output_buffer $addr $addr+1 $wordL $wordH]
}

proc compile_string {str} {
    for {set i 0} {$i < [string length $str]} {incr i; incr i} {
        set chr1 [string index $str $i]; set n1 [expr [scan $chr1 %c]+0]
        set chr2 [string index $str $i+1]; set n2 [expr [scan $chr2 %c]+0]
        append_word [expr {$n1 | ($n2 << 8)}]
    }
    if {[string length $str] % 2 != 1} {append_word 0}
}

proc compile_input {} {
    global input_buffer last_word output_buffer dict
    while {[string trim $input_buffer " \t\n"] != {}} {
        set word [parse_word]
        switch $word {
            : {
                new_word [parse_word]
            }
            IMMEDIATE {
                # Задает последнему слову признак немедленного исплонения.
                set pos [expr {$last_word - 3}]
                set output_buffer [lreplace $output_buffer $pos $pos 1]
            }
            IF {
                stack push [here]
                # Опкод условного перехода.
                append_word 0x2000
            }
            ELSE {
                stack push [here]
                stack rotate 2 1
                # Опкод безусловного перехода.
                append_word 0
                set addr [stack pop]
                set word [expr {[read_word $addr] | ([here] >> 1)}]
                replace_word $addr $word
            }
            THEN {
                set addr [stack pop]
                set word [expr {[read_word $addr] | ([here] >> 1)}]
                replace_word $addr $word
            }
            BEGIN {
                stack push [expr {[here] >> 1}]
            }
            AGAIN {
                append_word [stack pop]
            }
            UNTIL {
                append_word [expr {[stack pop] | 0x2000}]
            }
            WHILE {
                stack push [here]
                append_word 0
            }
            REPEAT {
                stack rotate 2 1
                append_word [stack pop]
                replace_word [stack pop] [expr {([here] >> 1) | 0x2000}]
            }
            "\\" {
                # Комментарий.
                regexp {[^\n]*(.*)} $input_buffer buf input_buffer
            }
            Tcl" {
                regexp {^.([^\"]*)\"(.*)} $input_buffer buf str input_buffer
                eval $str
            }
            default {
                if {![compile_word $word]} {
                    if {[string is integer $word]} {
                        compile_literal $word
                    } else {
                        puts "Unknown token: $word"
                        exit
                    }
                }
            }
        }
    }
}

if [catch {open forth.f r} forth_file] {
    puts stderr $forth_file
    exit
} else {
    set input_buffer [read $forth_file]
    close $forth_file
}

compile_input

if [catch {open $output_filename w} out_file] {
    puts stderr $out_file
} else {
    fconfigure $out_file -translation binary -encoding binary
    set addr 0
    foreach byte $output_buffer {
        incr addr
        puts -nonewline $out_file [binary format c $byte]
    }
    for {set i $addr} {$i < 0x4000} {incr i} {
        puts -nonewline $out_file [binary format c 0]
    }
    close $out_file
}
puts "[llength $output_buffer] bytes"
puts "[array size dict] words"
puts {Done.}