# ==============================================================================
# 
# 	RubyFORTH -- Copyright (C) 2007-8, Marc Simpson (GPL). 
# 
#	Forth primitives.
# 
# ==============================================================================

require 'kernel.rb'
require 'file.rb'
require 'inspector.rb'

# --[ Dictionary ]--------------------------------------------------------------
# 
# Here are the basic Forth primitives, written in Ruby. Each prim has
# a header in the $context wordlist (a hashed dictionary in the
# topmost vocabulary -- see $vocabularies) and consists of a Ruby
# string for its body.

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          "."  ,  "print pop ; print ' '"
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         "i@"  ,  "swap; push(pop[pop])"
prim         "i!"  ,  "swap; pop[pop] = pop"

prim     "invert"  ,  "push(~ pop)"
prim        "and"  ,  "push(pop & pop)"
prim         "or"  ,  "push(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 += 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 "parse-word"  ,  "push(parse_word)"
prim  "peek-word"  ,  "push(peek_word)"
prim       "type"  ,  "print pop"
prim       "emit"  ,  "print pop.chr"

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 "\n"'
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        "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"  ,  "print ' '"
prim     "spaces"  ,  "pop.times { |i| print ' ' }"

# --[ 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!