# ==============================================================================
# 
# 	RubyFORTH -- Copyright (C) 2007-8, Marc Simpson (GPL). 
# 
#	Kernel (inner and outer interpreter)
# 
# ==============================================================================

require 'vocabulary.rb'

# --[ Globals ]-----------------------------------------------------------------
# 
# Important globals.

$data_stack = Stack.new(128) ; $retn_stack = Stack.new(128)

$data_space = Array.new(4096, 0)
$here = 1 ; $ip = 0 ; $header_ip = 0

$rubyforth = Vocabulary.new('rubyforth')
push_vocab($rubyforth)

$context   = "forth"
$compiling = false
$this_header = nil

$parsed  = $current_line = nil

# --[ Stack operations ]--------------------------------------------------------

def push(n)
  $data_stack.push(n)
end

def pop
  $data_stack.pop
end

def tos
  $data_stack.tos
end

def rot
  x = pop ; y = pop ; z = pop
  push(y) ; push(x) ; push(z) 
end 

def swap
  $data_stack.swap
end

def fetch(addr)                  # resolve an offset in the dictionary
  $data_space[addr]
end

def save_ip
  $retn_stack.push($ip)
end

def restore_ip
  $ip = $retn_stack.pop
end

# --[ Predicates ]--------------------------------------------------------------

$num_re = /^-?[0-9]+(\.[0-9]+)?$/ # integer or floating point.
$word_re = /[ \t]/                # token separator.

def is_number(string)
  $num_re.match(string)
end

def is_primitive(element)
  element.class == String
end

# --[ Wordlists ]---------------------------------------------------------------

def active_wordlist
  if $context == "compiler"
    compiler_words
  else
    forth_words
  end
end

def print_wordlist(w)           # Pretty wordlist printing.
  keys = w.keys.sort
  col = 4
  keys.each do |k|
    if col > 3
      col = 0
      print "\n"
    end
    printf("%20s", k)
    col += 1
  end
  puts "\n\n"
end

def print_words(v)              # Print Forth then Compiler words in vocab v.
  puts "FORTH\n=====\n"
  print_wordlist(v[0])
  puts "COMPILER\n========\n"
  print_wordlist(v[1])
end

# --[ Primitives ]--------------------------------------------------------------
# 
# Our interpreter will treat strings as primitives; here we define some of the
# lengthier operations to keep the code clear, and clean.

def comma(n)
  $data_space[$here] = n ; $here += 1
end

def place
  length = pop ; offset = pop
  0.upto(length-1) { |cell| comma($data_space[offset+cell]) }
end

def null_parse                  # return '' and skip over the delimiter token
  $parsed = ''
  $current_line = $current_line[1..$current_line.length]
  $parsed
end

def process_parse(index)        # alter the input stream; return $parsed data
  if index == 0 
    return null_parse
  end
  $parsed = $current_line[0..index-1]
  $current_line = $current_line[index+1..-1]
  $current_line = '' if ! $current_line
  $parsed
end

def parse                       # ( c -- )
  index = $current_line.index(pop.chr)
  index = $current_line.length if ! index                    
  process_parse(index)
end

def peek                        # ( c -- )
  index = $current_line.index(pop.chr)
  index = $current_line.length if ! index                    
  return null_parse if index == 0
  $current_line[0..index-1]
end

def next_word                   # fetch the index of next token separator.
  m = $word_re.match($current_line)
  if m
    i = m.begin(0)
  else
    i = $current_line.length
  end
  return i
end

def parse_word                  # parse using next_word (up to separator)
  process_parse(next_word)
end

def peek_word                   # peek using next_word
  index = next_word
  return null_parse if index == 0
  $current_line[0..index-1]
end  

def parse_header
  parse_word                    # grab the next token 
  $this_header = $parsed        # set most recent dictionary header
  header($parsed)               # write the header
end

def colon_body
  comma("doCOL")                # begin a colon definition
  $compiling = true             # switch to compiling mode
end

def colon
  parse_header                  # write header information
  colon_body                    # begin doCOL
end

def noname
  push($here)                   # leave xt on the stack
  colon_body
end

def forth_alias                 # ( "new word" "old word" -- )
  new_word = parse_word
  old_word = parse_word
  old_xt = xt(old_word)
  if old_xt
    active_wordlist[new_word] = old_xt
  else
    puts "Error: could not create an alias; '#{old_word}' not found."
  end
end

def variable                    # create a variable
  parse_header
  comma("doVAR")
  comma(0)                      # Variables default to value 0
end

def constant                    # create a constant
  parse_header
  comma("doCONSTANT")
  comma(pop)
end

def create_body
  comma("doCREATE")
  comma($here+2)
  $last_does = $here
  comma(0)
end

def create                      # create a 'create' word
  parse_header
  create_body
end

def make                        # like create, but ( header$ -- )
  header(pop)
  create_body
end

def dodoes                      # called at run time from a create/does> word
  # Points to doCOL...
  $data_space[$last_does] = $ip + 2
end

def does                        # written by does>
  comma("dodoes")
  comma("exit")
  comma("doCOL")
end

def forth_exit                  # Written by semi-colon
  comma("exit")
  $compiling = false
end

def lit                         # For numerical and string literals
  $ip += 1
  push(fetch($ip))
end

def compile                     # Compile the next word in the input stream.
  context = $context            # --> regardless of context, search FORTH
  $context = "forth"
  push(xt(parse_word))
  $context = context
  comma("lit")
  comma(pop)
  comma(xt(","))
end

def forth_equal
  return push(-1) if pop == pop
  push(0)
end

def forth_flag(f)               # convert a ruby bool into a Forth flag
  return -1 if f
  return 0
end
  
def forth_true
  pop != 0 
end

def branch
  # Branch to the next cell (take into account the NEXT call)
  $ip = $data_space[$ip + 1] - 1
end

def qbranch                  # Conditional branching ('?branch'), see 'branch'
  flag = forth_true
  if ! flag
    branch
  else
    $ip += 1
  end
end

# --[ Headers and XTs ]---------------------------------------------------------

def header_with(name, address)
  active_wordlist[name] = address
end

def header(name)                # store $here into the active wordlist
  header_with(name, $here)
end

def remove_header(header)
  w = active_wordlist
  w.delete(header)
end

def prim(name, code)            # no threading; 'name' points to a ruby string
  header(name)
  comma(code)
end

def forth_prim                  # one-line primitive, called from Forth
  name = parse_word
  push(0)
  code = parse
  prim(name, code)
end

# Return the execution token for header 'name'. If local is 'true', then only
# search the current vocabulary.
# 
def lookup_xt(name, local)
  token = nil
  if $context == "compiler"
    if local
      token = compiler_words[name]
    else
      token = compiler_word(name)
    end
    return token if token
  end
  if local 
    token = forth_words[name]
  else
    token = forth_word(name)
  end
  return token if token 
  return 0
end

def xt(name)
  lookup_xt(name, false)
end

def local_xt(name)
  lookup_xt(name, true)
end

# --[ 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]+/

def doCOL
  save_ip
  $ip = $header_ip + 1          # perform jump
  while $data_space[$ip] != "exit"
    forth_execute($ip) ; $ip += 1
  end
  restore_ip
end

def doVAR
  push($header_ip + 1)
end

def doCONSTANT
  push(fetch($header_ip + 1))
end

def doCREATE
  address = fetch($header_ip + 1)
  does_xt = fetch($header_ip + 2)
  push(address)
  forth_execute(does_xt)
end

def forth_execute(xt)
  resolved = $data_space[xt]     # resolve the xt.
  if resolved.class == String    # primitive?
    $header_ip = xt              # can be used if necessary
    eval resolved
  else                          # address...
    return nil if xt == 0       # NOOP
    forth_execute(resolved)
  end
end

def return_to_toplevel          # in case of error, clean up and reset system
  $current_line = ""
  $data_stack.reset
  $compiling = false
  throw("toplevel")
end

def interpret_token(token)
  xt = forth_word(token)
  return forth_execute(xt) if xt
  return push(eval(token)) if is_number(token)
  # Print error message and return to toplevel...
  puts "'#{token}' not found."
  return_to_toplevel
end

def compile_token(token)
  xt = compiler_word(token)
  return forth_execute(xt) if xt 
  xt = forth_word(token)
  return comma(xt) if xt
  if is_number(token)
    comma("lit")
    comma(eval(token))
  else
    remove_header($this_header)
    puts "'#{token}' not found during compilation of '#{$this_header}'." 
    return_to_toplevel
  end
end

# --[ Outer Interpreter ]-------------------------------------------------------
# 
# Here we define operations for reading input from strings, tokenising, and
# dispatching these tokens to the inner interpreter.

def forth_eval_token(token)
  if $compiling
    compile_token(token)
  else
    interpret_token(token)
  end
end

def forth_process_line          # fetch the next token from the input stream
  $current_line.strip!
  token = $current_line.split[0]
  if token
    $current_line = $current_line[token.length..-1]
    $current_line.strip!
  end
  token
end

def _forth_eval_line            # silently evaluate the line
  while $current_line and token = forth_process_line
    forth_eval_token(token)
  end
end

def forth_eval_line             # as above, but print confirmation of action
  _forth_eval_line
  if $compiling 
    puts "	compiled"
  else 
    puts "	ok"
  end 
end

def forth_eval(string)
  $current_line = string
  forth_eval_line
end

def code(string)                # for inlining Forth in Ruby scripts
  $current_line = string
  _forth_eval_line
end

# --[ Toplevel ]----------------------------------------------------------------

$alive = true

def enter_forth                 # our REPL loop
  while $alive and $current_line = gets
    catch ("toplevel") do
      begin
        forth_eval_line
      rescue Exception
        puts "Error: Ruby has encountered the following error:\n#{$!}"
      end
    end
  end
end

def compiler
  $context = "compiler" 
end

def forth
  $context = "forth"    
end