--- flua-comp.lua - compile a flua program into an engine file in C
--- and a bytecode file in Nasm.
--
-- Copyright (C) 2001 Eduardo Ochs.
-- Author:     Eduardo Ochs <edrx@mat.puc-rio.br>
-- Version:    0.02 (2001apr29).
--
-- This program was copylefted to prevent against patent psychopaths;
-- if you want a version with any other license you'll have to write
-- it yourself. More formally,
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of the
-- License, or (at your option) any later version.


-- Flua is an experimental Forth-like language, built on top of Lua, C
-- and Nasm. It is an implementation of the ideas of my (old) "Crim"
-- project.
--
-- Related files:
-- (find-flua "flua.lua")
-- (find-flua "flua-prims.lua")
-- (find-flua "flua-demos.lua")
-- (find-flua "flua-lua.lua")
-- (find-flua "inc.lua")


-- «.nasmnames»			(to "nasmnames")
-- «.xprims_structs»		(to "xprims_structs")
-- «.asm»			(to "asm")
-- «.lbl_glbl_tolbl»		(to "lbl_glbl_tolbl")
-- «.add_xxxprims»		(to "add_xxxprims")
-- «.strings»			(to "strings")
-- «.build_engine_strings»	(to "build_engine_strings")
-- «.skeleton_files»		(to "skeleton_files")
-- «.basic_parsing»		(to "basic_parsing")
--   «.getword»			(to "getword")
--   «.getrestofline»		(to "getrestofline")
--   «.getupto»			(to "getupto")
--   «.f»			(to "f")
--   «.tick»			(to "tick")
--   «.gtick»			(to "gtick")
--   «.dbstuff»			(to "dbstuff")
--   «.cnword»			(to "cnword")
--   «.c1word»			(to "c1word")
-- «.lua_code_in_flua»		(to "lua_code_in_flua")
--   «.getluaargs»		(to "getluaargs")
--   «.immed_lua»		(to "immed_lua")
--   «.word:lua»		(to "word:lua")
--   «.word:nasm»		(to "word:nasm")
--   «.word:dbstuff»		(to "word:dbstuff")
--   «.word:function»		(to "word:function")
-- «.tmplabels»			(to "tmplabels")
--   «.word:lbl:»		(to "word:lbl:")
--   «.word:tolbl»		(to "word:tolbl")
--   «.word:if»			(to "word:if")
--   «.word:then»		(to "word:then")
--   «.word:else»		(to "word:else")



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

function nasmify(str)
  return gsub(str, "([^0-9A-Za-z_])",
    function (c)
      return format("x%02x", strbyte(c))
    end)
end
function names2cname(arr)
  if getn(arr) == 0 then print("Tried to cname an empty array") end
  local cname = {}
  foreachi(arr,
    function(_, name)
      if not strfind(name, "[^0-9A-Za-z_]") then %cname[1] = name end
    end)
  return cname[1] or nasmify(arr[1])
end

-- px(names2cname(split("TIMES *")))
-- px(names2cname(split("/ *")))



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

-- We define this separately because SFprims uses it in a weird way.
function basic_assert_used(xprims, cname)
  if not xprims.cname2usedp[cname] then
    xprims.cname2usedp[cname] = "used"
    tinsert(xprims.cnames_used, cname)
    xprims.cname2n[cname] = getn(xprims.cnames_used)
  end
end

function new_xprims_struct(opcode_first, opcode_step, use_all)
  local xprims = {}
  xprims.cnames = {}
  xprims.cname2code = {}
  xprims.cname2usedp = {}
  xprims.cnames_used = {}
  xprims.use_all = use_all
  xprims.assert_used = basic_assert_used
  xprims.add_cname_code = function(self, cname, code)
    if not self.cname2code[cname] then
      tinsert(self.cnames, cname)
    end
    self.cname2code[cname] = code
    if self.use_all then self:assert_used(cname) end
  end
  xprims.cname2n = {}
  xprims.n = function(self) return getn(self.cnames_used) end
  xprims.opcode_first = opcode_first
  xprims.opcode_step = opcode_step
  xprims.opcode = function(self, cname)
    if not self.cname2n[cname] then printf("No opcode for %s\n", cname) end
    return self.opcode_first + (self.cname2n[cname] - 1) * self.opcode_step
  end
  xprims.opcode_last = function(self)
    return self.opcode_first + (self:n() - 1) * self.opcode_step
  end
  xprims.forall_used = function(self, f)
    foreachi(self.cnames_used, function (i, cname)
        %f(cname, %self.cname2code[cname], %self.cname2n[cname])
      end)
  end
  return xprims
end

  Hprims = new_xprims_struct(0, 1)
FIPprims = new_xprims_struct(65535, -1, "use_all")
  Fprims = new_xprims_struct(4095, -1)     -- the "4096" will be adjusted later
 SFprims = new_xprims_struct(255, -1)      -- and also some fields of SFprims

function SFprims:assert_used(SFcname)
  Fprims:assert_used(strsub(SFcname, 2))   -- use the "F_xxx" from the "SF_xxx"
  basic_assert_used(SFprims, SFcname)
end

action = {}



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

function nasm(nbytes, ...)
  strings.nasmbytecode = strings.nasmbytecode .. call(format, arg)
  -- call(printf, arg)
end

function db_prim(symbol)
  nasm(1, "\tdb %s\n", symbol)
end
function dhl_prim(symbol)
  nasm(2, "\tdhl %s\n", symbol)
end
function db_forth(symbol)
  nasm(2, "\tdhl %s\n", symbol)
end

-- «lbl_glbl_tolbl»  (to ".lbl_glbl_tolbl")
function lbl(labelname)
  nasm(0, "%s:\n", labelname)
end
function glbl(labelname)
  nasm(0, "    global %s\n", labelname)
  nasm(0, "%s:\n", labelname)
end
function tolbl(labelname)
  nasm(2, format("\tdw %s -_f0\n", labelname))
end




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

function foreach2(arr, f)
  local i=1
  while i<=getn(arr) do
    f(arr[i], arr[i+1])
    i=i+2
  end
end

function add_Hprims(...)
  foreach2(arg, function(names_str, code)
    local cname = "H_"..names2cname(split(names_str))
    Hprims:add_cname_code(cname, code)
    foreachi(split(names_str), function(i, name)
      local cname = %cname
      action[name] = function ()
        Hprims:assert_used(%cname)
	db_prim(%cname)
      end
      action["H_"..name] = action[name]
      action[name..":"] = action[name]
    end)
  end)
end

Fprims.name2cname = {}

function add_Fprims(...)
  foreach2(arg, function(names_str, code)
    local cname = "F_"..names2cname(split(names_str))
    Fprims:add_cname_code(cname, code)
    foreachi(split(names_str), function(i, name)
      local cname = %cname
      Fprims.name2cname[name] = cname
      action[name] = function ()
          Fprims:assert_used(%cname)
	  dhl_prim(%cname)
        end
      action["F_"..name] = action[name]
    end)
  end)
end

function add_FIPprims(...)
  foreach2(arg, function(names_str, code)
    local cname = "FIP_"..names2cname(split(names_str))
    FIPprims:add_cname_code(cname, code)
  end)
end


function add_SFprims(names_str, mark_as_used)
  foreachi(split(names_str),
    function(i, name)
      local Fcname = Fprims.name2cname[name]
      local SFcname = "S"..Fcname
      SFprims:add_cname_code(SFcname, Fcname)   -- too skeletal?
      if %mark_as_used then SFprims:assert_used(SFcname) end
      action[name] =
	function ()
          SFprims:assert_used(%SFcname)
	  db_prim(%SFcname)
        end
      action["SF_"..name] = action[name]
    end)
end




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

strings = {}
strings.nasmbytecode = ""
strings.Cextras1=""

-- «build_engine_strings»  (to ".build_engine_strings")
function build_engine_strings()
  strings.Hprims=""
  strings.Fprims=""
  strings.SFprims=""
  strings.FIPprims=""
  strings.Cdefs=""
  strings.Cdefs_LAST=""
  Hprims:forall_used(function (cname, code, n)
    strings.Hprims = strings.Hprims .. format("case %s: %s\n", cname, code)
    strings.Cdefs = strings.Cdefs ..
      format("#define %-16s 0x%02X\n", cname, Hprims:opcode(cname))
  end)
  FIPprims:forall_used(function (cname, code, n)
    strings.FIPprims = strings.FIPprims .. format("case %s: %s\n", cname, code)
    strings.Cdefs = strings.Cdefs ..
      format("#define %-16s 0x%02X\n", cname, FIPprims:opcode(cname))
  end)
  SFprims:forall_used(function (cname, code, n)
    --strings.SFprims = strings.SFprims .. format("(SF) %s: %s\n", cname, code)
    strings.SFprims = strings.SFprims .. format("%s, ", code)
    strings.Cdefs = strings.Cdefs ..
      format("#define %-16s 0x%02X\n", cname, SFprims:opcode(cname))
  end)
  Fprims.opcode_first = SFprims:opcode_last() * 256 - 1
  Fprims:forall_used(function (cname, code, n)
    strings.Fprims = strings.Fprims .. format("case %s: %s\n", cname, code)
    strings.Cdefs = strings.Cdefs ..
      format("#define %-16s 0x%04X\n", cname, Fprims:opcode(cname))
  end)
  strings.Cdefs_LAST =
    format("#define %-16s 0x%02X\n",   "H_LAST",   Hprims:opcode_last()) ..
    format("#define %-16s 0x%04X\n", "FIP_LAST", FIPprims:opcode_last()) ..
    format("#define %-16s 0x%02X\n",  "SF_LAST",  SFprims:opcode_last()) ..
    format("#define %-16s 0x%04X\n",   "F_LAST",   Fprims:opcode_last())
end

-- dump_engine_strings(): for debugging.
function dump_engine_strings()
  printf("\n/* Cdefs: */\n%s",        strings.Cdefs)
  printf("\n/* Cdefs_LAST: */\n%s",   strings.Cdefs_LAST)
  printf("\n/* Cextras1: */\n%s",     strings.Cextras1)
  printf("\n/* Hprims: */\n%s",       strings.Hprims)
  printf("\n/* FIPprims: */\n%s",     strings.FIPprims)
  printf("\n/* Fprims: */\n%s",       strings.Fprims)
  printf("\n/* SFprims: */\n%s",      strings.SFprims)
  printf("\n/* nasmbytecode: */\n%s", strings.nasmbytecode)
-- print(strings.nasmbytecode)
end



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

function process_skeleton(skelstr, delim1, delim2, f)
  local rest, result = skelstr, ""
  local pre, d1, post, mid, d2
  while 1 do
    pre, d1, post = split_at_first(rest, delim1)
    if not post then break end
    mid, d2, rest = split_at_first(post, delim2)
    -- result = result .. pre .. "/* [lua" .. mid .. "lua] */" .. dostring(mid)
    result = result .. pre .. f(mid)
  end
  return result .. rest
end

function process_C_skeleton(fnamein, fnameout)
  local str = process_skeleton(readfile(fnamein),
    "/**[lua", "lua]**/",
    function (mid)
      return "/*[lua" .. mid .. "lua]*/" .. dostring(mid)
    end)
  if fnameout then writefile(fnameout, str) end
  return str
end
function process_nasm_skeleton(fnamein, fnameout)
  local str = process_skeleton(readfile(fnamein), "\n;;; lua:", "\n",
    function (mid)
      return "\n;; lua:" .. mid .. "\n" .. dostring(mid)
    end)
  if fnameout then writefile(fnameout, str) end
  return str
end




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

rest = ""
word = ""
restofline = ""

-- «getword»  (to ".getword")
function getword()
  local _, tmprest
  _, _, word, tmprest = strfind(rest, "^%s*([^%s]+)(.*)")
  if word then
    if DBG then
      printf("getword: %q\n", word)
    end
    rest = tmprest
    return word
  end
end

-- «getrestofline»  (to ".getrestofline")
function getrestofline()
  local _
  restofline, _, rest = split_at_first(rest, "\n", rest, "", "")
  return restofline
end

-- «getupto»  (to ".getupto")
function getupto(delim, canthave)
  local _, inner, tmprest
  inner, delim, tmprest = split_at_first(rest, delim)
  if not inner then
    printf("getupto(%q, %q), when rest = %q: no closing delim!\n",
           delim, canthave, rest)
  end
  if canthave and strfind(inner, canthave) then
    printf("getupto(%q, %q), when rest = %q: captured too much!\n",
           delim, canthave, rest)
  end
  if DBG then printf("getupto: inner=%q, delim=%q\n", inner, delim) end
  rest = tmprest
  return inner
end

-- «f»  (to ".f")
function f(str)
  local oldrest = rest
  rest = str
  while getword() do
    action[word]()
  end
  rest = oldrest
end




-- «tick»  (to ".tick")
function tick(name)
  local nasmname = "ADR_" .. nasmify(name)
  lbl(nasmname)
  action[name] = function () db_forth(%nasmname .. " -_f0") end
end

-- «gtick»  (to ".gtick")
function gtick(name)
  local nasmname = "ADR_" .. nasmify(name)
  glbl(nasmname)
  action[name] = function () db_forth(%nasmname .. " -_f0") end
end

-- «dbstuff»  (to ".dbstuff")
function dbstuff(...)
  local dbs, len = {}, 0
  local i, obj, rest, _, str, c
  for i = 1, getn(arg) do
    obj = arg[i]
    if type(obj) == "string" then
      rest = obj
      while rest ~= "" do
        _, _, str, c, rest = strfind(rest, "^([ -&(-~]*)(.?)(.*)")
        if str ~= "" then
          tinsert(dbs, "'" .. str .. "'")
          len = len + strlen(str)
        end
        if c ~= "" then
          tinsert(dbs, strbyte(c))
          len = len + 1
        end
      end
    elseif type(obj) == "number" then
      tinsert(dbs, obj)
      len = len + 1
    else
      error("weird type for db!")
    end
  end
  nasm(len, format("\tdb %s\n", join(dbs, ",")))
end

-- «cnword»  (to ".cnword")
function cnword(wordname, heads, cname)
  cname = cname or wordname
  tick(wordname)
  f(heads)
  nasm(4, format("    extern %s\n\tdd %s\n", cname, cname))
end

-- «c1word»  (to ".c1word")
function c1word(name, cname)
  cnword(name, "C1:", cname)
end




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

-- «word:lua»  (to ".word:lua")
-- The "lua" word implements a way (the simplest possible, I think) to
-- execute lua code from Flua; for example, in Flua,
--
--   lua <luacode> end;
--
-- executes dostring(<luacode>>) immediately. Newlines are allowed in
-- <luacode>.
--
action["lua"] = function() dostring(getupto("end;")) end


-- «getluaargs»  (to ".getluaargs")
function getluaargs()
  return getupto(");", "\n")
end

-- «immed_lua»  (to ".immed_lua")
function immed_lua(str)
  foreachi(split(str), function (i, funname)
      action[funname.."("] = function()
          dostring(%funname.."("..getluaargs()..")")
        end
    end)
end

-- «word:nasm»  (to ".word:nasm")
-- «word:dbstuff»  (to ".word:dbstuff")
immed_lua("nasm dbstuff")

-- immed_lua implements a simple way to call Lua functions from Flua
-- code... An example: running immed_lua("nasm dbstuff") is equivalent
-- to running:
--
--  action["nasm("]    = function() dostring("nasm("..getluaargs()..")") end
--  action["dbstuff("] = function() dostring("dbstuff("..getluaargs()..")") end
--
-- and after that things like the following Flua block will work
-- (i.e., making "f" run that block will add a definition for the word
-- "2" to the nasm bytecode; a stack diagram for "2" is at the right):
--
--   % 2 CON: nasm( 4, "\tdd 2\n");   -- 2 ( -- 2 )
--
-- Note that the word "nasm(" is executed "immediately" (in the Forth
-- sense of "immediate"!), by Lua; action["nasm("]() will call
-- getluaargs() to parse everything up to the ");", and then execute
-- 'nasm(4, "\tdd 2\n")' with dostring.



-- «word:function»  (to ".word:function")
action["function"] = function()
    local funname = getword()
    local body = getupto("end;")
    -- We define the function <funname> (callable from Lua):
    dostring(format("function %s %s end", funname, body))
    -- Now we define the word "funname(", that calls the function <funname>.
    action[funname.."("] = function()
        dostring(%funname.."("..getluaargs()..")")
      end
  end

-- The word "function" provides a way to actually define Lua (and
-- Flua!) functions from inside Flua code. A slightly artificial
-- example: in this block of flua code
--
--   function printf (...) write(call(format, arg)) end;
--   printf( "%s: %q\n", "rest", rest);
--
-- the first line will work exactly as
--
--   function printf (...) write(call(format, arg)) end
--   action["printf("] = function()
--     dostring("printf("..getluaargs()..")")
--   end
--
-- redefining the "printf" function of inc.lua, and the second line
-- will execute immediately (in the Forth sense)
--
--   printf("%s: %q\n", "rest", rest)
--
-- as the "getluaargs()" will have returned [["%s: %q\n", "rest", rest]].
--
-- Note that in action["function"] "getupto" is called without the
-- "canthave" argument; a call to "function" allows newlines before
-- the "end;", while an invocation of a word created with immed_lua
-- will complain if a newline is found before the ");".





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

function d2n(stack, depth)		-- convert depth to n (top is depth=1)
  return getn(stack)-((depth or 1)-1)	-- to do: check bounds
end

function newstack()
  local stack = {}
  local s_push, s_pop, s_pick, s_pock, s_pluck
  s_push  = function (value) tinsert(%stack, value) end
-- s_pop is currently a copy of s_pluck
  s_pick  = function (depth) return %stack[d2n(%stack, depth)] end
  s_pock  = function (depth, value) %stack[d2n(%stack, depth)] = value end
  s_pluck = function (depth) return tremove(%stack, d2n(%stack, depth)) end
-- return stack, s_push, s_pop, s_pick, s_pock, s_pluck
  return stack, s_push, s_pluck, s_pick, s_pock, s_pluck
end

-- (find-node "(lua)tremove")
-- (find-node "(lua)tinsert")

ntmplabels = 0
tmplabelstack,
  tmplabelpush,
  tmplabelpop = newstack()

function tmplabelname(str)
  local labelname, _
  if str == ">" then			-- push a new tmplabel on the stack
    ntmplabels = ntmplabels + 1
    labelname = "LBL_"..ntmplabels
    tmplabelpush(labelname)
    return labelname
  else
    _, _, n = strfind(str, "^<([0-9]*)$")
    if n then				-- pop some tmplabel from the stack
      return tmplabelpop(tonumber(n))
    end
  end
  return "LBL_"..nasmify(str)
end
function gettmplabelname()
  return tmplabelname(getword())
end

-- «word:lbl:»  (to ".word:lbl:")
-- «word:tolbl»  (to ".word:tolbl")
action["lbl:"] = function() lbl(gettmplabelname()) end
action["tolbl"] = function() tolbl(gettmplabelname()) end

-- «word:if»  (to ".word:if")
-- «word:then»  (to ".word:then")
-- «word:else»  (to ".word:else")

-- «words:if_then_else»  (to ".words:if_then_else")
-- (find-flua "flua-demos.lua" "flua_demo4")
--
-- Some standard Forth control words. Note that we are not defining
-- 0BRANCH and BRANCH now; the "user" will have to define them as Flua
-- words, primitive or not -- and will have to follow the conventions
-- of lbl and tolbl: the destination is stored as dw labelname-_f0.
--
action["if"]   = function() f("0BRANCH tolbl >") end
action["else"] = function() f(" BRANCH tolbl > lbl: <2") end
action["then"] = function() f("lbl: <") end





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