#!/usr/bin/tclsh
# (find-es "anatocc" "nasm_crim1")
# (find-fline "~/CRIM1/tclstuff")

set c_lines {}
set sf_to_f {}
set sf_to_adr {}
set h_last   [expr 0xFF   + 1]	;# head primitives
set fip_last [expr 0xFFFF + 1]	;# forth ip primitives
set sf_last  [expr 0xFF   + 1]	;# short forth words, primitives or not
set lsf_last [expr 0xFFFF + 1]	;# short forth primitives - long form
set f_last   [expr 0xE5FF + 1]	;# forth primitives without short forms
set engine {}			;# C file to append to the generated C defs


# A control structure to let me avoid some "catch" juggling.
# You are not expected to understand this - it's a huge overkill.
# The details are in section 9.4 of Ousterhout's book.
# (find-fline "~/tmp/tclbook.p1.txt" "3 The break command was invoked.")
# (eev "gv -page 91 $S/http/www.cica.indiana.edu/cica/faq/tcl/book.p1.ps" nil)
#
proc if_ok {code_cond code_ok code_err} {
  global errorInfo errorCode
  if {[catch {uplevel 1 $code_cond}]} {
    set code $code_err
  } else {
    set code $code_ok
  }
  set r {}
  set c [catch {uplevel 1 $code} r]
  switch $c {
    0 {return $r}
    1 {return -code error -errorinfo $errorInfo \
	      -errorcode $errorCode $r}
    2 {return -code return $r}
    3 {return -code break}
    4 {return -code continue}
  }
}


# Functions for global arrays
#
proc arrset {arrname key val} {
  upvar #0 $arrname arr
  set arr($key) $val
  return $val
}
proc in {arrname key} {
  upvar #0 $arrname arr
  return $arr($key)
  # will fail if $arr() doesn't have that entry
}


# A function to convert Crim words to words that C and Nasm can use
#
proc nasmify {str} {
  if_ok {set nasmstr [in nasmnames $str]} {
    return $nasmstr
  } {
    if {$str==""} { error "Tried to nasmify the null string" }
    set re {[A-Za-z]}
    set nasmstr {}
    foreach c [split $str {}] {
      if {[regexp {[0-9A-Za-z_]} $c]} {
	append nasmstr $c
      } else {
	scan $c "%c" ord
	append nasmstr [format "x%02x" $ord]
      }
    }
    arrset nasmnames $str $nasmstr
    return $nasmstr
    # e.g. S<."> -> Sx3Cx2Ex22x3E
  }
}


# File stuff, def stuff
#
proc readfile {fname} { exec cat $fname }
proc writefile {fname str} {
  if {$fname=="-"} { puts -nonewline $str; return }
  set ch [open $fname w]; puts -nonewline $ch $str; close $ch
}
proc asm_now {args} { foreach li $args { puts $li } }
proc c_now {args} { global c_lines; eval lappend c_lines $args }
proc d_def {w def} { arrset d_defs $w $def }


# Headers of the asm file
#
# (find-node "(nasm)Section 5.4" "extern _printf")
# (find-node "(nasm)Section 5.5" "global _main")
proc asm_label {symbol {isglobal {}}} {
  global  asm_labels
  if {$isglobal!=""} {
    lappend asm_labels $symbol
    asm_now "global $symbol"
  }
  asm_now "$symbol:"
}
asm_now "%macro d2 1.nolist"
asm_now "\tdb (%1) >> 8"
asm_now "\tdb (%1) & 0xFF"
asm_now "%endmacro"
asm_now "%macro d2a 1.nolist"
asm_now "\tdb ((%1)-_f0) >> 8"
asm_now "\tdb ((%1)-_f0) & 0xFF"
asm_now "%endmacro"
asm_now "SECTION .data"	;# don't make the crim code read-only
asm_label "_f0" global


# Some immediate words: asm, tcl, #, ', '', syns, nasmnames
#
arrset action "#" {getrest}
arrset action "tcl" {uplevel #0 [getrest]}
arrset action "asm" {puts [getrest]}
arrset action "'"  {tick [getword]}
proc tick {w {isglobal {}}} {
  set w0 [nasmify $w]
  if {$w!=$w0} {
    asm_now "; $w = $w0"
  }
  asm_label "ADR_$w0" $isglobal
  d_def "F_$w" "\td2a ADR_$w0"
  d_def "$w"   "\td2a ADR_$w0"
  return $w0
}
arrset action "g'" {tick [getword] 1}
arrset action "syns" {eval syns [getwords]}
proc syns {args} {
  foreach {old new} $args {
    catch {arrset action $new [in action $old]}
    catch {arrset d_defs $new [in d_defs $old]}
  }
}
arrset action "nasmnames" {
  foreach {crim nasm} [getwords] { arrset nasmnames $crim $nasm }
}


# Engine-related immediate words: Hprims, Fprims, SFprims, FIPprims
#
proc casm_def {formatstr symbol varname} {
  upvar #0 $varname v
  incr v -1
  c_now   [format  "#$formatstr" $symbol $v]
  asm_now [format "%%$formatstr" $symbol $v]
}
proc new_Hprim   {w} { casm_def "define %-16s 0x%02X" H_$w   h_last   }
proc new_Fprim   {w} { casm_def "define %-16s 0x%04X" F_$w   f_last   }
proc new_SFprim  {w} { casm_def "define %-16s 0x%02X" SF_$w  sf_last  }
proc new_FIPprim {w} { casm_def "define %-16s 0x%04X" FIP_$w fip_last }
arrset action "Hprims" {
  foreach w [getwords] {
    new_Hprim $w
    d_def H_$w  "\tdb H_$w"
    d_def   $w: "\tdb H_$w"
  }
}
arrset action "Fprims" {
  foreach w [getwords] {
    new_Fprim $w
    d_def F_$w "\td2 F_$w"
    d_def   $w "\td2 F_$w"
  }
}
arrset action "SFprims" {
  global sf_to_f
  foreach w [getwords] {
    new_SFprim $w
    new_Fprim $w
    d_def  F_$w "\td2 F_$w"
    d_def SF_$w "\tdb SF_$w"
    d_def    $w "\tdb SF_$w"
    lappend sf_to_f F_$w
  }
}
arrset action "FIPprims" {
  foreach w [getwords] {
    new_FIPprim $w
  }
}


# An immediate word that works as "'" and "SFprim" at the same time
#
arrset action "''" {sf_tick [getword]}
proc sf_tick {w} {
  global sf_to_f sf_to_adr
  set w0 [tick $w global]
  new_SFprim $w0
  d_def $w "\tdb SF_$w0"	;# the short form becomes the default
  lappend sf_to_f   "1"
  lappend sf_to_adr "ADR_$w0"
}


# The two main parsing functions
#
proc getword {} {
  global rest line
  if {[regexp "^\[ \t\]*(\[^ \t\]+)(.*)\$" $rest -> word rest]} {
    return $word
  }
  error "Premature EOL, line=[list $line]"
}
proc getline {} {
  global nlinenow lines rest
  if {$nlinenow>=[llength $lines]} {
    error "Premature EOF"
  }
  set rest [lindex $lines $nlinenow]
  incr nlinenow
  return $rest
  # e.g., $nlinenow==2 means that $rest is a part of the 2nd line of input
}


# Extra parsing functions
#
proc getrest {} { global rest; set tmp $rest; set rest ""; return $tmp }
proc getwords {} {
  set words {}
  catch {while 1 {lappend words [getword]}}
  return $words
}


# Basic word handlers: immediate and compilable words
#
set wordhandlers {}
proc addhandler {test code} {
  global wordhandlers
  lappend wordhandlers $test "$code\nbreak"
}
addhandler {[info exists action($word)]} { eval $action($word) }
addhandler {[info exists d_defs($word)]} { asm_now $d_defs($word) }
set unhandleableword {1 {error "uninterpretable word: $word"}}


# Other word handlers: gotos
#
proc addhandler_re {re vars code} {
  addhandler [format {[regexp %s $word -> %s]} [list $re] $vars] $code
}
addhandler_re {^->([0-9A-Za-z_]+):$} {label} { asm_now "LBL_$label:" }
addhandler_re {^->([0-9A-Za-z_]+)$} {label} { asm_now "\tdw LBL_$label-_f0" }


# Main loop
#
set nlinenow 0
set lines [split [readfile [lindex $argv 0].tf] "\n"]
while 1 {
  if_ok {getline} {
    while 1 {
      if_ok {set word [getword]} {
        foreach {wtest wdo} [concat $wordhandlers $unhandleableword] {
          if $wtest $wdo
        }
      } {
        break
      }
    }
  } {
    break
  }
}


# Prepare and output the xxx.engine.c file
#
c_now [format "#define H_LAST          0x%02X" $h_last]
c_now [format "#define F_LAST          0x%04X" $f_last]
c_now [format "#define SF_LAST         0x%02X" $sf_last]
c_now [format "#define FIP_LAST        0x%04X" $fip_last]
c_now "typedef unsigned char ucptr\[\];"
c_now "extern ucptr [join $asm_labels ", "];"
c_now "#define adr2i(symbol) ((int)(symbol)-(int)_f0)"
c_now "unsigned short SF_TO_F\[\] =\n  {[join $sf_to_f ", "], /* end: */ 0};"
c_now "void *SF_TO_ADR\[\] =\n  {[join $sf_to_adr ", "]};"
if {$engine!=""} {
  c_now "" "/* Now the engine C code taken from $engine: */" ""
  c_now [readfile $engine]
  writefile [lindex $argv 0].engine.c "[join $c_lines "\n"]\n"
}