forth-stuff/CoreWords.tl

local ds = require("DataStructures")
local Dictionary, Stack, WordInfo, Environment = ds.Dictionary, ds.Stack, ds.WordInfo, ds.Environment
local helpers = require("CoreHelpers")
local areNumbers, getActiveDataStack, isNumber, isWhitespace= helpers.areNumbers, helpers.getActiveDataStack, helpers.isNumber, helpers.isWhitespace
local skipWhitespace, parseToken = helpers.skipWhitespace, helpers.parseToken
local popTwoOperands = helpers.popTwoOperands
local defineWord = helpers.defineWord
local ret = helpers.ret
local makeCall = helpers.makeCall

local literal = helpers.literal
local compile = helpers.compile
-- Mathematical operations
local function add(env: Environment)
  local a, b = popTwoOperands(env)
  if areNumbers(a,b) then
    local c = (a as number) + (b as number)
    getActiveDataStack(env):push(c)
  else
    error("invalid operands for add operation!")
  end
end
local function sub(env: Environment)
  local a, b = popTwoOperands(env)
  if areNumbers(a, b) then
    local c = (a as number) - (b as number)
    getActiveDataStack(env):push(c)
  else
    error("invalid operands for sub operation!")
  end
end
local function mul(env: Environment)
  local a, b = popTwoOperands(env)
  if areNumbers(a, b) then
    local c = (a as number) * (b as number)
    getActiveDataStack(env):push(c)
  else
    error("invalid operands for mul operation!")
  end
end
local function div(env: Environment)
  local a, b = popTwoOperands(env)
  if areNumbers(a, b) then
    local c = (a as number) / (b as number)
    getActiveDataStack(env):push(c)
  else
    error("invalid operands for div operation!")
  end
end

local function dup(env: Environment)
  local stack = getActiveDataStack(env)
  local top = stack:pop()
  stack:push(top)
  stack:push(top)
end
local function swap(env: Environment)
  local stack = getActiveDataStack(env)
  local a, b = popTwoOperands(env)
  stack:push(b)
  stack:push(a)
end
local function rot(env: Environment)
  local stack = getActiveDataStack(env)
  local c, b, a= stack:pop(), stack:pop(), stack:pop()
  stack:push(b)
  stack:push(c)
  stack:push(a)
end
local function drop(env: Environment)
  local stack = getActiveDataStack(env)
  stack:pop()
end
local function over(env: Environment)
  local stack = getActiveDataStack(env)
  local b, a = stack:pop(), stack:pop()
  stack:push(a)
  stack:push(b)
  stack:push(a)
end
-- I/O operations
local function dot(env: Environment)
	local out = env.activeDataStack:pop()
  io.write(tostring(out) as string)
end

local twoDup = helpers.makeCall{over, over, ret}

local function twoSwap(env: Environment)
  local stack = getActiveDataStack(env)
  local d, c, b, a = stack:pop(), stack:pop(), stack:pop(), stack:pop()
  stack:push(c)
  stack:push(d)
  stack:push(a)
  stack:push(b)
end


local function twoOver(env: Environment)
  local stack = getActiveDataStack(env)
  local d, c, b, a = stack:pop(), stack:pop(), stack:pop(), stack:pop()
  stack:push(a)
  stack:push(b)
  stack:push(c)
  stack:push(d)
  stack:push(a)
  stack:push(b)
end
local function nip(env: Environment)
  local stack = getActiveDataStack(env)
  local b, _ = stack:pop(), stack:pop()
  stack:push(b)
end

local tuck = helpers.makeCall{swap, over, ret}

local function roll(env: Environment)
  local stack = getActiveDataStack(env)
  local u = stack:pop()
  local bufferStack = Stack:new()
  if u is number then
    local v = u as number
    while(v > 0) do
      local item = stack:pop()
      bufferStack:push(item)
      v = v - 1
    end
    local newTop = stack:pop()
    local x = (u as number)
    while(x > 0) do
      local item = bufferStack:pop()
      stack:push(item)
      x = x - 1
    end
    stack:push(newTop)
  else
    error("u is not a number")
  end
end 
local function getExecutionToken(env: Environment)
  local stack = getActiveDataStack(env)
  skipWhitespace(env)
  local name: string = parseToken(env)
  for _, dictionary in ipairs(env.dictionaries) do
    local wordinfo = dictionary:lookup(name)
    if wordinfo then
      stack:push((wordinfo as WordInfo).func)
      break
    end
  end
end

local function execute(env: Environment)
  local stack = getActiveDataStack(env)
  local func: function(Environment) = stack:pop() as function(Environment)
  func(env)
end

local function enterCompileMode(e: Environment)
  e.compileState = true
end

local function exitCompileMode(e: Environment)
  e.compileState = false
end

local function colon(e: Environment)
  skipWhitespace(e)
  local name: string | nil = parseToken(e)
  if not name then
    e.running = false
    return
  end
  e.currentDefinitionName = name as string
  enterCompileMode(e)
end

local function semicolon(e: Environment)
  table.insert(e.currentDefinition as {function(Environment)}, helpers.ret)
  local instrs = e.currentDefinition
  local call = helpers.makeCall(instrs as {function(Environment)})
  local dict = e.dictionaries[1]
  defineWord(dict, e.currentDefinitionName, call, false)
  e.mostRecentDefinition = e.currentDefinitionName
  e.currentDefinitionName = nil
  e.currentDefinition = {}
  exitCompileMode(e)
end
local function toCompileStack(e: Environment)
  local dataStack = getActiveDataStack(e)
  local compileStack = e.compilerStack
  local val = dataStack:pop()
  compileStack:push(val)
end

local function fromCompileStack(e: Environment)
  e.activeDataStack:push(e.compilerStack:pop())
end

local function getDefinitionIndex(e: Environment)
  e.activeDataStack:push(#e.currentDefinition)
end

local function unresolvedZeroBranch(e: Environment)
  helpers.noop(e)
end

local function unresolvedUncondBranch(e: Environment)
  helpers.noop(e)
end

local function getResolvedZeroBranch(destinationIndex: integer): function(Environment)
  return function(e: Environment)
    local flag = e.activeDataStack:pop()
    if flag == 0 or not flag then
      e.instructionPointer.index = destinationIndex
    end
  end
end

local function resolveBranch(e: Environment, sourceIndex: integer, destinationIndex: integer): function(Environment)
  if e.currentDefinition[sourceIndex] == unresolvedZeroBranch then
    return function(e: Environment)
      local flag = e.activeDataStack:pop()
      if flag == 0 or not flag then
        e.instructionPointer.index = destinationIndex
      end
    end
  elseif e.currentDefinition[sourceIndex] == unresolvedUncondBranch then
    return function(e: Environment)
      e.instructionPointer.index = destinationIndex
    end
  end
  -- TODO: abort if none of the checks succeed
end


local function forthIf(e: Environment)
  table.insert(e.currentDefinition as {function(Environment)}, unresolvedZeroBranch)
  getDefinitionIndex(e)
  toCompileStack(e)
end

local function patchBranch(e: Environment)
  local branchIndex = e.activeDataStack:pop() as integer
  local destinationIndex = e.activeDataStack:pop() as integer
  e.currentDefinition[branchIndex as integer] = resolveBranch(e,branchIndex,destinationIndex)
end


local function forthThen(e: Environment)
  getDefinitionIndex(e)
  fromCompileStack(e)
  patchBranch(e)
end
local function forthElse(e: Environment)
  table.insert(e.currentDefinition as {function(Environment)}, unresolvedUncondBranch)
  getDefinitionIndex(e)
  fromCompileStack(e)
  patchBranch(e)
  getDefinitionIndex(e)
  toCompileStack(e)
end


local function cmplt(e: Environment)
  local a, b = popTwoOperands(e)
  e.activeDataStack:push((a as number) < (b as number))
end
local function cmplte(e: Environment)
  local a, b = popTwoOperands(e)
  e.activeDataStack:push((a as number) <= (b as number))
end
local function cmpe(e: Environment)
  local a, b = popTwoOperands(e)
  e.activeDataStack:push((a as number) == (b as number))
end
local function cmpgte(e: Environment)
  local a, b = popTwoOperands(e)
  e.activeDataStack:push((a as number) >= (b as number))
end
local function cmpgt(e: Environment)
  local a, b = popTwoOperands(e)
  e.activeDataStack:push((a as number) > (b as number))
end
local function cmpne(e: Environment)
  local a, b = popTwoOperands(e)
  e.activeDataStack:push((a as number) ~= (b as number))
end

local function markImmediate(e: Environment)
  helpers.searchDictionaries(e, e.mostRecentDefinition).immediate = true
end

local function forthBegin(e: Environment)
  getDefinitionIndex(e)
  toCompileStack(e)
end

local function forthUntil(e: Environment)
  fromCompileStack(e)
  table.insert(e.currentDefinition as {function(Environment)}, unresolvedZeroBranch)
  getDefinitionIndex(e)
  patchBranch(e)
end
local function forthAgain(e: Environment)
  fromCompileStack(e)
  table.insert(e.currentDefinition as {function(Environment)}, unresolvedUncondBranch)
  getDefinitionIndex(e)
  patchBranch(e)
end
local function forthWhile(e: Environment)
  fromCompileStack(e)
  table.insert(e.currentDefinition as {function(Environment)}, unresolvedZeroBranch)
  getDefinitionIndex(e)
  toCompileStack(e)
  toCompileStack(e)
end

local function forthRepeat(e: Environment)
  fromCompileStack(e)
  table.insert(e.currentDefinition as {function(Environment)}, unresolvedUncondBranch)
  getDefinitionIndex(e)
  patchBranch(e)
  getDefinitionIndex(e)
  fromCompileStack(e)
  patchBranch(e)
end

local function stringLiteral(e: Environment)
  local str: string | nil = ""
  local chr: string | nil = ""
  if not e.activeInputStream:curr() then e.activeDataStack:push("") end
  while(not (chr == "\"") and chr ~= nil) do
    str = str..(chr as string)
    chr = e.activeInputStream:next()
  end
  e.activeInputStream:next()
  e.activeDataStack:push(str as string)
end

local CoreWords = Dictionary:new()
local addInfo = WordInfo:new(add, false)
local subInfo = WordInfo:new(sub, false)
local mulInfo = WordInfo:new(mul, false)
local divInfo = WordInfo:new(div, false)
local dotInfo = WordInfo:new(dot, false)
local dupInfo = WordInfo:new(dup, false)
local swapInfo = WordInfo:new(swap, false)
local rotInfo = WordInfo:new(rot, false)
local dropInfo = WordInfo:new(drop, false)
local overInfo = WordInfo:new(over, false)
local twoDupInfo = WordInfo:new(twoDup, false)
local twoSwapInfo = WordInfo:new(twoSwap, false)
local twoOverInfo = WordInfo:new(twoOver, false)
local nipInfo = WordInfo:new(nip, false)

defineWord(CoreWords, "TUCK", tuck, false)
defineWord(CoreWords, "ROLL", roll, false)
defineWord(CoreWords, "'", getExecutionToken, false)
defineWord(CoreWords, "EXECUTE", execute, false)
defineWord(CoreWords, "[", exitCompileMode, true)
defineWord(CoreWords, "]", enterCompileMode, false)
defineWord(CoreWords, "COMPILE,", compile, true)
defineWord(CoreWords, "LITERAL", literal, true)
defineWord(CoreWords, ":", colon, true)
defineWord(CoreWords, ";", semicolon, true)
defineWord(CoreWords, ">C",toCompileStack, false)
defineWord(CoreWords, "C>", fromCompileStack, false)
defineWord(CoreWords, "DP", getDefinitionIndex, false)
defineWord(CoreWords, "IF", forthIf, true)
defineWord(CoreWords, "THEN", forthThen, true)
defineWord(CoreWords, "ELSE", forthElse, true)
defineWord(CoreWords, "IMMEDIATE", markImmediate, false)
defineWord(CoreWords, "BEGIN", forthBegin, true)
defineWord(CoreWords, "UNTIL", forthUntil, true)
defineWord(CoreWords, "WHILE", forthWhile, true)
defineWord(CoreWords, "REPEAT", forthRepeat, true)
defineWord(CoreWords, "AGAIN", forthAgain, true)

defineWord(CoreWords,"<", cmplt, false)
defineWord(CoreWords,"<=", cmplte, false)
defineWord(CoreWords,"=", cmpe, false)
defineWord(CoreWords,">=", cmpgte, false)
defineWord(CoreWords,">", cmpgt, false)
defineWord(CoreWords,"<>", cmpne, false)
defineWord(CoreWords,"S\"", stringLiteral, false)


CoreWords:define("+", addInfo)
CoreWords:define("-", subInfo)
CoreWords:define("*", mulInfo)
CoreWords:define("/", divInfo)
CoreWords:define(".", dotInfo)

CoreWords:define("DUP", dupInfo)
CoreWords:define("SWAP", swapInfo)
CoreWords:define("ROT", rotInfo)
CoreWords:define("DROP", dropInfo)
CoreWords:define("OVER", overInfo)
CoreWords:define("2DUP", twoDupInfo)
CoreWords:define("2SWAP", twoSwapInfo)
CoreWords:define("2OVER", twoOverInfo)
CoreWords:define("NIP", nipInfo)



local sqr = {dup, mul, ret}
local sqrf = makeCall(sqr)

defineWord(CoreWords, "SQR", sqrf, false)








return CoreWords