-- The kernel of LForth: an inner interpreter, plus an outer
-- interpreter implemented as a set of new states for the inner one.

-- The inner interpreter - minimal, but very extensible.
-- The data stack and the return stack:
--   «.ds»				(to "ds")
--   «.rs»				(to "rs")
-- The "memory", implemented as a Lua array:
--   «.mem»				(to "mem")
-- Functions to add primitives and Forth words to the `forths' dictionary:
--   «.prim»				(to "prim")
--   «.compile»				(to "compile")
-- Dictionaries for the inner interpreter: heads and forths.
--   «.heads»				(to "heads")
--   «.forths»				(to "forths")
-- The "inner" states of the inner interpreter.
--   «.states.head»			(to "states.head")
--   «.states.forth»			(to "states.forth")
--   «.states.forthret»			(to "states.forthret")
-- The inner interpreter loop.
--   «.innerloop»			(to "innerloop")
-- The standard way to invoke Forth functions or primitives... the
-- tricky part is that the loop of the inner interpreter must stop
-- looping when everything is done.
--   «.invoke»				(to "invoke")

-- An extension to the inner interpreter: support for RSR words.
--   «.ss»				(to "ss")
--   «.RSR»				(to "RSR")
--   «.rsrprim»				(to "rsrprim")


-- The outer interpreter.
-- The basic parsing functions, and the array on which they operate.
--   «.p»				(to "p")
--   «.p.parseluare»			(to "p.parseluare")
--   «.getword»				(to "getword")
--   «.getuntilluare»			(to "getuntilluare")
-- The outer interpreter is implemented as two new states for the
-- inner interpreter.
--   «.states.outer_interpreter»	(to "states.outer_interpreter")
--   «.states.outer_compiler»		(to "states.outer_compiler")
-- The outer interpreter's dictionaries:
-- Words common to both the interpreter mode and the compiler mode,
--   «.dict»				(to "dict")
-- Words specific to interpreter mode,
--   «.dict_interpreter»		(to "dict_interpreter")
-- Words specific to compiler mode.
--   «.dict_compiler»			(to "dict_compiler")
-- The standard way to invoke the outer interpreter on a piece of
-- text, kind of like what `invoke' does for bytecodes.
--   «.interpret»			(to "interpret")

-- (find-angg "LFORTH/outer.lua")
-- (find-angg "LFORTH/README")


-- «ds»  (to ".ds")
ds = {}
dspush = function (v) table.insert(ds, 1, v); return v end
dspop  = function () return table.remove(ds, 1) end
-- «rs»  (to ".rs")
rs = {}
rspush = function (v) table.insert(rs, 1, v); return v end
rspop  = function () return table.remove(rs, 1) end
-- «mem»  (to ".mem")
mem = {}
mem.here = 0
mem.compile = function (...)
    for i = 1,table.getn(arg) do
      mem[mem.here] = arg[i]
      mem.here = mem.here + 1
    end
  end
-- «prim»  (to ".prim")
prim = function (name, fun) forths[name] = fun end
-- «compile»  (to ".compile")
compile = function (name, ...)
    forths[name] = mem.here
    mem.compile(unpack(arg))
  end

-- «heads»  (to ".heads")
heads = {}
heads["h_forth"] = function ()
    state = states.forth
  end
-- «forths»  (to ".forths")
forths = {}
forths["exit"] = function ()
    ip = rspop(); state = states.forthret
  end

-- «states»  (to ".states")
-- «states.head»  (to ".states.head")
states = {}
states.head = function ()
    local instr = mem[ip]; ip = ip+1; 
    heads[instr]()
  end
-- «states.forth»  (to ".states.forth")
states.forth = function ()
    local v = mem[ip]; ip = ip+1
    if type(v)=="string"   then v = forths[v] end
    if type(v)=="function" then v(); return end
    if type(v)=="number"   then
      rspush(ip)
      ip = v
      state = states.head
      return
    end
    error()
  end
-- «states.forthret»  (to ".states.forthret")
states.forthret = function ()
    if type(ip)=="number" then state = states.forth; return end
    if type(ip)=="function" then ip(); return end
    PP("forthret error: ip=", ip)
    error()
  end

-- «innerloop»  (to ".innerloop")
innerloop = function ()
    while state do
      if DBG then P(ip, mem[ip]) end
      state()
    end
  end
-- «invoke»  (to ".invoke")
invoke = function (f)
    if type(f)=="string" then f = forths[f] end
    if type(f)=="function" then f(); return end
    if type(f)=="number" then
      local oldstate, oldip = state, ip
      rspush(function () state = nil end)
      ip = f
      state = states.head
      innerloop()
      ip = oldip
      state = oldstate
      return
    end
    error()
  end
invoke_ = function (f, stateafter)
    if type(f)=="string" then f = forths[f] end
    if type(f)=="function" then f(); return end
    if type(f)=="number" then
      rspush(function () state = stateafter end)
      ip = f
      state = states.head
      return
    end
    error()
  end



-- «ss»  (to ".ss")
ss = {}
sspush = function (v) table.insert(ss, 1, v); return v end
sspop  = function () return table.remove(ss, 1) end
-- «RSR»  (to ".RSR")
heads["h_rsr"] = function ()
    sspush(rspop())
    rspush(function () ip = sspop() end)
  end
-- «rsrprim»  (to ".rsrprim")
rsrprim = function (rname, sname, fun)
    prim(sname, fun)
    compile(rname, "h_rsr", "h_forth", sname, "exit")
  end


-- Tests for the inner interpreter:
-- (find-angg "LFORTH/README" "kernel-innertest1")
-- (find-angg "LFORTH/README" "kernel-innertestrsr")




-- «p»  (to ".p")
p = {}
p.pos = 0
-- p.text = ??
-- «p.parseluare»  (to ".p.parseluare")
p.parseluare = function (errfunction, luare)
    local arr = pack(string.find(p.text, luare, p.pos+1))
    if arr[1] == nil then return errfunction(luare) end
    local startre = table.remove(arr, 1)
    local endre   = table.remove(arr, 1)
    if DBG then
      P(p.pos, luare, startre-p.pos-1, endre-startre+1, unpack(arr))
    end
    return startre-p.pos-1, endre-startre+1, unpack(arr)
  end
-- «getword»  (to ".getword")
getword = function ()
  local _, nspaces = p.parseluare(nil, "^[ \t]*")
  p.pos = p.pos + nspaces
  local __, dpos, word = p.parseluare(nil, "^([^ \t\n]*)")
  if dpos == 0 then _, dpos, word = p.parseluare(nil, "^(\n?)") end
  p.pos = p.pos + dpos
  return word
end
-- «getuntilluare»  (to ".getuntilluare")
getuntilluare = function (errfunction, luare)
  local arr = pack(p.parseluare(errfunction, luare))
  local _, len = table.remove(arr, 1), table.remove(arr, 1)
  p.pos = p.pos+_+len
  return unpack(arr)
end

-- «states.outer_interpreter»  (to ".states.outer_interpreter")
states.outer_interpreter = function ()
    word = getword()
    local immed = dict_interpreter[word] or dict[word] or forths[word]
    if immed then invoke_(immed, states.outer_interpreter); return end
    local n = tonumber(word)
    if n then dspush(n); return end
    unkown(word)
  end
-- «states.outer_compiler»  (to ".states.outer_compiler")
states.outer_compiler = function ()
    word = getword()
    local immed = dict_compiler[word] or dict[word]
    if immed then invoke_(immed, states.outer_compiler); return end
    if forths[word] then mem.compile(word); return end
    local n = tonumber(word)
    if n then mem.compile("lit", n); return end
    unkown(word)
  end

-- «dict»  (to ".dict")
dict = {}
dict[""] = function () ip = rspop(); state = states.forthret end	-- EOF
dict["\n"] = function () end			-- just skip the newline
dict["[lua"] = function ()
    assert(loadstring(getuntilluare(nil, "^(.-)lua%]")))()
  end
-- «dict_interpreter»  (to ".dict_interpreter")
dict_interpreter = {}
dict_interpreter[":lua"] = function ()
    local word, code = getword(), getuntilluare(nil, "^(.-)lua;")
    forths[word] = assert(loadstring(code))
  end
dict_interpreter[":"] = function ()
    compile(getword(), "h_forth")
    state = states.outer_compiler
  end
-- «dict_compiler»  (to ".dict_compiler")
dict_compiler = {}
dict_compiler[";"] = function ()
    mem.compile("exit")
    state = states.outer_interpreter
  end

-- «interpret»  (to ".interpret")
-- (to "test2")
interpret  = function (str)
    local oldstate = state; interpret_(str, nil); innerloop(); state = oldstate
  end
interpret_ = function (str, stateafter)
    p.text = str
    p.pos = 0
    state = states.outer_interpreter
    rspush(function () state = stateafter end)
  end



-- prim("dup",  function () dspush(ds[1]) end)
-- prim("*",    function () ds[2] = ds[2]*ds[1]; dspop() end)
-- prim("swap", function () ds[2], ds[1] = ds[1], ds[2] end)
-- prim("drop", function () dspop() end)
-- prim(".",    function () print(dspop()) end)
-- prim("..",   function () ds[2] = ds[2]..ds[1]; dspop() end)