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

# «.variables»		(to "variables")
# «.top_level»		(to "top_level")
# «.run_»		(to "run_")
# «.Xprims_support»	(to "Xprims_support")
# «.Xprims»		(to "Xprims")
# «.building_strings»	(to "building_strings")
# «.file_functions»	(to "file_functions")
# «.test:prims»		(to "test:prims")
# «.test:prototf»	(to "test:prototf")
# «.test:printing»	(to "test:printing")


# «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:
}




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

# «top_level»  (to ".top_level")
# Not really written yet, but the idea is that to run a word (which
# generally means compiling the address corresponding to it) what we
# do is:
#
#   uplevel #0 $word_action($word)

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



#%%%%
#
# 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]
    }
  }
}



#%%%%
#
# 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 function (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
}












#%%%%
#
# Tests, part 1: defining the C primitives
#
#%%%%

# «test:prims»  (to ".test:prims")

SFprims EXIT \; { RS--; goto forth;
  } PLUS + { DS[-1]+=DS[0]; DS--; goto forth;
  } DUP    { DS[1]=DS[0]; DS++; goto forth;
  } 2DUP   { DS[1]=DS[-1]; DS[2]=DS[0]; DS+=2; goto forth;
  } SWAP   { itmp=DS[-1]; DS[-1]=DS[0]; DS[0]=itmp; goto forth;
  } DROP   { DS--; goto forth;
  } SBRANCH   { SS[0]=(int)_f0+*((ushort *)(SS[0])); goto forth;
  } S0BRANCH  { tmp=*((ushort *)(SS[0]))++; if(DS[0]==0) SS[0]=(int)_f0+tmp;
		DS--; goto forth;
  }

Fprims 1    { DS[1]=1; DS++; goto forth;
  } TIMES * { DS[-1]*=DS[0]; DS--; goto forth;
  } COUNT   { DS[1]=*((uchar *)(DS[0]))++; DS++; goto forth;
  } TYPE    { fwrite((void *)(DS[-1]), 1, DS[0], stdout); DS-=2; goto forth;
  } CR      { printf("\n"); goto forth;
  } STO S>  { DS[1]=SS[0]; DS++; SS--; goto forth;
  } TOS >S  { SS[1]=DS[0]; SS++; DS--; goto forth;
  } SGOBBLE1  { DS[1]=*((uchar *)(SS[0]))++; DS++; goto forth;
  } SGOBBLE2  { DS[1]=*((ushort *)(SS[0]))++; DS++; goto forth;
  } WSTORE W! { *((ushort *)(DS[0]))=DS[1]; DS-=2; goto forth;
  } WFETCH W@ { DS[0]=*((ushort *)(DS[0])); goto forth;
  }

FIPprims RETURN { RS--; return;
  } RSREXIT { RS[0]=SS[0]-((int)_f0); SS--; goto forth;
  }

Hprims COL : { goto forth;
  } CON { DS[1]=*(int *)(_f0+RS[0]); DS++; RS--; goto forth;
  } TO  { *(int *)(_f0+RS[0]+1)=DS[0]; DS--; RS--; goto forth;
  } AT  { DS[1]=((int)_f0)+RS[0]+2; DS++; RS--; goto forth;
  } RSR { SS[1]=((int)_f0)+RS[-1]; SS++; RS[-1]=FIP_RSREXIT; goto head;
  } C1  { fun=*(funptr *)(_f0+RS[0]); DS[0]=(*fun)(DS[0]); RS--; goto forth;
  } C2  { fun=*(funptr *)(_f0+RS[0]); DS[-1]=(*fun)(DS[-1], DS[0]);
	    DS--; RS--; goto forth;
  } C3  { fun=*(funptr *)(_f0+RS[0]); DS[-2]=(*fun)(DS[-2], DS[-1], DS[0]);
	    DS-=2; RS--; goto forth;
  }


#%%%%
#
# Tests, part 2: simulating a .tf
#
#%%%%

# «test:prototf»  (to ".test:prototf")
# (find-fline "~/CRIM1/")
# (find-fline "~/CRIM1/demo0a.tf")
# (find-fline "~/CRIM1/demo0a.lst")
# (find-fline "~/CRIM1/tclstuff" "proc getword")

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\""
}

tick 2      ; run CON:                 ; append asm_code "\tdd 2\n"
tick SQUARE ; run    : DUP * \;
tick CUBE   ; run    : DUP SQUARE * \;
                                         append asm_code "global ADR_DEMO\n"
tick DEMO   ; run    : 2 CUBE \;




# «test:printing»  (to ".test:printing")
proc putsvars {args} {
  foreach varname $args {
    puts $varname:
    catch "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
}




set_final_prim_data
# print_vars

# doCfilestuff engine0.skel.c -
# doasmfilestuff -

doCfilestuff engine0.skel.c /tmp/engine.c
doasmfilestuff /tmp/x.asm

# cd /tmp; nasm -f elf -o x.o -l x.lst x.asm; gcc -c -o engine.o engine.c




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