|
Warning: this is an htmlized version!
The original is here, 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!