# «.variables»		(to "variables")
# «.variables_print»	(to "variables_print")
# «.building_strings»	(to "building_strings")
# «.file_functions»	(to "file_functions")
# «.top_level»		(to "top_level")
# «.run_»		(to "run_")
# «.Xprims_support»	(to "Xprims_support")
# «.Xprims»		(to "Xprims")



#%%%%
#
# «variables»  (to ".variables")
#
#%%%%

# Lists:
set FIPprims_used {}
set SFprims_used {}
set Fprims_used {}
set Hprims_used {}

# Arrays:
#   word_action
#   prim_code
#   prim_status

# Strings:
set asm_code {}
set asm_defs {}
set C_defs {}
set FIPprims_code {}
set SFprims_code {}
set Fprims_code {}
set Hprims_code {}
set SF_TO_F_code {}

# (find-node "(nasm)Section 5.4" "extern _printf")
# (find-node "(nasm)Section 5.5" "global _main")
# The section is ".data" because we want the crim code read-write.
#
set asm_headers {%macro dwhl 1.nolist
	db (%1) >> 8
	db (%1) & 0xFF
%endmacro
%macro dwhla 1.nolist
	db ((%1)-_f0) >> 8
	db ((%1)-_f0) & 0xFF
%endmacro
SECTION .data
global _f0
_f0:
}



#%%%%
#
# «variables_print»  (to ".variables_print")
#
#%%%%

proc putsvars {args} {
  foreach varname $args {
    puts $varname:
    catch {puts [uplevel #0 set $varname]}
  }
}
proc print_vars {} {
  uplevel #0 {
    catch {parray prim_status}
    catch {parray word_action}
    catch {parray prim_code}
  }
  putsvars FIPprims_used SFprims_used Fprims_used Hprims_used
  # Strings:
  putsvars asm_code asm_defs C_defs
  putsvars FIPprims_code SFprims_code Fprims_code Hprims_code
}



#%%%%
#
# Functions to build strings for the
# "define"s, "switch"s, externs and arrays
#
#%%%%

# «building_strings»  (to ".building_strings")

proc define%02X {word n} {global C_defs asm_defs
  append   C_defs [format  "#define %-16s 0x%02X\n" $word $n]
  append asm_defs [format "%%define %-16s 0x%02X\n" $word $n]
}
proc define%04X {word n} {global C_defs asm_defs
  append   C_defs [format  "#define %-16s 0x%04X\n" $word $n]
  append asm_defs [format "%%define %-16s 0x%04X\n" $word $n]
}

# This function "prepares" the following vars:
# C_defs asm_defs
# H_LAST FIP_LAST SF_LAST F_LAST
# Hprims_code FIPprims_code Fprims_code SF_TO_F_code
#
proc set_final_prim_data {} { uplevel #0 {
  set n [expr 0xFF]
  foreach word $Hprims_used {
    set prim_opcode($word) $n; define%02X $word $n; incr n -1
    append Hprims_code "case $word: $prim_code($word)"
  }
  define%02X H_LAST [expr $n+1]
  
  set n [expr 0xFFFF]
  foreach word $FIPprims_used {
    set prim_opcode($word) $n; define%04X $word $n; incr n -1
    append FIPprims_code "case $word: $prim_code($word)"
  }
  define%02X FIP_LAST [expr $n+1]
  
  set n [expr 0xFF]
  foreach word $SFprims_used {
    set prim_opcode($word) $n; define%02X $word $n; incr n -1
    append SF_TO_F_code "[string range $word 1 end], "
  }
  define%02X SF_LAST [expr $n+1]
  set n [expr ($n<<8)|255]
  foreach word $Fprims_used {
    set prim_opcode($word) $n; define%04X $word $n; incr n -1
    append Fprims_code "case $word: $prim_code($word)"
  }
  define%04X F_LAST [expr $n+1]
}}




#%%%%
#
# File functions (generic, asm-specific and C-specific)
#
#%%%%

# «file_functions»  (to ".file_functions")
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 doasmfilestuff {fnameout} { global asm_headers asm_defs asm_code
  writefile $fnameout $asm_headers$asm_defs$asm_code
}
proc doCfilestuff {fnamein fnameout} {
  set s [readfile $fnamein]
  set tail {}
  while {[regexp {^(.*)/\*-- (.*) --\*/(.*)$} $s -> a b c]} {
    set tail "/*--{ $b }--*/\n  [uplevel #0 $b]$c$tail"
    set s $a
  }
  writefile $fnameout $s$tail
}




#%%%%
#
# top-level functions 
#
#%%%%

# «top_level»  (to ".top_level")

proc run {args} { global word_action
  foreach word $args {
    uplevel #0 $word_action($word)
  }
}

proc tick {word} { global asm_code word_action
  set nasmname [nasmify $word]
  append asm_code "ADR_$nasmname:\n"
  set word_action($word) "append asm_code \"\\tdwhla ADR_$nasmname\\n\""
}



#%%%%
#
# main "run_" functions
# (used for compiling "db"s)
#
#%%%%

# «run_»  (to ".run_")

proc assert_used {listvar word} {global $listvar prim_status
  if {![info exists prim_status($word)] || $prim_status($word)==""} {
    lappend $listvar $word
    set prim_status($word) USED
  }
}

proc run_Hprim {word} {global asm_code
  assert_used Hprims_used $word
  append asm_code "\tdb $word\n"
}
proc run_SFprim {sfword} {global asm_code
  regexp {^S(F_.*)$} $sfword -> fword
  assert_used  Fprims_used $fword
  assert_used SFprims_used $sfword
  append asm_code "\tdb $sfword\n"
}
proc run_Fprim {word} {global asm_code
  assert_used Fprims_used $word
  append asm_code "\tdwhl $word\n"
}
# Every FIPprim declared is treated as used, and there is no db'ing
# for them; so, no run_FIPprim.

proc run_Fadr {word} {global asm_code
  append asm_code "\tdwhla $word\n"
}



#%%%%
#
# Support for the high-level defining functions
#
#%%%%

# «Xprims_support»  (to ".Xprims_support")

proc nasmify {str} {
  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]
    }
  }
  return $nasmstr
}

proc has_space {str} { expr {[string first " " $str]!=-1} }
proc nasm_namep {str} { regexp {^[0-9A-Za-z_]+$} $str }

# A function to reorder lists of arguments in a certain way.
# Args with spaces are considered as the def for the preceding args. 
# Also select the first arg which is a valid nasm name.
# Example:
#   untitled1 {? a b c {1 + 2} * && { hello }}
#          -> {a {? a b c} {1 + 2}
#              {} {* &&} { hello }}
#
proc bigreorder {list} {
  set names {}
  set nasmname {}
  set result {}
  foreach arg $list {
    if {[has_space $arg]} {
      if {$names==""} {
	error "a def was not preceded by any names: [list $arg]"
      }
      lappend result $nasmname $names $arg
      set names {}
      set nasmname {}
    } else {
      if {$nasmname=="" && [nasm_namep $arg]} {
	set nasmname $arg
      }
      lappend names $arg
    }
  }
  if {$names!=""} {
    error "there were names not followed by a def: $names"
  }
  return $result
}

proc bigreorder_nasm {list} {
  set result {}
  foreach {nasmname othernames def} [bigreorder $list] {
    if {$nasmname==""} { set nasmname [nasmify [lindex $othernames 0]] }
    lappend result $nasmname $othernames $def
  }
  return $result
}

# puts [bigreorder {? a b c {1 + 2} * && { hello }}]
# puts [bigreorder {? a b c {1 + 2} * && { hello } quux faz}]
# puts [bigreorder {? a b c {1 + 2} { hello } quux}]




#%%%%
#
# High-level functions to define primitives
#
#%%%%

# «Xprims»  (to ".Xprims")

proc FIPprims {args} { global word_action prim_code
  foreach {nasmname othernames def} [bigreorder_nasm $args] {
    set prim_code(FIP_$nasmname) $def
    assert_used FIPprims_used FIP_$nasmname
  }
}
proc Fprims {args} { global word_action prim_code
  foreach {nasmname othernames def} [bigreorder_nasm $args] {
    set prim_code(F_$nasmname) $def
    foreach word $othernames {
      set word_action($word)   [list run_Fprim F_$nasmname]
      set word_action(F_$word) [list run_Fprim F_$nasmname]
    }
  }
}
proc SFprims {args} { global word_action prim_code
  foreach {nasmname othernames def} [bigreorder_nasm $args] {
    set prim_code(F_$nasmname) $def
    foreach word $othernames {
      set word_action($word)    [list run_SFprim SF_$nasmname]
      set word_action(SF_$word) [list run_SFprim SF_$nasmname]
      set word_action(F_$word)  [list run_Fprim   F_$nasmname]
    }
  }
}
proc Hprims {args} { global word_action prim_code
  foreach {nasmname othernames def} [bigreorder_nasm $args] {
    set prim_code(H_$nasmname) $def
    foreach word $othernames {
      set word_action($word)  [list run_Hprim H_$nasmname]
      set word_action($word:) [list run_Hprim H_$nasmname]
    }
  }
}






#  Local Variables:
#  coding:               no-conversion
#  ee-anchor-format:     "«%s»"
#  ee-charset-indicator: "Ñ"
#  End: