package require struct
# Исходный текст.
set input_buffer {}
# Память. Список байтов.
set output_buffer {}
# Созданные слова.
array set dict {}
# Адрес последнего определенного слова.
set last 0
# Стек для условий и циклов.
::struct::stack stack
# Слова - единичные инструкции.
lappend istr      DUP    +      AND    OR     =      <     U<     NIP    DROP   NOT    1-
lappend istr_code 0x6081 0x6203 0x6303 0x6403 0x6703 26627 0x6803 0x6003 0x6103 0x6600 0x6A00
lappend istr      1<<   1>>   swap_bytes  A@    SWAP  DEPTH R@    OVER  >R    R>    {;}
lappend istr_code 27904 26880 25856       27648 24960 28289 27585 24961 24903 27597 28684
# Костыль для констант.
array set constants {}

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 {[info exists dict($word)]} {
        append_word [expr {($dict($word) >> 1) | 0x4000}]
        return true
    } else {
        return [istr_compile $word]
    }
}

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 compile_const {name} {
    global constants
    if {[info exists constants($name)]} {
        compile_literal $constants($name)
        return true
    } else {
        return false
    }
}

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
    if {[string bytelength $name] % 2 != 0} {
        # Выравнивающий байт.
        append_byte 0
    }
    foreach char [split $name {}] {
        append_byte [scan $char %c]
    }
    # Терминирующий байт.
    append_byte 0
    # Байт признака.
    append_byte 0
    # Адрес предыдущего слова.
    append_word $last
    set last [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]
}

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

while {[string trim $input_buffer " \t\n"] != {}} {
    set word [parse_word]
    switch $word {
        : {
            new_word [parse_word]
        }
        IMMEDIATE {
            # Задает последнему слову признак немедленного исплонения.
            set pos [expr [last] - 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
        }
        jump {
            replace_word 0 [expr {[here] >> 1 }]
        }
        code {
            append_word [parse_word]
        }
        # Костыль для костант.
        const {
            set const_name [parse_word]
            set const_val [parse_word]
            if {$const_val == {here}} {
                set constants($const_name) [here]
            } else {
                set constants($const_name) $const_val
            }
        }
        default {
            if {![compile_word $word] && ![compile_const $word]} {
                if {[string is integer $word]} {
                    compile_literal $word
                } else {
                    puts "Unknown token: $word"
                    exit
                }
            }
        }
    }
}

if [catch {open $output_filename w} out_file] {
    puts stderr $out_file
} else {
    set addr 0
    foreach byte $output_buffer {
        incr addr
        binary scan [binary format c $byte] B* bits
        if {[expr {$addr % 2}] != 0} {
            set bitsL $bits
        } else {
            puts $out_file "$bits$bitsL"
        }
    }
    for {set i $addr} {$i < 16383} {set i [expr {$i + 2}]} {
        puts $out_file 0000000000000000
    }
    close $out_file
}
puts "[llength $output_buffer] bytes"
puts {Done.}