Warning: this is an htmlized version!
The original is across this link,
and the conversion rules are here.
-- -*- coding: raw-text -*-
-- A direct translation of Marc Simpson' RubyForth to Lua.
-- (find-angg "rubyforth/README.too")
-- Edrx, 2008nov07



-- «.stack.rb»		(to "stack.rb")
-- «.vocabulary.rb»	(to "vocabulary.rb")
-- «.kernel.rb»		(to "kernel.rb")

-- (find-lua50file "etc/compat.lua")
strchar = string.char
strfind = string.find
eval   = function (str) return assert(loadstring(str))() end
-- (find-es "rubyforth" "lrstrip")
lstrip = function (str) return str:match("^[ \t]*(.*)$") end
 strip = function (str) return str:match("^[ \t]*(.-)[ \t]*$") end
rstrip = function (str) return str:match(      "^(.-)[ \t]*$") end
string.lstrip = lstrip
string.strip  =  strip
string.rstrip = rstrip
string.split  =  split

-- «stack.rb»  (to ".stack.rb")
-- (find-rubyforthfile "stack.rb")
Stack           = {}
Stack_metatable = {__index = Stack}
Stack.new = function ()
      return setmetatable({n = 0}, Stack_metatable)
    end
Stack.push = function (s, obj)
    s.n = s.n + 1
    s[s.n] = obj
    return s
  end
Stack.pop = function (s)
    if s.n < 1 then error "Stack underflow!" end
    s.n = s.n - 1
    return s[s.n + 1]
  end
Stack.tos = function (s)
    if s.n < 1 then error "Stack underflow!" end
    return s[s.n]
  end
Stack.swap = function (s)
    local x, y = s:pop(), s:pop()
    s:push(x); s:push(y)
  end
Stack.contents = function (s)
    return s   -- This is a hack - beware!
  end
Stack.nth = function (s, n)
    return s[n + 1]  -- no checks yet
  end
Stack.depth = function (s)
    return s.n
  end




-- «vocabulary.rb»  (to ".vocabulary.rb")
-- (find-rubyforthfile "vocabulary.rb" "-[ Vocabulary Class ]-")
Vocabulary           = {}
Vocabulary_metatable = {__index = Vocabulary}
Vocabulary.new = function (name)
    local v = {vocab_name = name, [0] = {}, [1] = {}}
    return setmetatable(v, Vocabulary_metatable)
  end
Vocabulary.to_s = function (v)
    return "vocab{" .. v.vocab_name .. "}"
  end

-- (find-rubyforthfile "vocabulary.rb" "-[ Vocabulary Storage ]-")
vocabularies = Stack.new()

-- (find-rubyforthfile "vocabulary.rb" "-[ Core Words ]-")
current_vocab    = function () return vocabularies:tos() end
vocabulary_order = function () return vocabularies:contents() end
push_vocab       = function (v) vocabularies:push(v) end  
pop_vocab        = function () return vocabularies:pop() end  

-- Search for 'name' in all vocabularies, with the specified wordlist index.
find_word = function (name, wordlist_type)
    local found_xt = nil
    for i=0,vocabularies:depth()-1 do
      local vocab = vocabularies:nth(i)
      local wid = vocab[wordlist_type]
      local found_xt = wid[name]
      if found_xt then return found_xt end
    end
  end
array_index = function (arr, key, s, e)  -- like Ruby's <array>.index(key)
    for i=s or 1,e or #arr do
      if arr[i] == key then return i end
    end
  end
c_index = function (str, c)    -- like Ruby's <str>.index(c)  (c is a number)
    return str:find(strchr(c), 1, true)
  end
find_xt = function (xt, wordlist_type)
    local found_name = nil
    for i=0,vocabularies:depth()-1 do
      local vocab = vocabularies:nth(i)
      local wid = vocab[wordlist_type]
      -- ?? found_name = wid.index(xt)
      local found_name = array_index(wid, xt)
      if found_name then return found_name end
    end
  end

forth_words     = function () return current_vocab()[0] end
compiler_words  = function () return current_vocab()[1] end
forth_word      = function (name) return find_word(name, 0) end
compiler_word   = function (name) return find_word(name, 1) end
forth_header    = function (xt) return find_xt(xt, 0) end
compiler_header = function (xt) return find_xt(xt, 1) end




-- «kernel.rb»  (to ".kernel.rb")
-- (find-rubyforthfile "kernel.rb" "-[ Globals ]-")
data_stack = Stack.new()
retn_stack = Stack.new()
data_space = {n = 0}
scratch    = 0
here       = 100
ip         = 0
header_ip  = 0

rubyforth = Vocabulary.new("rubyforth")
push_vocab(rubyforth)

context     = "forth"
compiling   = false
this_header = nil

parsed       = nil
current_line = nil

-- (find-rubyforthfile "kernel.rb" "-[ Stack operations ]-")
push = function (obj) return data_stack:push(obj) end
pop  = function ()    return data_stack:pop() end
tos  = function ()    return data_stack:tos() end
rot  = function ()
    local x,y,z = pop(), pop(), pop()
    push(y); push(x); push(z)
  end
swap    = function () data_stack:swap() end
fetch   = function (addr) return data_space[addr] end
save_ip    = function () retn_stack:push(ip) end
restore_ip = function () ip = retn_stack:pop() end

-- (find-rubyforthfile "kernel.rb" "-[ Predicates ]-")
int_re   = "^-?[0-9]+$"
float_re = "^-?[0-9]*%.[0-9]+$"
word_re  = "[ \t]"
is_number  = function (str) return str:match(int_re) or str:match(float_re) end
is_primitive = function (elt) return type(elt) == "string" end

-- (find-rubyforthfile "kernel.rb" "-[ Wordlists ]-")
active_wordlist = function ()
    if context == "compiler"
    then return compiler_words()
    else return forth_words()
    end
  end
print_wordlist = function (w)   -- Pretty wordlist printing.
  local ks = sort(keys(w))
  local col = 4
  for _,k in ipairs(ks) do
    if col > 3 then col = 0; print() end
    printf("%20s", k)
    col = col + 1
  end
  print("\n")
end
print_words = function (v)      -- Print Forth then Compiler words in vocab v.
    print("FORTH\n=====\n")
    print_wordlist(v[0])
    print("COMPILER\n========\n")
    print_wordlist(v[1])
  end

-- (find-rubyforthfile "kernel.rb" "-[ String Conversion ]-")
-- We used to use traditional Forth-like strings, with conversion overhead.
-- These routines take an address/length pair from the stack and return a ruby
-- string.
_ruby_string = function (len, addr)
    local arr = {}
    for i=1,len do arr[i] = string.char(data_space[addr+i-1]) end 
    return table.concat(arr) 
  end
ruby_string = function ()                -- convert ( a u -- ) into a ruby string
    return _ruby_string(pop(), pop())
  end

-- (find-rubyforthfile "kernel.rb" "-[ Primitives ]-")
-- Our interpreter will treat strings as primitives; here we define some of the
-- lengthier operations to keep the code clear, and clean.
comma = function (n)
    data_space[here] = n; here = here + 1
  end
place = function ()
    local length, offset = pop(), pop()
    for i=0,length-1 do comma(data_space[offset+i]) end
  end
to_scratch = function (str)  -- Write a ruby string to scratch.
    local length = #str
    if length > 99 then length = 99 end
    for i=0,length-1 do data_space[scratch+i] = strbyte(str, i+1) end -- check
    push(scratch); push(length)
  end
null_parse = function ()   -- return '' and skip over the delimiter token
    parsed = ""
    current_line = current_line:sub(2)
    return parsed
  end
process_parse = function (index)  -- alter the input stream; return $parsed data
    if index == 0 then return null_parse end
    parsed       = current_line:sub(0, index)     -- check this
    current_line = current_line:sub(index)        -- check this
    return parsed
  end
parse = function ()   -- ( c -- )
    local index = c_index(current_line, pop()) or #current_line
    process_parse(index)
  end
peek = function ()    -- ( c -- )
    local index = c_index(current_line, pop()) or #current_line
    if index == 0 then return null_parse() end
    return current_line:sub(1, index-1)  -- check
  end
scratch_parse = function ()              -- perform parse, write to scratch.
    to_scratch(parse())
  end
next_word = function ()            -- fetch the index of next token separator.
    return current_line:find("()[ \t]") or #current_line
  end
parse_word = function ()           -- parse using next_word (up to separator)
    return process_parse(next_word())
  end
peek_word = function ()            -- peek using next_word
    local index = next_word()
    if index == 0 then return null_parse() end
    return current_line:sub(1, index)
  end
parse_header = function ()
    parse_word()                -- grab the next token 
    this_header = parsed        -- set most recent dictionary header
    return header(parsed)       -- write the header
  end
colon_body = function ()
    comma("doCOL")              -- begin a colon definition
    compiling = true            -- switch to compiling mode
  end
colon = function ()
    parse_header()              -- write header information
    colon_body()                -- begin doCOL
  end
noname = function ()
    push(here)                  -- leave xt on the stack
    colon_body()
  end
forth_alias = function ()       -- ( "new word" "old word" -- )
    local new_word = parse_word()
    local old_word = parse_word()
    local old_xt = xt(old_word)
    if old_xt
    then active_wordlist[new_word] = old_xt
    else print("Error: could not create an alias; '"..old_word.."' not found.")
    end
  end
variable = function ()           -- create a variable
    parse_header()
    comma("doVAR")
    comma(0)                     -- Variables default to value 0
  end
constant = function ()           -- create a constant
    parse_header()
    comma("doCONSTANT")
    comma(pop())
  end
create_body = function ()
    comma("doCREATE")
    comma(here+2)
    last_does = here
    comma(0)
  end
create = function ()            -- create a 'create' word
    parse_header()
    create_body()
  end
make = function ()              -- like create, but ( header$ -- )
    header(pop())
    create_body()
  end
dodoes = function ()            -- called at run time from a create/does> word
    -- Points to doCOL...
    data_space[last_does] = ip + 2
  end
does = function ()              -- written by does>
    comma("dodoes")
    comma("exit")
    comma("doCOL")
  end
forth_exit = function ()        -- Written by semi-colon
    comma("exit")
    compiling = false
  end
lit = function ()               -- For numerical and string literals
    ip = ip + 1
    push(fetch(ip))
  end
compile = function ()           -- Compile the next word in the input stream.
    local context_ = context    --> regardless of context, search FORTH
    context = "forth"
    push(xt(parse_word()))
    context = context_
    comma("lit")
    comma(pop())
    comma(xt(","))
  end
forth_equal = function ()
    if pop() == pop() then push(-1) else push(0) end
  end
forth_flag = function (flag)    -- convert a ruby/lua bool into a Forth flag
    if flag then return -1 else return 0 end
  end
forth_true = function ()
    return pop() ~= 0 
  end
branch = function ()  -- Branch to the next cell (take into account the NEXT call)
    ip = data_space[ip + 1] - 1
  end
qbranch = function () -- Conditional branching ('?branch'), see 'branch'
    if not forth_true() then branch() else ip = ip + 1 end
  end

-- (find-rubyforthfile "kernel.rb" "-[ Headers and XTs ]-")
header_with = function (name, address)
    active_wordlist()[name] = address
  end
header = function (name)              -- store $here into the active wordlist
    header_with(name, here)
  end
remove_header = function (header)
    active_wordlist:delete(header)    -- wrong!
  end
prim = function (name, code)    -- no threading; 'name' points to a ruby string
    header(name)
    comma(code)
  end
forth_prim = function ()        -- one-line primitive, called from Forth
    local name = parse_word()
    push(0)
    local code = parse()
    prim(name, code)
  end
-- Return the execution token for header 'name'. If local is 'true', then only
-- search the current vocabulary.
lookup_xt = function (name, locl)
    local token = nil
    if context == "compiler" then
      if locl
      then token = compiler_words[name]
      else token = compiler_word(name)
      end
      if token then return token end
    end
    if locl 
    then token = forth_words[name]
    else token = forth_word(name)
    end
    if token then return token end
    return 0
  end
xt       = function (name) lookup_xt(name, false) end
local_xt = function (name) lookup_xt(name, true)  end

-- (find-rubyforthfile "kernel.rb" "-[ Inner Interpreter ]-")
-- In this section, we define the heart of our interpreter -- forth_execute(),
-- interpret_token(), compile_token(). Tokenisation is left to the outer
-- interpreter [see the next section].
token_re = "^[ \t]*[^ \t]+[ \t]+"
doCOL = function ()
    save_ip()
    ip = header_ip + 1                   -- perform jump
    while data_space[ip] ~= "exit" do    -- hack!!!
      forth_execute(ip); ip = ip + 1
    end
    restore_ip()
  end
doVAR = function ()
    push(header_ip + 1)
  end
doCONSTANT = function ()
    push(fetch(header_ip + 1))
  end
doCREATE = function ()
    local address = fetch(header_ip + 1)
    local does_xt = fetch(header_ip + 2)
    push(address)
    forth_execute(does_xt)
  end
forth_execute = function (xt)
    local resolved = data_space[xt]     -- resolve the xt.
    if type(resolved) == "string" then  -- primitive?
      header_ip = xt                    -- can be used if necessary
      eval(resolved)                    -- *WRONG* - uses a ruby trick
    else                                -- address...
      if xt == 0 then return end        -- NOOP
      forth_execute(resolved)
    end
  end
return_to_toplevel = function () -- in case of error, clean up and reset system
    current_line = ""
    data_stack:reset()                  -- not implemented
    compiling = false
    throw("toplevel")                   -- not implemented
  end
interpret_token = function (token)
    local xt = forth_word(token)
    if xt then return forth_execute(xt) end
    if is_number(token) then return push(tonumber(token)) end
    -- Print error message and return to toplevel...
    print("'"..token.."' not found.")
    return_to_toplevel()
  end
compile_token = function (token)
    local xt = compiler_word(token)
    if xt then return forth_execute(xt) end
    xt = forth_word(token)
    if xt then return comma(xt) end
    if is_number(token) then
      comma("lit")
      comma(eval(token))                 -- not implemented
    else
      remove_header(this_header)
      print("'#"..token.."' not found during compilation of '"..this_header.."'.")
      return_to_toplevel()
    end
  end

-- (find-rubyforthfile "kernel.rb" "-[ Outer Interpreter ]-")
-- Here we define operations for reading input from strings, tokenising, and
-- dispatching these tokens to the inner interpreter.
forth_eval_token = function (token)
    if compiling
    then compile_token(token)
    else interpret_token(token)
    end
  end
forth_process_line = function () -- fetch the next token from the input stream
    current_line = current_line:strip()
    local  token = current_line:split()[1]
    if token
    then current_line = current_line:sub(#token + 1)
    else current_line = current_line:strip()
    end
    return token
  end
_forth_eval_line = function ()   -- silently evaluate the line
    while current_line do
      local token = forth_process_line()
      if not token then break end
      forth_eval_token(token)
    end
  end
forth_eval_line = function () -- as above, but print confirmation of action
    _forth_eval_line()
    if compiling 
    then print "\tcompiled"
    else print "\tok"
    end 
  end
forth_eval = function (str)
    current_line = str
    forth_eval_line()
  end
code = function (str)         -- for inlining Forth in Ruby scripts
    current_line = str
    _forth_eval_line()
  end

-- (find-rubyforthfile "kernel.rb" "-[ Toplevel ]-")
alive = true
enter_forth = function ()     -- our REPL loop
    while alive do
      current_line = io.read()
      if not current_line then break end
      -- catch ("toplevel") do
      -- begin
      forth_eval_line()
      -- rescue Exception
      -- puts "Error: Ruby has encountered the following error:\n#{$!}"
      -- end
    end
  end
compiler = function () context = "compiler" end
forth    = function () context = "forth"    end




-- (find-rubyforthfile "")
-- (find-rubyforthfile "primitives.rb")
Prim = function (str) prim(str:match("^[ \t]*([^ \t]+)[ \t]+(.*)")) end

compiler()                     -- COMPILER words.

Prim          ";       forth_exit()"
Prim    "compile       compile()"
Prim    "literal       comma('lit'); comma(pop())"
Prim      "does>       does()"
Prim          "[       compiling = false"
Prim         "\"       push(34); comma('lit'); comma(parse())"

forth()                        -- FORTH words.

Prim   ".context       puts 'Context is: \"'..context..'\"'"

Prim     "branch       branch()"
Prim    "?branch       qbranch()"

Prim          ".       printf('%s ', pop())"
Prim          ">       push(forth_flag(pop() < pop()))"
Prim          "<       push(forth_flag(pop() > pop()))"
Prim          "*       swap() ; push(pop() * pop())"
Prim          "+       swap() ; push(pop() + pop())"
Prim          "-       swap() ; push(pop() - pop())"
Prim          "/       swap() ; push(pop() / pop())"
Prim          "=       forth_equal()"
Prim          ",       comma(pop())"
Prim          "@       push(data_space[pop()])"
Prim          "!       data_space[pop()] = pop()"
Prim         "\"       push(34); push(parse())"
Prim         "1-       push(pop() - 1)"
Prim         "1+       push(pop() + 1)"
Prim         "**       swap(); push(pop()^pop())"
Prim         ".r       printf('%'..pop()..'i', pop())"

Prim         ">r       retn_stack:push(pop())"
Prim         "r>       push(retn_stack:pop())"
Prim         "r@       push(retn_stack:tos())"

Prim     "invert       push(binv(pop()))"
Prim        "and       push(band(pop(), pop()))"
Prim         "or       push(bor(pop(), pop()))"

Prim         "bl       push(32)"
Prim        "dup       push(tos())"
Prim        "rot       rot()"
Prim       "drop       pop()"
Prim       "swap       swap()"
Prim       "over       push(data_stack:nth(1))"

Prim       "here       push(here)"
Prim      "allot       here = here + pop()"
Prim      "place       place()"
Prim   "variable       variable()"
Prim   "constant       constant()"

Prim       "peek       push(peek())"    -- parse, non-destructive
Prim      "parse       push(parse())"   -- parse, returning a string
Prim       "word       scratch_parse()" -- parse, scratch: ( -- addr len )
Prim "parse-word       push(parse_word())"
Prim  "peek-word       push(peek_word())"
Prim       "type       print(pop())"
Prim       "emit       printf('%c', pop())"

Prim       "page       system('clear')"

Prim  "rubyforth       push(rubyforth)"
Prim      "vocab       push(Vocabulary.new(pop()))"
Prim     "expose       push_vocab(pop())"
Prim     "shield       pop_vocab()"
Prim      "order       vocabulary_order()"
Prim      "words       print_words(current_vocab())"
Prim     ".vocab       print_words(pop())"

Prim        "see       see()"
Prim         "cr       print()"
Prim         ".s       data_stack:contents()"
Prim        ".ds       ds_print()"      -- dump data-space to stdout

Prim        "bye       alive = false"
Prim       "quit       throw('toplevel')"
Prim      "chdir       Dir.chdir(pop())"
Prim         "cd       push(0); Dir.chdir(parse())"

Prim          ":       colon()"
Prim          "]       compiling = true"
Prim       "prim       forth_prim()"
Prim      "alias       forth_alias()"
Prim       "make       make()"
Prim     "create       create()"
Prim    ":noname       noname()"
Prim     "header       header(pop())"
Prim    "header,       swap(); header_with(pop(), pop())"

Prim   "compiler       context = 'compiler'"
Prim      "forth       context = 'forth'"

Prim          "'       push(xt(parse_word()))"
Prim        "xt?       push(xt(pop()))"
Prim      "name?       push(lookup_name(pop()))"
Prim     "local'       push(local_xt(parse_word()))"
Prim     "search       push_vocab(pop()); push(local_xt(pop())); pop_vocab()"
Prim   "local-xt       push(local_xt(pop()))"
Prim "local-name?      push(lookup_local_name(pop()))"

Prim    "execute       forth_execute(pop())"
Prim   "evaluate       code(pop())"
Prim  "ruby-eval       eval(pop())"
Prim   "lua-eval       eval(pop())"

Prim        "nip       swap(); pop()"
Prim       "tuck       swap(); push(data_stack.nth(1))"
Prim       "2dup       push($data_stack.nth(1)); push(data_stack.nth(1))"
Prim      "2swap       rot();retn_stack:push(pop());rot();push(retn_stack:pop())"
Prim      "2drop       pop(); pop()"
Prim      "space       printf ' '"
Prim     "spaces       printf(strrep(' ', pop()))"

--[ High Level ]-----------------------------------------------------------
-- # 
-- # We define comments, then load the rest of the system from a Forth script.
-- 
-- compiler
-- 
-- code  ': \ 0  parse drop ;'     # comment out the rest of the line
-- code  ': ( 41 parse drop ;'     # comment until )
-- 
-- forth
-- 
-- code  ': \ 0  parse drop ;'
-- code  ': ( 41 parse drop ;'
-- 
-- code  'include high-level.fs'   # include!