-- crim.lua: a library for miniforth.
-- Written by edrx@inx.com.br. Version: 2001dec04. GPL.
-- There's an htmlized version of this file at:
-- <http://angg.twu.net/miniforth/crim.lua>.
-- "Crim" is an idea that I've been cooking since 1995 for a
-- Forth-like language with very compact bytecodes. Crim has a
-- definite inner engine but no decent high-level syntax yet; any
-- "Crim compiler", like this one, is a tool for exploring possible
-- syntaxes.

-- «.heir»		(to "heir")
-- «.newxprimclass»	(to "newxprimclass")
-- «.hprimclass»	(to "hprimclass")
-- «.fprimclass»	(to "fprimclass")
-- «.fipprimclass»	(to "fipprimclass")
-- «.fwordclass»	(to "fwordclass")
-- «.sfprimclass»	(to "sfprimclass")
-- «.declarehprims»	(to "declarehprims")
-- «.declarefprims»	(to "declarefprims")
-- «.standard_primitives»  (to "standard_primitives")
-- «.defineLASTs»	(to "defineLASTs")
-- «.unskeletize»	(to "unskeletize")


asmcode = ""
nasm = function( nbytes, text ) asmcode = asmcode .. text end
dict = dict or {}

nasmify = function( str )
  return gsub(str, "([^0-9A-Za-z_])",
    function (c)
      return format("x%02x", strbyte(c))
    end)
end


--%%%%
--%
--% «heir»  (to ".heir")
--%
--%%%%

heirtag = newtag()
heir = function( table ) settag(table, heirtag); return table end
settagmethod(heirtag, "gettable", function( table, index )
    local a = rawget(table, index); if a then return a end
    local up = rawget(table, "UP"); if up then return up[index] end
  end)
settagmethod(heirtag, "function", function( ... )
    call(arg[1].FUN, arg)
  end)


--%%%%
--%
--% «newxprimclass»  (to ".newxprimclass")
--%
--%%%%

newxprimclass = function( params )
  local xprimclass = {
    prefix = params.prefix,
    def_format  = params.def_format,
    case_format = "case %s: %s\n",
    case_formatter = function( xprim )
        return format("case %s: PRIMp(\"%s\"); %s\n", xprim.aname, xprim.aname, xprim.Ccode)
      end,
    compile_format = params.compile_format,
    nbytes = params.nbytes,
    cdefs_str = "",
    adefs_str = "",
    case_str  = "",
    all  = {},
    used = {},
    firstopcode = params.firstopcode,
    nextopcode  = params.firstopcode,
    step = params.step,
    declare = nil,		-- class method
    define_opcode = nil,	-- class method
    assert_used = nil,		-- instance method
    compile = nil		-- instance method
  }
  xprimclass.declare = function( xprimclass, aname, Ccode )
      local xprim = heir {
        aname = aname,
        compile_str = format(xprimclass.compile_format, aname),
        opcode = nil,
        Ccode = Ccode,
        depends = nil,
        UP  = xprimclass,
        FUN = xprimclass.compile,
      }
      tinsert(xprimclass.all, xprim)
      return xprim
    end
  xprimclass.define_opcode = function( xprimclass, aname )
      local c, opcode = xprimclass, xprimclass.nextopcode
      c.adefs_str =
      c.adefs_str .. format(c.def_format, "%", aname, opcode)
      c.cdefs_str =
      c.cdefs_str .. format(c.def_format, "#", aname, opcode)
    end
  xprimclass.assert_used = function( xprim )
      if xprim.opcode then return end
      local c = xprim.UP
      c.define_opcode(c, xprim.aname)
      xprim.opcode = c.nextopcode
      c.nextopcode = c.nextopcode + c.step
      c.case_str =
      c.case_str .. c.case_formatter(xprim)
      -- c.case_str .. format(c.case_format, xprim.aname, xprim.Ccode)
      tinsert(c.used, xprim)
      if xprim.depends then
        foreachi(xprim.depends, function( i, depend )
            if type(depend)=="string" then
              dict[depend]:assert_used()
            else
              depend:assert_used()
            end
          end)
        end
    end
  xprimclass.compile = function( xprim )
      xprim:assert_used()
      nasm(xprim.nbytes, xprim.compile_str)
    end
  return xprimclass
end


--%%%%
--%
--% «hprimclass»  (to ".hprimclass")
--% «fprimclass»  (to ".fprimclass")
--% «fipprimclass»  (to ".fipprimclass")
--%
--%%%%

hprimclass = newxprimclass {
  prefix = "H_",
  def_format     = "%sdefine %-16s 0x%02X\n",
  compile_format = "\tdb %s\n",
  nbytes = 1,
  firstopcode = 0,
  step = 1,
}
fprimclass = newxprimclass {
  prefix = "F_",
  def_format     = "%sdefine %-16s 0x%04X\n",
  compile_format = "\tdhl %s\n",
  nbytes = 2,
  firstopcode = ((255-10)*256)+255,   -- space for 10 sfprims
  step = -1,
}
fipprimclass = newxprimclass {
  prefix = "FIP_",
  def_format     = "%sdefine %-16s 0x%04X\n",
  compile_format = "\tdhl %s\n",
  nbytes = 1,
  firstopcode = 65535,
  step = -1,
}


--%%%%
--%
--% «fwordclass»  (to ".fwordclass")
--%
--%%%%

fwordclass = {
  compile = function( fword )
      nasm(2, fword.compile_str)
    end,
  declare = nil
}
fwordclass.declare = function( thisclass, wordname )
  local aname = "ADR_" .. nasmify(wordname)
  nasm(0, format("%s:\n", aname))
  local fword = heir {
    compile_str = format("\tdhl %s -_f0\n", aname),
    UP = thisclass,
    FUN = thisclass.compile
  }
  dict[wordname] = fword
end

fwordclass.gdeclare = function( thisclass, wordname )
  local aname = "ADR_" .. nasmify(wordname)
  nasm(0, format("global %s\n", aname))
  thisclass:declare(wordname)
end


--%%%%
--%
--% «sfprimclass»  (to ".sfprimclass")
--% Experimental! Ugly!
--% This supports both adding an sfprim to an existing fprim and
--% creating both at the same time with sfprimclass:declare.
--%
--%%%%

sfprimclass = newxprimclass {
  prefix = "SF_",
  def_format     = "%sdefine %-16s 0x%02X\n",
  compile_format = "\tdb %s\n",
  nbytes = 1,
  firstopcode = 255,
  step = -1,
}
sfprimclass.transltable_str = ""
sfprimclass.assert_used_sfonly = sfprimclass.assert_used
sfprimclass.assert_used = function( sfprim )
  local fprim = sfprim.fprim
  fprim:assert_used()
  if sfprim.opcode == nil then
    sfprim.UP.transltable_str =
    sfprim.UP.transltable_str .. fprim.aname .. ", "
  end
  sfprim:assert_used_sfonly()
end
sfprimclass.declare_sfonly = sfprimclass.declare
sfprimclass.declare = function( sfprimclass, sfaname, Ccode )
  local faname = strsub(2, sfaname)            -- hack; drop the "S" from "SF_"
  local fprim = fprimclass:declare(faname, Ccode)
  local sfprim = sfprimclass:declare_sfonly(sfaname, "??")   -- no case for sfs
  sfprim.fprim = fprim  
  fprim.sfprim = sfprim  
  return sfprim, fprim
end

fprimclass.assert_sfprim_exists = function( fprim )
  if fprim.sfprim then return fprim.sfprim end
  local faname = fprim.aname
  local sfaname = "S"..faname
  local sfprim = sfprimclass:declare_sfonly(sfaname, faname..", ") -- ugh
  sfprim.fprim = fprim  
  fprim.sfprim = sfprim  
  return sfprim, fprim
end


--%%%%
--%
--% «declarehprims»  (to ".declarehprims")
--% «declarefprims»  (to ".declarefprims")
--%
--%%%%

declarexprims_helper = function( pairs, fun )
  local i, words, aname_stem, Ccode
  for i=1,getn(pairs),2 do
    words = split(pairs[i])
    aname_stem = nasmify(words[1])
    Ccode = pairs[i+1]
    fun(words, aname_stem, Ccode)
  end
end

declarehprims = function( ... )		-- ... = words, Ccode, words, Ccode...
  declarexprims_helper(arg, function( words, aname_stem, Ccode )
      local c = hprimclass
      local hprim, j = c:declare(c.prefix..aname_stem, Ccode)
      for j=1,getn(words) do
        dict[c.prefix..words[j]] = hprim
      end
    end)
end
declarefprims = function( ... )		-- ... = words, Ccode, words, Ccode...
  declarexprims_helper(arg, function( words, aname_stem, Ccode )
      local c = fprimclass
      local fprim, j = c:declare(c.prefix .. aname_stem, Ccode)
      for j=1,getn(words) do
        dict[c.prefix..words[j]] = fprim
        dict[words[j]] = fprim
      end
    end)
end
declarefipprims = function( ... )	-- ... = words, Ccode, words, Ccode...
  declarexprims_helper(arg, function( words, aname_stem, Ccode )
      local c = fipprimclass
      local fipprim, j = c:declare(c.prefix .. aname_stem, Ccode)
      for j=1,getn(words) do
        dict[c.prefix..words[j]] = fipprim	-- won't be used
      end
    end)
end

prefer_sf_form = function( wordsasstring )
  foreachi(split(wordsasstring), function( i, word )
      local sfprim, fprim = fprimclass.assert_sfprim_exists(dict["F_"..word])
      dict["SF_"..word] = sfprim
      dict[word] = sfprim
    end)
end


--%%%%
--%
--% «standard_primitives»  (to ".standard_primitives")
--%
--%%%%

declarehprims(
"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;",
"C0    "," fun=*(funptr *)(_f0+RS[0]); DS[1]=(*fun)(); DS++;RS--; goto forth;",
"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;",
"DROPPING"," RS[1]=RS[0]; RS[0]=FIP_FIPDROP; RS++; goto head;"
)

declarefprims(
"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;",
"0         "," DS[1]=0; DS++; goto forth;",
"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;"
)

declarefipprims(
"RETURN  "," RS--; return;",
"RSREXIT "," RS[0]=SS[0]-((int)_f0); SS--; goto forth;",
"FIPDROP "," RS--; DS--; goto forth;"
)

dict["FIP_RETURN"]:assert_used()

dict["H_RSR"].depends = {"FIP_RSREXIT"}

prefer_sf_form("EXIT ; DUP")
dict["EXIT"]:assert_used()


--%%%%
--%
--% «defineLASTs»  (to ".defineLASTs")
--% «unskeletize»  (to ".unskeletize")
--%
--%%%%

-- (find-node "(lua)Patterns" "shortest")

defineLASTs = function()
  hprimclass:define_opcode(hprimclass.prefix .. "LAST")
  fprimclass:define_opcode(fprimclass.prefix .. "LAST")
  sfprimclass:define_opcode(sfprimclass.prefix .. "LAST")
  fipprimclass:define_opcode(fipprimclass.prefix .. "LAST")
end

unskeletize = function(fnamein, fnameout)
  local bigstr = readfile(fnamein)
  bigstr = gsub(bigstr, "<<LUA(.-)LUA>>", dostring)
  writefile(fnameout, bigstr)
  printf("Wrote %s\n", fnameout)
end


-- (find-angg "miniforth/")
-- (find-angg "miniforth/crim/")
-- (find-angg "miniforth/crim/crim.lua")
-- (find-angg "miniforth/crim/demo1.mflua")


comment = [[
# (find-fline "~/flua/")
# (find-fline "~/flua/demo1.bytecode.asm")
# (find-fline "~/flua/demo1.flua")
# (find-fline "~/flua/flua-comp.lua")
# (find-fline "~/flua/flua-demos.lua")
# (find-fline "~/flua/flua-lua.lua")
# (find-fline "~/flua/flua-prims.lua")
# (find-fline "~/flua/flua.lua")
#*
a2ps -=p2iso ~/miniforth/crim.lua
make -f ~/LATEX/Makefile /tmp/o.p01
#*
# (find-fline "~/o")
cd ~/miniforth/
mylua crim.lua |& tee ~/o
#*
# (find-fline "~/o")
cd ~/miniforth/
mylua -f miniforth1.lua crim/demo1.mflua |& tee ~/o
#*
]]