bashforth

#!/bin/bash
set -u
# set -x

# required bash 2.04 or more recent, but probably depends on bash 3.x now, since v0.54


version="0.63a"
# bashforth - forth interpreter in bash
# v0.03 20030219 ls added bool, logical, constants, fixed nip and other
# v0.04 20030219 ls added ?dup, fixed 0branch
# v0.05 20030220 ls reviewed auto-inc/dec addressing modi, fixed 0branch again
# v0.06 20030220 ls constants redone
# v0.07 20030220 ls added lshift rshift
# v0.08 20030220 ls emit outputs correctly decimal numbers on stack. thanks dufflebunk
# v0.09 20030220 ls simplified asc table building.
# v0.10 20030220 ls accept works. uses external command  cut  right now.
# v0.11 20030220 ls added pad c@ @ c! ! count
# v0.12 20030221 ls key and accept return asciis, rather than chars.
#                        emit, type, find work on asciis
# v0.13 20030221 ls word,  input stream parser, query, interpret, quit added
#                        this enables multiple words on input line
# v0.14 20030221 ls ?number added, extended interpreter. numbers work, but
#                         only decimal
# v0.15 20030221 ls added deferred words, improved error handler. first
#                        defining words. creation of variables works.
# v0.16 20030221 ls immediate, colon definitions work
# v0.17 20030222 ls improved prompt, added ' and ['], compiles numbers
#                        find returns the word#, can get to xt, name and header flags.
#                        added 2*, 2/, negate, begin..again  begin..until
# v0.18 20030222 ls if..then, if..else..then begin..while..repeat work. structure is tested
# v0.19 20030222 ls do..loop, i, j, negative numbers input, commented out debug output
#                        from virtual machine for 50% speed improvement
# v0.20 20030223 ls added  does>  2+
# v0.21 20030223 ls hide, reveal, constant. started redoing error handler. loops broken
# v0.22 20030223 ls loops fixed. ?comp
# v0.23 20030223 ls added  catch throw ?exec  . fixed key (space). ctrl chars return asc of space too.
# v0.24 20030224 ls added  ." , s" , $, .(      fixed bug in word .  tests stack underflow
# v0.26 20030225 ls added s( \ (
# v0.27 20030225 ls errorhandler through throw. top level error handler catches gracefully
# v0.28 20030225 ls speed increase of about 50 %
# v0.29 20030225 ls exit, outputs asciis 0...31, speeded up compares, improved move
# v0.30 20030225 ls .. outputs decimal (quick), . respects base (slower), number input respects base
#                        added hex, decimal, binary
# v0.31 20030226 ls pictured number output added ( <# # #s #> #>type sign )
# v0.31a20030226 ls hold (forgotten, pictured number output), rot, -rot
# v0.32 20030226 ls system (shells to command), pack ( a n -- x ) packs string to string on tos,
#                        unpack (explodes tos string to memory), cleaned up messy accept and name
# v0.33 20030226 ls added bash, fixed does>, started include.  sent out for does> fix
# v0.34 20030226 ls first rough version of include works. no nesting yet. thanks deltab for getting the source into vars
# v0.35 20030226 ls fixed backslash bug in include.
# this is for the time being the last version of bashforth. i'm now busy working on a target translator which allows to generate source
# for several languages, including bash
# v0.36 20030305 ls added pick, found a way to split input stream into chars w/o requiring external cut, as a result
#                        including source files works much quicker. bashforth is "pure" now.
# v0.37 20030309 ls number output with . doesn't complain about zero-string stack elements.
#                        stack order  reversed.  added */  */mod  ?do  leave . speeded up type
# v0.37a20030310 ls fixed include, broken in 0.37 because of changed do
# v0.37b20030310 ls fixed include again. * in source was expanded to file list
# v0.37c20030310 ls fixed ." which had cr appended
# v0.38 20030310 ls added skip, scan, tuck, compare
# v0.39 20030310 ls added min max abs fill doc,   abort throws,  removed ?exec
# v0.40 20030311 ls bugfix for 2.05a, hopefully for 2.04 too. incompatible with 2.03
# v0.41 20030311 ls redone doc. this implementation writes line number to word body. added rnd +! cell cells chars
# v0.42 20030311 ls more consistent use of addressing modes, added
#                date&time.fixed negative number big introduced with .40
# v0.42a20030313 ls changed email address. verified function on bash 2.04. thanks, stepan
# v0.42b20030315 ls fixed sign bug, result of v0.40, added >name
# v0.43 20030316 ls added .name, roll, improved locate and >name, last points now to cfa of last word
# v0.44 20030316 ls added cell+ char +loop ?leave **
# v0.45 20030316 ls added 2>r 2r>, cleaned up code, speeded up some words (type, #, words)
# v0.46 20030316 ls added literal, compiling, addressing modes optimizations
# v0.46a20030316 ls bugfix addressing modes v0.46. untested with bash 2.04
# v0.47 20030319 ls added black yellow green red blue magenta cyan white fg bg colors
# v0.47a20030320 ls added normal bold underscore reverse attr@ attr!
# v0.47b20030320 ls added at home
# v0.47c20030325 ls added ?at (doesn't work yet) number /string right$ left$
# v0.48 20030325 ls added system2 2swap dup$ drop$ depth$ 2dup$ swap$ over$ nip$ rot$ push$ pop$ append$
#                        modified left$ right$, these work on stop string stack element now
#                        modified doc to show word description, besides stack effect. optimized does>
# v0.48a20030325 ls added/modified descriptions
# v0.48b20030526 ls replaced hide/reveal against versions by h-peter recktenwald. these ones seem
#                        to be less sensitive for the used version of bash
# v0.48c20030527 ls bug fix "hold", bug discovered by h-peter recktenwald
# v0.48d20030530 ls merged with h-peter recktenwald's patches: info, hold, immediate
#                        hi-level . is about 50 % slower than former primitive version
#                        (output 1000 number 7.5 rather than 4.7 seconds now)
# v0.48e20030808 ls attempted fix of ?number, number and * for bash v2.04 on BEOS
# v0.49 20030809 ls fixed time&date, broken after 2.04 fix in 0.48e
# v0.49a20030809 ls fixed loop +loop for 2.04
# v0.49b20030818 ls found a better fix for time&date
# v0.49c20031019 ls fixed : foo ." *" ;  bug which displayed current directory
# v0.49d20031019 ls added for .. next, compatible with i j  , added spaces.
#                        made count tolerant for non-initialized memory locations
# v0.49e20031019 ls attempt to include nonexisting file throws -38
# 0.50  20031028 ls added see  (does not decompile, shows script source instead)
# 0.50a 20040101 ls fixed : $structured, not structured in until
# 0.50b 20040928 ls optional doc <word> uses sed rather than tail - recently tail args were changed.
# 0.51  20041004 ls added 2@ and 2!, suggested by Antonio Maschio
# 0.52  20041116 ls slow (1sec) version of key?, added secs and epoche
# 0.52a 20041123 ls can emit ascii <32 correctly
# 0.53  20041217 ls ***STACK EFFECT OF 'WORD' HAS CHANGED***  previously ( c -- a n ), it is now ( c -- cstring ), with string at HERE
#                        previous a was pointing into input stream. STREAM was added, providing function of former WORD. new WORD uses STREAM.
#                        added :noname  . bugfix compare .
# 0.53a 20041220 ls trapped Ctrl-C: warm start
# 0.53b 20041220 ls added >body body>
# 0.53c 20041222 ls include appends .bashforth extension and retries if file not found
# 0.54  20050119 ls fixed bug in move
# 0.54a 20050222 ls added ?
# 0.54b 20050331 ls div/0 exception
# 0.55  20060314 ls unhandled exceptions quit, not warmstart, leaving radix untouched
# 0.55a 20061003 lsls removed unnecessary cat in see
# 0.55b 20071220 ls reversed logic in key?
#                changed comparison against empty string to -z test in exception and 2 other
#                speeded up by using [[ or (( instead of [
#                simplified logic here and there
# 0.55c20071223 ls exception accepts literal
# 0.56 20071229 ls line numbers (for doc and see) dont't require info #LINENO per word anymore
#                        changed all function foo { } to  foo() { }
#                        passed command line is executed
#                        string stack underflow detected
#                        string stack emptied on warm and cold
#                        fixed bug in include
#                        string stack operators testing for underflow
#                        first mac debian package
# 0.56a 20071231 ls fix in key (returns ascii for space now)
#                        added nanoseconds, time (measures execution time)
#                        made distance between HERE and PAD a config variable: PADAWAY
#                        tib size configurable too
#                        simplified some logic
#                        changed find to resemble a bit more the standard
#                        using new find in interpreter loop
#                        using printf instead of echo
#                        misc small speedups (or rather, removed a few slowdowns)
# 0.56b intermediate testing speed improvements
# 0.56c 20080114 ls added control characters in output ascii table
#                        using (( cond )) && action where appropriate
#         changing spacing to accommodate fte syntax highlighting better
#         some more arithmetic optimisations
# 0.57 20091005 ls  key?, needs bash 4, waits 1ms. single char buffer,
#                        read by key?, used by key and accept.
# 0.57a 20101022 ls fixed bug in (s") which must have slipped into with
#                          a recent version
#        slight optimisation of abs
# 0.57b 20101101 ls added env, removed "upload" handling, which went into a source file by the same name.
#                          renamed "timestamp" to "epoche"
#                          renamed "merge$" to "append$"
#           attempts to source ~/.bashforthrc, use to set variables:
#                              sources=/path/to/sourcefiles     # "include" reads source files from that dir,
#                                                               # and defaults to current directory if unset.
#                          added "type$"
# 0.57c 20101112 ls simplified exception, and some style improvements sprinkled all over the code
#                          user interrupt (ctrl-c) improved
# 0.57d 20101127 ls removed load and loadfrom. reversed logic on -z string tests.
#                          removed -n from string tests.
# 0.58  20101220 ls replaced right$. simpler, shorter, faster
#           changed result generation of key?
#                          bug fix number - may have another, dropping sign with hex -ff
# 0.58a  20110819 ls fixed bug with multiple consecutive revealheader
# 0.58b  20120312 ls multi line compound arithmetic expressions problem with bash 4.2-1 at hash
# 0.58c  20170609 ls A syntax error affecting bash v4.4 was fixed.
#            ASCII to char translation array initialised with char(1) now.
# 0.59   20190806 ls uses $EPOCHSECONDS instead of $(date +%s) for epoche when running under bash 5+
# 0.59a  20190821 ls some more quoting, removed saving IFS contents in key and key?
#                    changed !(( to ! (( to pacify shellcheck.
# 0.60   20190830 ls added restore, restore-from, save-system, saveas, contributed by quaraman-me
#                    type$ didn't drop top string stack element. Fixed
#                    changed output of .s$ to vertical. top of string stack is uppermost output line.
#                    Fixed error in type when outputting % char.
# 0.60a  20190830 ls .s$ autodecrements
# 0.60b  20190830 ls added nlimit, producing highest signed number.
#                    fixed rshift: making it logical right shift while bash does arithmetic right shift.
#                    partially (attempted to fix) sign problem in #
# 0.60c  20190830 ls see prevented from mangling output lines.
# 0.60d  20190830 ls fixed expanding * in restore.
# 0.60e  20190830 ls fixed: number input accepting some non numeric chars. A side effect is that digits > 10 are now case insensitive.
#                    added: 2swap d= sub$
#                    changed: left$ and right$ call sub$, ?number uses (fixed) number
# 0.60f  20190831 ls fixed: wrong number output when outputting a number with only msb set (nlimit+1)
#                    changed (already in a previous version): executing save-system and restore without file name write to/read from $sources directory
# 0.61   20190831 ls functionally reverted to 0.60f, undoing changes to floored modulo and division, causing more damage than benefits
# 0.61a  20190831 ls fixed: (s") bug from 0.57a again, seems to have reinstroduced when reverting.
# 0.62   20190909 ls added: !sourcepath complements sourcepath
#                    changed: set working variables in compare to local
# 0.63   20190909 ls changed: words attempts to break lines
# 0.63a  20201121 ls fixed: exposed one superfluous "epoche" header 
#
#   known bugs:
#     catch:   doesn't return the thrown value correctly sometimes
#     include: max line length in source files isn't checked against TIBSIZE
#     env: without name abort with "invalid variable name"
#     see: doesn't look into included source files
#     /:  while modulo and divison of /mod and */mod are floored,  / isn't.

# global variables:
# ip           virtual machine instruction pointer
# w            virtual machine word pointer.
# sp           data stack pointer
# rp           return stack pointer
# wc           word count, number of headers. used as name field address
# temp         scratch. never used to carry data across words/functions
# tos          top of stack, stack cache
# dp           dictionary pointer, "here". new words are added at this address
# state        compile/interpret switch
# catchframe   pointer to latest frame
# ssp          string stack pointer


# global variable arrays:
# m            memory
# s            data stack
# r            return stack
# h            headers (word names)
# hf           header flags (precedence bit, smudge bit)
# x            execution tokens
# asc          characters array, indexed by decimal ascii
# ss           string stack






################################# example primitive #####################################
# # ( -- ) description  # stack diagram, description
# revealheader "foo"    # name in forth vocabulary
# code foo foo          # name in bash, call of executable
#          --------- executable may follow, but may also be seperated ----------
# foo() {               # executable implementated as function
#    s[++sp]=$tos       # stack push
#    tos=${s[sp--]}     # stack pop
# }                     # empty lines follows
#
#########################################################################################




################################# example hi-level word #####################################
# # ( -- ) description  # stack diagram, description
# revealheader "foo"    # name in forth vocabulary
# colon foo           \ # name in bash. line continuation
#   $word $word $word \ # compiled words, line continuation
#   $word $word         # last line does not need continuation, empty line follows
#
#########################################################################################


#
#
#

# -------------------------------------------------------------------------
# ---                           configuration                           ---
# -------------------------------------------------------------------------
PADAWAY=256                      # distance between HERE and PAD
TIBSIZE=256
PROMPT="ok"
LOADING=""
EDITOR=sensible-editor



# -------------------------------------------------------------------------
# ---                  allocate memory / initialize vars                ---
# -------------------------------------------------------------------------

m=()                             # memory
s=()                             # data stack
r=()                             # return stack
h=()                             # headers, wordcount
hf=()                            # header flags, corresponding to headers
x=()                             # execution tokens, corresponding to headers
ss=()                            # string stack


declare -i ip w                  # instruction and word pointer of virtual machine
declare -i s0=0 sp               # data stack origin and pointer
declare -i r0=0 rp               # return stack origin and pointer
declare -i ss0=0 ssp             # string stack origin and pointer
declare -i dp=0                  # dictionary pointer
declare -i wc=0                  # word count
declare -i state=0               # compiler/interpreter switch
declare -i catchframe=0          # pointer to latest catch frame, or 0

sources="."                      # unless overwritten from .bashforthrc or !sourcepath


# ---- bitmasks ------------------------------------------------------------

# declared as read-only, integer
declare -ri precedencebit=1      # immediate words
declare -ri smudgebit=2          # hide/reveal headers



# --------------- build decimal>ascii lookup table for emit ----------------
asc=()
for i in {1..255}; do
   asc[i]=$(echo -en "\\x$(printf '%x' $i)")  # ascii 0-255
done


# ------------------------------- "macros" ---------------------------------


# --- array of variables and functions which will be removed after the script has been loaded ---
# --- only to use with words which help building bashforth, but aren't required at runtime ---
remove=()

transient()  {
   remove[${#remove[@]}]=$1
}

transient remove              # remove must either be non-transient, or the first transient.
transient transient




transient compile
compile() {
   for nextword in $*
   do
      m[dp++]="${nextword}"
   done
}



transient code
code()  {
   (( $1 = dp ))
   shift
   m[dp++]="$*"
}



dovar()   {
   s[++sp]="$tos"
   tos="$w"
}


transient var
var() {
   (( $1 = dp ))
   compile dovar 0
}



var lastxt

header() {
   m[lastxt+1]=$dp
   x[wc]=$dp
   hf[wc]=0
   h[wc++]="$1"                  # word name
}




reveal() {
   ((hf[wc-1] |= smudgebit))
}


hide() {
   ((hf[wc-1] &= ~smudgebit))
}



transient revealheader
revealheader() {
   ((m[dp++]=BASH_LINENO[0]-1))  # source line number - consider to put file/line into an array with source locations
   header "$1"
   reveal
}


transient semicolon
semicolon() {
   compile "$unnest"
   reveal
}


transient colon
colon()  {
   (( $1 = dp ))
   shift 1
   compile nest
   compile "$*"
   semicolon
}



doconst() {
   s[++sp]=$tos
   tos=${m[w]}
}


transient constant
constant() {
   (( $1 = dp ))
   shift
   compile doconst "$1"
}



dodefer() {  ip=$w; }

transient defer
defer() {
   (( $1 = dp ))
   compile dodefer 0
}





# -----------------------------------------------------------------------------
# -------------------------------- system start -------------------------------
# -----------------------------------------------------------------------------

revealheader ""

# warm start vector
# ( ??? -- ) init stacks and vars, restart interpreter
revealheader "warm"
defer warm



# -------------------------------------------------------------------------
# ---                      ctrl-c: user interrupt                       ---
# -------------------------------------------------------------------------

#trap "echo bashforth finished" EXIT
#trap "echo err" ERR
#trap "echo return" RETURN



ctrl-c() {
   tos=-28
   ip=$warm
   printf '%s\n' " ${throw[-tos]}"
   return 0
}
trap  ctrl-c 2






# -----------------------------------------------------------------------------
# ------------------------------ virtual machine ------------------------------
# -----------------------------------------------------------------------------



nest() {
   r[++rp]=$ip
   ip=$w
}

# ( -- ) exits the current definition. compiled by ;
revealheader "exit"
code unnest unnest
unnest() {
   ip=${r[rp--]}
}


# ----------------------------------------------------------------------------
# --------------------------- constants, variables ---------------------------
# ----------------------------------------------------------------------------

msb=1; until ((msb<0)); do ((msb<<=1)); done


# ( -- -1 )
revealheader "true"
constant minone -1

# ( -- -1 )
revealheader "-1"
constant minone -1


# ( -- 0 )
revealheader "false"
constant zero 0

# ( -- 0 )
revealheader "0"
constant zero 0


# ( -- 1 )
revealheader "cell"
constant one 1

# ( -- 1 )
revealheader "1"
constant one 1


# ( -- 2 )
revealheader "2"
constant two 2


# ( -- 3 )
revealheader "3"
constant three 3


# ( -- 4 )
revealheader "4"
constant four 4


# ( -- 5 )
revealheader "5"
constant five 5


# ( -- 6 )
revealheader "6"
constant six 6


# ( -- 27 ) ASCII of Escape char
revealheader "esc"
constant esc 27


# ( -- 32 ) ASCII of space char
revealheader "bl"
constant bl 32


# ( -- x ) highest signed number
revealheader "nlimit"
constant nlimit $((msb-1))


# ( -- a )
revealheader ">in"
var in


# ( -- a ) flags/switches interpret/compile mode
revealheader "state"
var state


# ( -- a ) variable, pointing to cfa of last word
revealheader "last"
constant last $((lastxt+1))


# ( -- a ) a memory area, relative to here, for user purposes
revealheader "tib"
var tib
   ((dp+=TIBSIZE))


# ( -- a ) variable containing the input and output radix
revealheader "base"
var base




# ----------------------------------------------------------------------------
# ------------------------------- run time -----------------------------------
# ----------------------------------------------------------------------------




# ( -- ) run time word - to be compiled by another word
revealheader "branch"
code branch branch
branch() {   ((ip+=m[ip])); }


# ( f -- ) run time word - to be compiled by another word
revealheader "0branch"
code branch0 branch0
branch0() {
   if ((tos)); then
      ((ip++))
   else
      ((ip+=m[ip]))
   fi
   tos=${s[sp--]}
}



# ( f -- ) run time word - compiled internally instead of  0= branch0
code branchx branchx
branchx() {
   if ((tos)); then
      ((ip+=m[ip]))
   else
      ((ip++))
   fi
   tos=${s[sp--]}
}




# ( -- x ) when compiled into a word, the contents of the cell under $ip are pushed to stack and skipped from execution
revealheader "lit"
code lit lit
lit() {
   s[++sp]=$tos
   tos=${m[ip++]}
}


# ( a n -- x ) assembles asciis at m[a] to string in tos
revealheader "pack"
code pack pack
pack() {
   i=$tos
   temp=${s[sp--]}
   unset tos
   while ((i--)); do
      tos+="${asc[m[temp++]]}"
   done
}


#pack() {
#   temp="${s[sp--]}"
#   temp2=$tos
#   tos="$(printf '\x0' $(printf '%x' "${m[@]:temp:temp2}"))"
#   echo ">>> $tos <<<"
#   printf '\x0%x ' "${m[@]:temp:temp2}"
#}




# ( x a -- n ) unpacks string x to ascii ordinals at a
revealheader "unpack"
code unpack unpack
unpack() {
   local string=${s[sp--]}
   len=${#string}
   ((dest=tos+len))
   tos=$len
   for ((; len; len-- )); do
      m[--dest]=$(printf '%d' "'${string:len-1:1}")
   done
}




# ( -- a c ) run time word - to be compiled by s"
revealheader '(s")'
code dosquote dosquote
dosquote() {
   s[++sp]=$tos
   tos=${m[ip++]}
   s[++sp]=$ip
   ((ip+=tos))
}



# ( -- ) run time word - to be compiled by ."
revealheader '(.")'
code dodotquote dodotquote
dodotquote() {
   dosquote
   pack
   printf '%s' "$tos"
   tos=${s[sp--]}
}



# ( limit start -- ) run time word - to be compiled by for
revealheader "(for)"
code dofor dofor
dofor() {
   r[++rp]=$tos
   r[++rp]=$tos
   tos=${s[sp--]}
   ((ip++))
}


# ( -- ) run time word - to be compiled by next
revealheader "(next)"
code donext donext
donext() {
   ((r[rp]--))
   if ((r[rp])); then
      ((ip+=m[ip]))
   else
      ((ip++, rp-=2))
   fi
}




# ( limit start -- ) run time word - to be compiled by do
revealheader "(do)"
code dodo dodo
dodo() {
   r[++rp]=${s[sp--]}
   r[++rp]=$tos
   ((ip++))
   tos=${s[sp--]}
}



# ( limit start -- ) run time word - to be compiled by ?do
revealheader "(?do)"
code doqdo doqdo
doqdo() {
   if (( tos == s[sp] )); then
      ((sp--))
      ((ip+=m[ip]))
   else
      r[++rp]=${s[sp--]}
      r[++rp]=$tos
      ((ip++))
   fi
   tos=${s[sp--]}
}



# ( -- ) run time word - to be compiled by leave
revealheader "(leave)"
code doleave doleave
doleave() {
   ((rp-=2))
   ip=${m[ip]}
   ((ip+=m[ip]))
}



# ( -- ) run time word - to be compiled by ?leave
revealheader "(?leave)"
code doqleave doqleave
doqleave() {
   if ((tos)); then
      doleave
   else
      ((ip++))
   fi
   tos=${s[sp--]}
}





# ( -- ) run time word - to be compiled by loop
revealheader "(loop)"
code doloop doloop
doloop() {
  ((r[rp]++))
   if ((r[rp] - r[rp-1])); then
      ((ip += m[ip]))
   else
      ((ip++, rp -= 2))
   fi
}



# ( -- ) run time word - to be compiled by +loop
revealheader "(+loop)"
code doplusloop doplusloop
doplusloop() {
   ((temp = r[rp] - r[rp-1],
   r[rp] += tos,
   tos = s[sp--]))
   if (( (temp ^ (r[rp] - r[rp-1])) > 0 )); then
      ((ip += m[ip]))
   else
      (( ip++, rp -= 2 ))
   fi
}


# ( ? xt -- ? )
revealheader "execute"
code execute execute
execute() {
   w=$tos
   tos=${s[sp--]}
   ${m[w++]}
}

# -----------------------------------------------------------------------------
# ------------------------------ stack operators ------------------------------
# -----------------------------------------------------------------------------


# ( -- n ) returns number stack elements on data stack
revealheader "depth"
code depth depth
depth() {
   s[++sp]=$tos
   ((tos=sp-s0-1))
}




# ( x -- x x ) duplicate top stack element
revealheader "dup"
code dup dup
dup() {  s[++sp]=$tos; }




# ( x1 x2 -- x1 x2 x1 x2 ) duplicate top two stck elements
revealheader "2dup"
code dup2 dup2
dup2() {
   s[++sp]=$tos
   s[++sp]=${s[sp-1]}
}



# ( 0 -- 0 )  ( x -- x x ) duplicate top stack element only if it is not zero
revealheader "?dup"
code qdup qdup
qdup() {
   ((tos)) && s[++sp]=$tos
}




# ( x -- ) discard top stack element
revealheader "drop"
code drop drop
drop() {
   tos=${s[sp--]}
}




# ( x1 x2 -- ) discard top two stack elements
revealheader "2drop"
code drop2 drop2
drop2() {
   ((sp--))
   tos=${s[sp--]}
}




# ( x1 x2 -- x2 x1 ) swap the top two stack elements with each other
revealheader "swap"
code swap swap
swap() {
   temp=$tos
   tos=${s[sp]}
   s[sp]=$temp
}



# ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) swap top 2 stack items against 3rd and 4th of stack
revealheader "2swap"
code swap2 swap2
swap2() {
   temp=${s[sp-1]}
   s[sp-1]=$tos
   tos=$temp
   temp=${s[sp-2]}
   s[sp-2]=${s[sp]}
   s[sp]=$temp
}



# ( x1 x2 -- x1 x2 x1 ) push copy of second stack element to top
revealheader "over"
code over over
over() {
   s[++sp]=$tos
   tos=${s[sp-1]}
}


# ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) copy 3rd and 4th stack item to stack top
revealheader "2over"
code over2 over2
over2() {
   s[++sp]=$tos
   tos=${s[sp-3]}
   s[++sp]=$tos
   tos=${s[sp-3]}
}


# ( x1 x2 -- x2 ) discard second stack element
revealheader "nip"
code nip nip
nip() {
   ((sp--))
}




# ( x1 x2 -- x2 x1 x2 ) insert a copy of top of stack under second stack element
revealheader "tuck"
code tuck tuck
tuck() {
   temp=${s[sp]}
   s[sp]=$tos
   s[++sp]=$temp
}



# ( x1 x2 x3 -- x2 x3 x1 ) rotate third stack element to top
revealheader "rot"
code rot rot
rot() {
   temp=${s[sp]}
   s[sp]=$tos
   tos=${s[sp-1]}
   s[sp-1]=$temp
}





# ( x1 x2 x3 -- x3 x1 x2 ) rotate top stack element under second stack element
revealheader "-rot"
code minrot minrot
minrot() {
   temp=${s[sp-1]}
   s[sp-1]=$tos
   tos=${s[sp]}
   s[sp]=$temp
}



# ( ... x2 x1  x0 n -- xn ) place a copy of stack element n on top of stack
revealheader "pick"
code pick pick
pick() {  tos=${s[sp-tos]}; }



# ( ... x2 x1  x0 n -- ... x2 x1 x0 xn  ) rotate stack element n to top of stack
revealheader "roll"
code roll roll
roll() {
   temp=${s[sp-tos]}
   for ((; tos; --tos)); do
      s[sp-tos]=${s[sp-tos+1]}
   done
   ((sp--))
   tos=$temp
}



# ( x -- ) moves top of data stack to return stack
revealheader ">r"
code to_r to_r
to_r() {
   r[++rp]=$tos
   tos=${s[sp--]}
}




# ( -- x ) moves top of return stack to data stack
revealheader "r>"
code r_from r_from
r_from() {
   s[++sp]=$tos
   tos=${r[rp--]}
}




# ( -- x ) copies top of return stack to data stack
revealheader "r@"
code r_fetch r_fetch
r_fetch() {
   s[++sp]=$tos
   tos=${r[rp]}
}




# ( -- ) drops top of return stack
revealheader "rdrop"
code rdrop rdrop
rdrop() {
   ((rp--))
}




# ( x1 x2 -- ) moves top two data stack elements to return stack
revealheader "2>r"
code twoto_r twoto_r
twoto_r() {
   r[++rp]=$tos
   r[++rp]=${s[sp--]}
   tos=${s[sp--]}
}




# ( -- x1 x2 ) moves top two return stack elements to data stack
revealheader "2r>"
code twor_from twor_from
twor_from() {
   s[++sp]=$tos
   s[++sp]=${r[rp--]}
   tos=${r[rp--]}
}




# ( -- x ) returns index of innermost loop
revealheader "i"
code i r_fetch



# ( -- x ) returns index of innermost loop
revealheader "j"
code j j
j() {
   s[++sp]=$tos
   tos=${r[rp-2]}
}


# -----------------------------------------------------------------------------
# ------------------------------- catch / throw -------------------------------
# -----------------------------------------------------------------------------



throw[1]="terminated"
throw[2]="aborted"
throw[3]="stack overflow"
throw[4]="stack underflow"
throw[5]="return stack overflow"
throw[6]="return stack underflow"
throw[7]="do loops nested too deeply"
throw[8]="dictionary overflow"
throw[9]="invalid memory address"
throw[10]="division by zero"
throw[11]="result out of range"
throw[12]="argument type mismatch"
throw[13]=" not found"
throw[14]="use only during compilation"
throw[15]="invalid forget"
throw[16]="attempt to use zero-length string as name"
throw[17]="pictured numeric ouput string overflow"
throw[18]="pictured numeric ouput string overflow"
throw[19]="word name too long"
throw[20]="write to a read-only location"
throw[21]="unsupported operation"
throw[22]="unstructured"
throw[23]="address alignment exception"
throw[24]="invalid numeric argument"
throw[25]="return stack imbalance"
throw[26]="loop parameters unavailable"
throw[27]="invalid recursion"
throw[28]="user interrupt"
throw[29]="compiler nesting"
throw[30]="obsolescent feature"
throw[31]=">BODY used on non-CREATEd definition"
throw[32]="invalid name argument"
throw[38]="file not found"
throw[65]="string stack underflow"


# throw without catch frame - top level error handler
code exception exception
exception() {
   (( $tos == -1 )) && exit				# exception one terminates interpreter. other exceptions are dealt with within
   local message="caught $tos"
   ((tos<0)) && message="${throw[-tos]:-$message}"
   printf '%s\n' "$message"
   if ((proceed)); then
      ip=$proceed
      start
   fi
}




code throw0 throw0
throw0() {
   catchframe=${r[rp]}
   sp=${r[--rp]}
   ip=${r[--rp]}
   tos=0
   (( rp-- ))
}
brthrow0=$throw0



# ( a -- n ) part of catch / throw exception handling mechanism
revealheader "catch"
code catch catch
catch() {
   r[++rp]=$ip
   r[++rp]=$sp
   r[++rp]=$catchframe
   catchframe=$rp
   r[++rp]=$brthrow0
   execute
}


# ( n -- ) part of catch / throw exception handling mechanism
revealheader "throw"
defer throw

code realthrow realthrow
realthrow() {
   if ((tos)); then
      if ((catchframe)); then
         rp=$catchframe
         catchframe=${r[rp--]}
         sp=${r[rp--]}
         ip=${r[rp--]}
      else
         proceed=$warm
         exception
         echo continue
      fi
   else
      tos=${s[sp--]}
   fi
   echo "--- realthrow [$tos] ---"
   (( tos )) && {
     echo "something fishy with 0 throw"
     proceed=$warm
     exception
   }
}

# when primitives throw exceptions, they can't easily execute
# a deferred word. Current workaround is to let the code entry
# into throwing check whether it is the deferred handler, and
# flowcontrols accordingly.
# Reason for two different handlings: when interpreting command line,
# errors need to terminate rather than warmstart the interpreter.
code codethrow codethrow
codethrow() {
   : "${tos:=0}"
   if [[ ${m[throw+1]} == $codethrow ]]; then
      printf '\n'
      proceed=0
      (( tos )) && {
         exception
      }
      exit "${tos#-}"
   fi
   realthrow
}
m[throw+1]="$codethrow"



# ( -- ) throw exception -2
revealheader "abort"
colon abort            $lit  -2 $throw

colon stackunderflow   $lit  -4 $throw
colon invalidaddr      $lit  -9 $throw
colon notfound         $lit -13 $throw
colon compileonly      $lit -14 $throw
colon unsupported      $lit -21 $throw
colon unstruc          $lit -22 $throw
colon invalidarg       $lit -24 $throw
colon nolooppars       $lit -26 $throw
colon filenotfound     $lit -38 $throw




# -----------------------------------------------------------------------------
# -------------------------------- arithmetic ---------------------------------
# -----------------------------------------------------------------------------


# ( n1 -- n2 ) increment top of stack by one
revealheader "1+"
code oneplus oneplus
oneplus() {
   ((tos++))
}




# ( n1 -- n2 ) increment top of stack by cell
revealheader "cell+"
code cellplus oneplus




# ( n1 -- n2 ) increment top of stack by two
revealheader "2+"
code twoplus twoplus
twoplus() {
   ((tos+=2))
}




# ( n1 -- n2 ) decrement top of stack by one
revealheader "1-"
code oneminus oneminus
oneminus() {
   ((tos--))
}




# ( n1 n2 -- n3 ) add top two stack elements together, leave result
revealheader "+"
code plus plus
plus()  {
   ((tos+=s[sp--]))
}




# ( n1 n2 -- n3 ) subtract tos from nos, leave result
revealheader "-"
code minus minus
minus()  {
   ((tos =s[sp--]-tos))
}




# ( n -- u ) remove sign
revealheader "abs"
code abs abs
abs()  {
   (( tos < 0 )) && (( tos *= -1 ))
#   tos=${tos#-}
}




# ( n1 n2 -- n3 ) multiply top two numbers, leave result
revealheader "*"
code mul mul
mul()  {
   ((tos*=s[sp--]))
}




# ( n1 u -- n2 ) calculate power of n1 ** u, leave result
revealheader "**"
code power power
power()  {
   ((tos=s[sp--]**tos))
}



divzero() {
   tos=-10
   codethrow
}



# ( n1 n2 n3 -- n4 n5 ) multiply n1 with n2, divide by n3, returning remainder n4 and quotient n5
revealheader "*/mod"
code starslashmod starslashmod
starslashmod()  {
   ((tos)) || divzero
   ((temp=s[sp--]*s[sp],
   s[sp]=temp%tos,
   tos=temp/tos))
}

#   ((tos)) || divzero
#   (( temp = s[sp--] * s[sp] ))
#   (( temp2 = tos ))
#   (( s[sp] = temp % tos ))
#   (( tos = temp / tos ))
#   if (( tos < 0 )); then
#      (( tos-- ))
#      (( s[sp] += temp2 ))
#   fi
#}


# ( n1 n2 -- n3 ) return remainder of n1/n2
revealheader "mod"
code mod mod
mod()  {
   ((tos)) || divzero
   ((tos=s[sp--]%tos))
}

#   ((tos=(s[sp--]%tos+tos)%tos))




# ( n1 n2 -- n3 n4 ) return remainder n3 and quotient n4 of n1/n2
revealheader "/mod"
code slashmod slashmod
slashmod()  {
   ((tos)) || divzero
   ((temp=s[sp],
   s[sp]=temp%tos,
   tos=temp/tos))
}

#   ((tos)) || divzero
#   (( temp = s[sp] ))
#   (( temp2 = tos ))
#   (( s[sp] = temp % tos ))
#   (( tos = temp / tos ))
#   if (( tos < 0 )); then
#      (( tos-- ))
#      (( s[sp] += temp2 ))
#   fi




# ( n1 n2 -- n3 ) divide n1 by n2, return result
revealheader "/"
code div div
div()  {
   ((tos)) || divzero
   ((tos=s[sp--]/tos))
}



# ( n1 n2 n3 -- n4 ) multiply n1 with n2, divide by n3
revealheader "*/"
code starslash starslash
starslashmod()  {
   ((tos)) || divzero
   ((tos=s[sp--]*s[sp--]/tos))
}

#   ((tos)) || divzero
#   (( temp = s[sp--] * s[sp] ))
#   (( temp2 = tos ))
#   (( tos = temp / tos ))
#   if (( tos < 0 )); then
#      (( tos-- ))
#   fi



# ( u1 n -- u2 ) shift right u1 by n
revealheader "rshift"
code rshift rshift
rshift()  {
   ((tos=(s[sp--]>>tos) & ~msb))
}


# ( u1 n -- u2 ) shift left u1 by n
revealheader "lshift"
code lshift lshift
lshift()  {
   ((tos="s[sp--]<<tos"))  # quotes defeat faulty syntax highlighting
}



# ( n1 -- n2 ) multiply n1 by 2, implemented as (quicker) shift left by 1
revealheader "2*"
code mul2 mul2
mul2()  {  (("tos<<=1")); }  # quotes help syntax hilighting of editor joe from getting confused



# ( n1 -- n2 ) divide n1 by 2, imeplemented as (quicker) shift right by 1
revealheader "2/"
code div2 div2
div2()  {  ((tos>>=1)); }




# ( n1 -- n2 ) reverse sign of n1
revealheader "negate"
code negate negate
negate()  {  ((tos=-tos)); }




# ( n1 n2 -- n1|n2 ) return the smaller one of two numbers
revealheader "min"
code min min
min() {
   temp=${s[sp--]}
   ((tos>temp)) && tos=$temp
}




# ( n1 n2 -- n1|n2 ) return the greater one of two numbers
revealheader "max"
code max max
max() {
   ((temp=s[sp--]))
   ((tos<temp)) && ((tos=temp))
}








# -----------------------------------------------------------------------------
# ---------------------------- arithmetic compare  ----------------------------
# -----------------------------------------------------------------------------



# ( x1 x2 -- flag ) compare top two stack elements, return true if equal, false otherwise
revealheader "="
code equ equ
equ() { tos=$((-(tos==s[sp--]))); }




# ( x1 x2 -- flag ) compare top two stack elements, return true if unequal, false otherwise
revealheader "<>"
code nequ nequ
nequ() { tos=$((-(tos!=s[sp--]))); }



# ( x -- flag ) compare top stack element with zero, return true if equal, false otherwise
revealheader "0="
code equ0 equ0
equ0() { tos=$((-(tos==0))); }



# ( x -- flag ) return true if top element is less than 0, false otherwise
revealheader "0<"
code less0 less0
less0() {  tos=$((-(tos<0))); }



# ( n1 n2 -- flag ) return true if second stack element is smaller than top element, false otherwise
revealheader "<"
code less less
less() { tos=$((-(s[sp--]<tos))); }



# ( n1 n2 -- flag ) return true if second stack element is greater than top element, false otherwise
revealheader ">"
code greater greater
greater() { tos=$((-(s[sp--]>tos))); }


# ( x1 x2 x3 x4 -- flag ) compare x1,x2 with x3,x4, return true if equal, false otherwise
revealheader "d="
code dequ dequ
dequ() {
   tos=$((-(tos==s[sp-1] & s[sp]==s[sp-2])))
   ((sp-=3))
}


# -----------------------------------------------------------------------------
# ----------------------------------- bool ------------------------------------
# -----------------------------------------------------------------------------


# ( x1 x2 -- x3 ) bitwise and of top two stack elements
revealheader "and"
code and and
and() { ((tos&=s[sp--])); }



# ( x1 x2 -- x3 ) bitwise or of top two stack elements
revealheader "or"
code or or
or() { ((tos|=s[sp--])); }




# ( x1 x2 -- x3 ) bitwise xor of top two stack elements
revealheader "xor"
code xor xor
xor() { ((tos^=s[sp--])); }




# ( x1 -- x2 ) invert all bits of top stack elements
revealheader "invert"
code invert invert
invert() { ((tos=~tos)); }



# -----------------------------------------------------------------------------
# ------------------------ number conversion and i/o --------------------------
# -----------------------------------------------------------------------------



# alternative implementation. different stack effect. if conversion fails, n
# is the number of character not converted. x is the accumulated values of all
#  legal digits up to the offending one
# ( a n -- x 0 | x n ) try to convert n chars at a to number, respecting base
revealheader "number"
code number number
number() {
   local digit sign=0 radix=${m[base+1]}
   (( src = s[sp] ))                      # addr of next digit
   (( s[sp] = 0 ))                        # accumulator
   (( m[src] == 45 )) &&
      (( sign = -1 , src++ , tos-- ))     # strip leading -
   for ((; tos; tos-- )); do              # for all digits
      (( digit=m[src++]-48 ))             # read ascii of digit, convert to numeric
      (( digit < 0 )) && break            # flag chars below 0 as invalid numbers
      (( digit > 9 )) &&  {               # chars above 9 need more attention
         (( digit -= 7 ))                 # convert A... to numeric
         (( digit < 10 )) && break        # flag :...@ as invalid numbers
         (( digit >= 36 )) && {           # chars above Z need more attention
            (( digit -= 32 ))             # convert a... to numeric
            (( digit < 10 )) && break     # flag [...' as invalid numbers
         }
      }
      (( digit >= radix )) && break       # flag chars as invalid number"
      (( s[sp]=s[sp]*radix+digit ))
   done
   (( sign )) && (( s[sp] = -s[sp] ))
}


# conversion with standard stack effect. Uses alternative implementation now.
# ( a n -- x -1 | 0 ) try to convert n chars at a to number, respecting base
revealheader "?number"
colon qnumber  $number $equ0 $qdup $drop



# ( n -- 0 n f ) start pictured number conversion
revealheader "<#"
code lesshash lesshash
lesshash() {
   ((s[++sp]=0))
   if ((tos<0)); then
      ((s[++sp]=-tos, tos=-1))
   else
      ((s[++sp]=tos, tos=0))
   fi
}


# problem with bash 4.2-1:  comma delimited compound arithmetic expressions would segfault
# ( n1 n2 f -- c n3 n4 f  ) pictured number conversion: convert a single digit
revealheader "#"
code hash hash
hash() {
   local radix=${m[base+1]}
   r[++rp]=$tos
   ((r[++rp]=s[sp]/radix))
   ((tos=s[sp--]%radix))
   ((tos<0)) && ((tos*=-1))
   ((tos+=48))
   ((tos>57)) && ((tos+=39))
   s[sp+1]=$((s[sp]+1))
   s[sp++]=$tos
   s[++sp]=${r[rp--]}
   tos=${r[rp--]}
}




# ( n1 n2 f -- ??? n3 n4 f ) pictured number conversion: convert remaining digits
revealheader "#s"
code hashs hashs
hashs() {
   hash
   while ((s[sp])); do
      hash
   done
}




# ( n1 n2 f c -- c n3 n4 f  ) pictured number conversion: insert a specified character
revealheader "hold"
code hold hold
hold() {
   temp=${tos}
   tos=${s[sp]}
   s[sp]=${s[sp-1]}
   s[sp-1]=$((s[sp-2]+1))
   s[sp-2]=${temp}
}



# ( n1 n2 f -- c n3 n4 f  ) pictured number conversion: insert minus sign if converted number is negative
revealheader "sign"
code sign sign
sign() {
   ((tos)) || return
   twoto_r
   ((tos++))
   s[++sp]=45
   twor_from
}




# ( ??? n1 n2 f -- a n3 ) pictured number conversion: end conversion, leaving number, converted to string
revealheader "#>"
code hashgreater hashgreater
hashgreater() {
   ((sp--))
   tos=${s[sp--]}
   i=$tos
   dest=$((dp+PADAWAY-tos))
   temp=$dest
   while ((i--)); do
      m[dest++]=${s[sp--]}
   done
   s[++sp]=$temp
}




# ( n1 -- ) pictured number conversion: output the string to which number has been converted
revealheader "#>type"
code hashgreatertype hashgreatertype
hashgreatertype() {
   ((sp--))
   for ((i=s[sp--]; i; --i)); do
      printf '%s' "${asc[${s[sp--]}]}"
   done
   tos=${s[sp--]}
}




# -----------------------------------------------------------------------------
# ------------------------------------ i/o ------------------------------------
# -----------------------------------------------------------------------------




# ( c -- ) output the character which ascii is on top of stack
revealheader "emit"
code emit emit
emit() {
   printf '%s' "${asc[tos]}"
   tos="${s[sp--]}"
}



# ( -- ) output a space character
revealheader "space"
code space space
space() {
   printf '%1s' " "
}


# ( n -- ) output spaces
revealheader "spaces"
code spaces spaces
spaces() {
   printf "%${tos}s"
   tos="${s[sp--]}"
}



# ( -- ) clear screen
revealheader "page"
code page clear

# ( -- ) clear screen
revealheader "cls"
code cls clear



# ( a n -- ) output the string, which address and len are given on stack
revealheader "type"
code type type
type() {
   pack
   printf '%s' "$tos"
   tos="${s[sp--]}"
}



# ( -- ) output a line feed
revealheader "cr"
code cr printf '\n'





# ( n -- ) raw output of tos. does not respect base, but can output string in tos.
revealheader ".."
code dotdot dotdot
dotdot() {
   printf '%s ' "$tos"
   tos="${s[sp--]}"
}



# ( n -- ) output the signed number in tos, respecting base
revealheader "."
colon dot      $lesshash $bl $hold $hashs $sign $hashgreatertype



keybuf=""
# ( -- c )  0 or (immediately) ascii of keystroke
# would need to stuff ascii into a key buffer, read by key
revealheader "key?"
code keyq keyq
keyq() {
   [[ -z $keybuf ]] &&
      IFS="" read -rsn1 -t0.001 keybuf
   s[++sp]="$tos"
   tos=$(((${#keybuf}==0)-1))
}


# key: ( -- c ) read one char from input, return ascii
revealheader "key"
code key key
key() {
   s[++sp]="$tos"
   [[ -z $keybuf ]] &&
      IFS="" read -rsn1 keybuf
   tos=$(printf '%d' "'$keybuf")
   keybuf=""
}




# ( a n1 -- n2 ) read n1 chars from input, store at a. number of actually entered chars returned as n2
revealheader "accept"
code accept accept
accept() {
   printf '%s' "$keybuf"
   read -ersn "$tos" buffer
   tos="${keybuf}${buffer}"
   keybuf=""
   swap
   unpack
}



# ( c -- a n ) read word, delimited by c, from input stream. return address and len
revealheader "stream"
code stream stream
stream() {
   local delimiter=$tos temp=${m[in+1]}
   char=${m[temp]}
   if ((delimiter==32)); then
      char=${m[temp]}
      while ((char!=255)); do
        ((char!=delimiter)) && break
        ((temp++))
        char=${m[temp]}
      done
   fi
   s[++sp]=$temp
   tos=-$temp
   while ((char!=255)); do
     ((char==delimiter)) && break
     ((temp++))
     char=${m[temp]}
   done
   ((tos+=temp))
   ((char!=255)) && ((temp++))
   m[in+1]=$temp
}



# ( -- ) output the prompt
revealheader "prompt"
code prompt prompt
prompt() {
   if ((!m[state+1])); then
      printf '%s' " $PROMPT"
      for ((i=sp-s0; i; i--)); do
         printf '%s' "."
      done
      printf '%b' "\\n"
   fi
}


# ( -- ) show numbers on stack
revealheader ".s"
code dot_s dot_s
dot_s() {
   if ((sp)); then
      temp=$s0
      while ((sp>++temp)); do
         printf '%s' "${s[temp+1]} "
      done
      printf '%s' "$tos "
   fi
}




# ( -- ) exit bashforth, return to calling program of command line
revealheader "bye"
code bye exit









# -----------------------------------------------------------------------------
# ------------------------------- dictionary  ---------------------------------
# -----------------------------------------------------------------------------



# ( -- ) modify header of most recently defined word to keep it from being found
revealheader "hide"
code hide hide



# ( -- ) set most recent word "findable"
revealheader "reveal"
code reveal reveal



# ( a n -- ) create a new header with name identical to string passed on stack
revealheader "newheader"
code newheader newheader
newheader() {
   pack
   header $tos
   tos=${s[sp--]}
}



# ( xt -- a ) given xt, return word body address
revealheader ">body"
code tobody oneplus


# ( a -- xt ) given word body address, return xt
revealheader "body>"
code bodyfrom oneminus


# ( xt -- wordnum ) returns word number or 0, opposite of name>.
revealheader ">name"
code toname toname
toname() {
   temp=$wc
   while ((temp)); do
      ((tos==x[--temp])) && break
   done
   tos=$temp
}



# ( wordnum -- xt ) calculate code field address from word number
revealheader "name>"
code name_from name_from
name_from() {  tos=${x[tos]}; }



# ( wordnum -- a n ) return string with name of word, given word number
revealheader "name"
code name name
name() {
   s[++sp]=$dp
   s[++sp]=${h[tos]}
   tos=$dp
   unpack
}



# ( wordnum --  ) output word name, given word number ("nfa")
revealheader ".name"
code dotname dotname
dotname() {
   printf '%s' "${h[tos]}"
   tos=${s[sp--]}
}



# ( word# -- flag ) return true flag if word, specified by word number ("nfa"), is an immediate word
revealheader "?immediate"
code qimm qimm
qimm() {
   ((tos=hf[tos]&precedencebit))
}



# ( -- ) make most recently defined word an immediate word
revealheader "immediate"
code immediate immediate
immediate() {
   ((hf[wc-1]|=precedencebit))
}




# ( a n -- namefield | 0 ) returns 0 or word number of word which name is given as string on stack
revealheader "locate"
code locate locate
locate() {
   pack
   temp=$wc
   while ((temp)); do
      if ((hf[--temp] & smudgebit)); then
         [[ "$tos" == "${h[temp]}" ]] && break
      fi
   done
   tos=$temp
}



# ( -- ) show list of words in vocabulary
revealheader "words"
code words words
words() {
   (( COLUMNS )) || clear                                         # initialize COLUMNS is necessary
   local out=0
   local len
   for ((i=wc; i--;)); do
      len=$(( ${#h[i]}+2 ))
      (( out += len ))
      if (( out >= COLUMNS )); then
         printf '\n%s' "${h[i]}  "
         out=$len
      else
         printf '%s' "${h[i]}  "
      fi
   done
}




# -----------------------------------------------------------------------------
# ------------------------------ compilation ----------------------------------
# -----------------------------------------------------------------------------


# ( x -- )
revealheader ","
code comma comma
comma() {
   m[dp++]="$tos"
   tos="${s[sp--]}"
}


# ( c -- ) compile an 8-bit number to memory at "here"
revealheader "c,"
code ccomma ccomma
ccomma() {
   ((m[dp++]=tos&255))
   tos="${s[sp--]}"
}




# ( -- ) turns compilation off
revealheader "["
code leftbracket leftbracket
leftbracket() {
   m[state+1]=0
}
immediate




# ( -- ) turns compilation on
revealheader "]"
code rightbracket rightbracket
rightbracket() {  m[state+1]=-1; }



# ( n -- ) statically reserve n memory locations
revealheader "allot"
code allot allot
allot() {
   ((dp+=tos))
   tos=${s[sp--]}
}



# ( -- a ) returns end-of-code address
revealheader "here"
code here here
here() {
   s[++sp]=$tos
   tos=$dp
}




# -----------------------------------------------------------------------------
# ----------------------------------- mem -------------------------------------
# -----------------------------------------------------------------------------


# ( a -- x ) read and return contents of address
revealheader "@"
code fetch fetch
fetch() {  tos="${m[tos]}"; }


# ( a -- ) output the contents of address a as signed number.
revealheader "?"
colon dot      $fetch $dot



# ( x a -- ) store x into memory address a
revealheader "!"
code store store
store() {
   m[tos]=${s[sp--]}
   tos=${s[sp--]}
}



# ( a -- c ) read and return 8 bits from memory address a
revealheader "c@"
code cfetch cfetch
cfetch() {
   ((tos=m[tos]&255))
}



# ( c a -- ) write 8 bits to memory at address a
revealheader "c!"
code cstore cstore
cstore() {
   ((m[tos]=s[sp--]&255))
   tos=${s[sp--]}
}



# ( a1 -- a2 c ) a1+1 -> a2,  [a1] -> c
revealheader "count"
code count count
count() {
   ((s[++sp]=tos+1,
   tos=m[tos]&255))
}



# ( a1 -- a2 x ) a1+cell -> a2,  [a1] -> x
revealheader "skim"
code skim skim
skim() {
   ((s[++sp]=tos+1,
   tos=m[tos]))
}



# ( a -- x1 x2 ) fetch two cells from a
revealheader "2@"
colon twofetch   $skim $swap $fetch


# ( x1 x2 a -- ) store cells at a
revealheader "2!"
colon twostore   $tuck $cellplus $store $store




# ( n a -- ) add n to contents of memory att a
revealheader "+!"
code plusstore plusstore
plusstore() {
   ((m[tos]+=s[sp--]))
   tos=${s[sp--]}
}




# ( x1 a -- x2 ) read x2 from a, then store x1 in a
revealheader "exchange"
code exchange exchange
exchange() {
   temp=${m[tos]}
   m[tos]=${s[sp--]}
   tos=$temp
}



# ( a n1 c -- n2 ) search for c in string a n1. n2 is len of remainder, including first c
revealheader "scan"
code scan scan
scan() {
   temp=$tos
   tos=${s[sp--]}
   dest=${s[sp--]}
   while ((tos)); do
      [[ "${m[dest++]}" == "$temp" ]] && break
   ((tos--))
   done
}



# ( a n1 c -- n2 ) skip all leading c in atring a n1. n2 is len of remainder
revealheader "skip"
code skip skip
skip() {
   temp=$tos
   tos=${s[sp--]}
   dest=${s[sp--]}
   while ((tos)); do
      [[ "${m[dest++]}" == "$temp" ]] || break
   ((tos--))
   done
}





# ---------- compare   is a bit dirty, because of quick fix ------------
# compare $tos bytes at  $source and $dest
# result of comparison (-1/0/1) in $tos
compare1() {
   while ((tos)); do
      ((temp=m[source++]-m[dest++]))
      if ((temp)); then
         tos="$(( ((temp > 0) << 1) - 1))"
         break
      fi
      ((tos--))
   done
}

# ( a1 n1 a2 n2 -- -1 | 0 | 1 ) compare two strings at a1 and a2.
revealheader "compare"
code compare compare
compare() {             # n2 in tos
   local dest=${s[sp--]}
   local temp=${s[sp--]}
   local source=${s[sp--]}
   if [[ "$temp" = "$tos" ]]; then
      compare1
   else
      temp2=1
      if [[ $temp < $tos ]]; then
         tos=$temp
         temp2=-1
      fi
      compare1
      if ! ((tos)); then
         tos=$temp2
      fi
   fi
}




# ( a1 n c -- ) fill n memory locations at a1 with c
revealheader "fill"
code fill fill
fill()  {
   i=${s[sp--]}
   dest=${s[sp--]}
   for ((; i; i--)); do
      m[dest++]=$tos
   done
   tos=${s[sp--]}
}




# ( a1 a2 n -- ) move contents of n memory locations at a1 to a2
revealheader "move"
code move move
move()  {
   if  [[ ${s[sp]} > ${s[sp+1]} ]]; then
      ((dest=s[sp--]+tos,
      src=s[sp--]+tos))
      while ((tos--)); do
         m[--dest]=${m[--src]}
      done
   else
      local dest=${s[sp--]}  src=${s[sp--]}
      while ((tos--)); do
         m[dest++]=${m[src++]}
      done
   fi
   tos=${s[sp--]}
}




# ( a1 n a2 -- ) store string a1 n at a2, with leading count byte
revealheader "move$"
code movestr movestr
movestr()  {
   temp=${s[sp]}
   m[tos++]=$temp
   s[sp]=$tos
   tos=$temp
   move
}




# ( a1 n1 n -- a2 n2 ) clip first n chars off string at a1
revealheader "/string"
code slashstring slashstring
slashstring()  {
   temp=$tos
   tos=${s[sp--]}
   if ((tos<temp)); then
      temp=$tos
   fi
   ((s[sp]+=temp, tos-=temp))
}





# ( c -- a n ) read word, delimited by c, from input stream. return address and len
revealheader "word"
colon word        $stream $here $movestr $here





# -----------------------------------------------------------------------------
# ------------------------------ string stack ---------------------------------
# -----------------------------------------------------------------------------


# ( a n -- ) push string at a to string stack
revealheader "push$"
code pushstr pushstr
pushstr() {
   pack
   ss[++ssp]="$stos"
   stos="$tos"
   tos="${s[sp--]}"; }



# ( -- a n ) pop string from string stack to here
revealheader "pop$"
code popstr popstr
popstr() {
   if ((!ssp)); then
      tos=-65; codethrow
   fi
   s[++sp]="$tos"
   tos=$dp
   s[++sp]=$tos
   s[++sp]="$stos"
   stos="${ss[ssp]}"
   ss[ssp--]=""
   unpack
}

# ( stringstack: string -- ) pop and output string from string stack
revealheader "type$"
code typestr typestr
typestr() {
   if ((!ssp)); then
      tos=-65; codethrow
   fi
   printf '%s' "$stos"
   stos="${ss[ssp]}"
   ((ssp--))
}



# ( -- n ) returns number stack elements on string stack
revealheader "depth$"
code depthstr depthstr
depthstr() {
   s[++sp]=$tos
   tos=$((ssp-ss0))
}


# ( -- ) show strings on string stack
revealheader ".s$"
code dot_sstr dot_sstr
dot_sstr() {
   if ((ssp)); then
      printf '%s\n' "$stos "
      temp=$(( ssp ))
      while ((temp > ss0+1)); do
         printf '%s\n' "${ss[temp--]}"
      done
   fi
}




# ( stringstack: str -- str str ) duplicate top string stack element
revealheader "dup$"
code dupstr dupstr
dupstr() {  ss[++ssp]="$stos"; }




# ( stringstack: x1 x2 -- x1 x2 x1 x2 ) duplicate top two elements of stack element
revealheader "2dup$"
code dup2str dup2str
dup2str() {  ss[++ssp]="$stos"  ss[++ssp]="${ss[ssp-1]}"; }




# ( stringstack: x -- ) drop top stringstack element
revealheader "drop$"
code dropstr dropstr
dropstr() {
   if ((!ssp)); then
      tos=-65; codethrow
   fi
   stos="${ss[ssp]}"
   ss[ssp--]=""
}




# ( stringstack: x1 x2 -- x2 x1 ) swap top two string stack elements
revealheader "swap$"
code swapstr swapstr
swapstr() {
   if ((ssp<2)); then
      tos=-65; codethrow
   fi
   temp="$stos"
   stos="${ss[ssp]}"
   ss[ssp]="$temp"
}




# ( stringstack: x1 x2 -- x1 x2 x1 ) copies next-of-stack of string stack to top
revealheader "over$"
code overstr overstr
overstr() {
   if ((ssp<2)); then
      tos=-65; codethrow
   fi
   ss[++ssp]="$stos"
   stos="${ss[ssp-1]}"
}




# ( stringstack: x1 x2 -- x2 ) discards next-of-stack string stack element
revealheader "nip$"
code nipstr nipstr
nipstr() {
   if ((ssp<2)); then
      tos=-65; codethrow
   fi
   ((ssp--))
}




# ( stringstack: x1 x2 x3 -- x2 x3 x1 ) rotate 3rd string stack element to top
revealheader "rot$"
code rotstr rotstr
rotstr() {
   if ((ssp<3)); then
      tos=-65; codethrow
   fi
   temp="${ss[ssp]}"
   ss[ssp]="$stos"
   stos="${ss[ssp-1]}"
   ss[ssp-1]="$temp"
}




# ( stringstack: "string1" "string2" -- "string1string2" ) joins top two strings
revealheader "append$"
code appendstr appendstr
appendstr() {
   if ((ssp<2)); then
      tos=-65; codethrow
   fi
   stos="${ss[ssp--]}$stos"
}


# ( u1 u2 -- )  ( ss: $1 -- $2 )  cut and return string starting at index u1 (zero based) with max length of u2 chars. negative index counts from end of string
revealheader "sub$"
code substr substr
substr()  {
   if ((!ssp)); then
      tos=-65; codethrow
   fi
   temp=${s[sp--]}
   stos="${stos:$temp:$tos}"
   tos=${s[sp--]}
}


# ( u -- ) ( ss: $1 -- $2 ) modifies string so that leading u chars of string remain
revealheader "left$"
colon leftstr   $zero $swap $substr


# ( u -- ) ( ss: $1 -- $2 ) modifies string so that trailing u chars of string remain
revealheader "right$"
colon rightstr   $dup $negate $swap $substr


# ( a n -- ) creates header. expects ascii array type string
revealheader "create$"
code createstr createstr
createstr() {
   newheader
   m[dp++]=dovar
   reveal
}



# -----------------------------------------------------------------------------
# --------------------------------- does> -------------------------------------
# -----------------------------------------------------------------------------


# executed upon execution of word defined by defining word:
# puts body address of defined word on stack, nests into does> action
# ( -- a )
code dodoes dodoes
dodoes() {
   s[++sp]=$tos
   tos=$w
   r[++rp]=$ip
   ip=$1
}



code setdoes setdoes
setdoes() {  m[m[lastxt+1]]="dodoes $((ip+1))"; }




# ( -- ) define run time action of a compiling word
revealheader "does>"
colon does              \
   $lit $setdoes $comma          \
   $lit $unnest  $comma
immediate





start()  {
while w=${m[ip++]}; do ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
      w=${m[ip++]};    ${m[w++]}
done
}









# -----------------------------------------------------------------------------
# ---------------------------- hi-level words ---------------------------------
# -----------------------------------------------------------------------------


# ( ??? -- ) initialize stacks, return to forth command line interpreter
revealheader "quit"
defer quit



# ( a -- ) set cfa of last word to a
revealheader "use"
colon use              $last $fetch $store


# ( -- f ) returns flag, indicating whether bashforth is compiling (-1) or interpreting (0)
revealheader "compiling"
colon compiling     $state $fetch



# ( -- ) throw exception if in intepreting state
revealheader "?comp"
colon qcomp        $compiling $branchx 2 $compileonly


# ( a n -- a n 0 | xt 1 | xt -1 ) search dictionary, returns name and 0 if not found, xt and precedence (1=imm) if found
revealheader "find"
colon findx            \
   $dup2 $locate       \
   $dup $branch0 10    \
      $nip $nip        \
      $dup $name_from  \
      $swap $qimm      \
      $equ0 $one $or   \


# ( x -- ) immediate word which compile top of stack as number into word
revealheader 'literal'
colon literal       $lit $lit $comma $comma
immediate




# ( <stream> -- a ) return execution token of word which name is read from input stream
revealheader "'"
colon tick               \
   $bl $stream $findx    \
   $branchx 3            \
     $type $notfound




# ( <stream> -- ) compile execution token of next word
revealheader "[']"
colon brackettick  $qcomp $tick $literal
immediate



revealheader "postpone"
colon postpone $tick $comma
immediate




# ( -- ) do nothing
revealheader "nop"   ; code nop : ; immediate

# ( n1 -- n2 ) convert cells to number of memory locations
revealheader "cells" ; code cells : ; immediate

# ( n1 -- n2 ) convert chars to number of memory locations
revealheader "chars" ; code chars : ; immediate



# ( -- ) set number base to 16
revealheader "hex"
colon hex          $lit 16 $base $store


# ( -- ) set number base to 10
revealheader "decimal"
colon decimal      $lit 10 $base $store


# ( -- ) set number base to 2
revealheader "binary"
colon binary       $two $base $store


# ( -- a ) return address of a scratch string space
revealheader "pad"
colon pad          $here $lit $PADAWAY $plus


# ( <stream> -- ) create a new header, name read from input stream
revealheader "create"
colon create       $bl $stream $createstr


# ( <stream> -- ) create a variable
revealheader "variable"
colon variable     $create  $zero $comma

# ( <stream> x -- ) create a constant
revealheader "constant"
colon constant     $create $comma $lit doconst $use

# ( <stream> -- ) create new high-level word
revealheader ":"
colon hllcolon     $bl $stream $newheader $lit nest $comma  $rightbracket

revealheader ":noname"
colon colnoname    $here $lit nest $comma  $rightbracket

# ( -- ) finish compilation of a high-level word
revealheader ";"
colon hllsemicolon $lit $unnest $comma $leftbracket $reveal
immediate



# ( a n -- ) compile the string, whose address and len is passed on stack
revealheader ',$'
colon commastr     $here $over $oneplus $allot $movestr


# ( <stream> -- ) compile a string from input stream
revealheader ',"'
colon commaquote   $lit 34 $stream $commastr


# ( <stream> -- ) put address and len of string, delimited by ), interactively on stack
revealheader 's('
colon sbracket     $lit 41 $stream $here $movestr $here $count
immediate


# ( <stream> -- ) compile string from input stream into word, return address and len during run time
revealheader 's"'
colon squote       $qcomp  $lit $dosquote $comma $commaquote
immediate




# ( <stream> -- ) output string from input stream, in interpreting mode
revealheader '.('
colon dotbracket   $lit 41 $stream $type
immediate


# ( <stream> -- ) compile string to high-level word, output string at run time
revealheader '."'
colon dotquote     $qcomp $lit $dodotquote $comma $commaquote
immediate



# ( <stream> -- ) ignore text until ) as comment
revealheader '('
colon bracket      $lit 41 $stream $drop2
immediate


# ( <stream> -- ) ignore rest of line as comment
revealheader '\'
colon backslash    $zero $stream $drop2
immediate

# ( <stream> -- ) ignore rest of line as comment
revealheader '#!'
colon shebang      $zero $stream $drop2
immediate


# ( <stream> -- c ) return ascii of next char on stack
revealheader 'char'
colon brchar         $bl $stream $drop $cfetch
immediate

# ( <stream> -- c ) return ascii of next char on stack, or compile as literal
revealheader '[char]'
colon brchar         $brchar $compiling $branch0 2 $literal
immediate







# -----------------------------------------------------------------------------
# -------------------------------- flow control -------------------------------
# -----------------------------------------------------------------------------


colon structured    $nequ $branch0 2 $unstruc
colon qclause       $lit $branch0 $comma
colon clause        $lit $branch $comma
colon resolve       $here $minus $comma
colon mark          $here $zero  $comma
colon resolveback   $here $over  $minus  $swap $store


# ( f -- ) flow control: true/false if ... else ... then    . else part is optional
revealheader "if"
colon fif           $qcomp $qclause $mark  $one
immediate


# ( -- ) flow control:  true/false if ... else ... then
revealheader "else"
colon felse         $qcomp $one $structured  $clause $mark  $swap $resolveback  $two
immediate


# ( -- ) flow control: true/false if ... else ... then     . else part is optional
revealheader "then"
colon fthen         $qcomp $dup $two $equ $plus $one $structured $resolveback
immediate


# ( -- ) flow control:  begin ... true/false until    or    begin ... true/false while ... repeat
revealheader "begin"
colon fbegin        $qcomp $here  $three
immediate


# ( f -- ) flow control:  begin ... true/false while ... repeat
revealheader "while"
colon fwhile        $qcomp $three $structured  $qclause $mark  $four
immediate


# ( -- ) flow control:  begin ... true/false while ... repeat
revealheader "repeat"
colon frepeat       $qcomp $four $structured   $swap $clause $resolve $resolveback
immediate


# ( -- ) flow control:  begin ... again
revealheader "again"
colon fagain        $qcomp $three $structured  $clause $resolve
immediate


# ( f -- ) flow control:  begin ... true/false until
revealheader "until"
colon funtil        $qcomp $three $structured  $qclause $resolve
immediate

var innerloop


# ( start -- ) flow control:  (limit) for ... next  , counts down
revealheader "for"
colon ffor          $qcomp $lit $dofor $comma     \
                    $here $innerloop $exchange    \
                    $here $zero $comma            \
                    $six
immediate

# ( -- ) flow control:  (limit) for ... next , counts down
revealheader "next"
colon floop         $qcomp $six $structured      \
                    $lit $donext $comma          \
                    $dup $oneplus $resolve       \
                    $resolveback                 \
                    $innerloop $store
immediate





# ( limit start -- ) flow control:  (limit) (start) do ... loop
revealheader "do"
colon fdo           $qcomp $lit $dodo $comma \
                    $here $innerloop $exchange    \
                    $here $zero $comma            \
                    $five
immediate


# ( limit start -- ) flow control:  (limit) (start) ?do ... loop
revealheader "?do"
colon fqdo          $qcomp $lit $doqdo $comma \
                    $here $innerloop $exchange     \
                    $here  $zero $comma            \
                    $five
immediate


# ( -- ) flow control:  (limit) (start) do ... loop
revealheader "loop"
colon floop         $qcomp $five $structured    \
                    $lit $doloop $comma    \
                    $dup $oneplus $resolve      \
                    $resolveback                \
                    $innerloop $store
immediate


# ( n -- ) flow control:  (limit) (start) do ... (increment) +loop
revealheader "+loop"
colon fplusloop     $qcomp $five $structured    \
                    $lit $doplusloop $comma    \
                    $dup $oneplus $resolve      \
                    $resolveback                \
                    $innerloop $store
immediate



# ( a -- )
colon putleave    $qcomp $comma $innerloop $fetch $qdup $branch0 3 $comma $unnest $nolooppars


# ( -- ) flow control:  (limit) (start) do ... if ... leave then ... loop
revealheader "leave"
colon leave         $lit $doleave $putleave
immediate


# ( f -- ) flow control:  (limit) (start) do ... (flag) ?leave ... loop
revealheader "?leave"
colon qleave        $lit $doqleave $putleave
immediate









# -----------------------------------------------------------------------------
# -------------------------------- interpreter --------------------------------
# -----------------------------------------------------------------------------





# ( -- ) fill input buffer from standard input
revealheader "query"
colon query          \
   $lit 255          \
   $tib   $dup $in $store     \
   $dup              \
   $lit $((TIBSIZE-1))        \
   $accept           \
   $plus          \
   $cstore





# ( a n -- ) interpreter for a single word
revealheader "interpret1"
colon interpret1        \
   $findx                 \
   $qdup $branch0 17       \
      $oneminus $branch0 7              \
      $compiling $branch0 4      \
      $comma            \
      $branch 7            \
      $execute          \
      $depth $less0 $branch0            \
          2 $stackunderflow $unnest \
   $dup2 $qnumber       \
   $branch0 8           \
      $nip $nip            \
      $compiling        \
      $branch0 2        \
      $literal          \
      $unnest           \
    $type $notfound



# ( -- ) interpret one line of forth source
revealheader "interpret"
colon interpret            \
   $lit 32 $stream         \
   $qdup          \
   $branch0 4           \
   $interpret1          \
   $branch -8           \
   $drop


# ( a n -- ) interpret the string passed on stack
#revealheader "evaluate"
#colon evaluate            \
# string to tib  $interpret





# -----------------------------------------------------------------------------
# ---------------------------------- include ----------------------------------
# -----------------------------------------------------------------------------


# ( a n1 -- n2 )
code from from
from() {
   local i
   pack
   f=(); i=0
   if [[ ! -f "$tos" ]]; then
      tos="${tos}.bashforth"
   fi
   if [[ -f "$tos" ]]; then
      while read -r f[i]
      do
         (( i++ ))
      done < $tos
      tos=$i
   else
     tos=-38; codethrow
   fi
}


# ( a n1 -- n2 )
code endfrom endfrom
endfrom() {
      unset f
}


# ( n -- )
code line line
line() {
   [[ $LOADING ]] && printf '%s' "$LOADING"
   s[++sp]=${f[tos]}   tos=${m[tib+1]}   m[in+1]=$tos
   unpack
   m[tos+${m[tib+1]}]=255   tos=${s[sp--]}
}



revealheader "sourcepath"
code sourcepath sourcepath
sourcepath()  {
   ss[++ssp]="$stos"
   stos="$sources/"
}

revealheader "!sourcepath"
code storesourcepath storesourcepath
storesourcepath()  {
   if ((!ssp)); then
      tos=-65; codethrow
   fi
   sources="$stos"
   stos="${ss[ssp]}"
   ((ssp--))
}


# ( <stream> -- ) read forth source from file
revealheader "include"
colon include           \
   $sourcepath          \
   $bl $stream $pushstr $appendstr  \
   $popstr $from        \
   $zero $dodo 6  \
   $i $line    \
   $interpret     \
   $doloop -4      \
   $endfrom



# ----- file interface -----

#  ( -- x )   a constant for file access method r/o
#revealheader "r/o"
#constant famreadwrite 0

#  ( -- x )   a constant for file access method r/w
#revealheader "r/w"
#constant famreadwrite 1


# ( a n fam -- fileid ior )
#revealheader "create-file"
#code create-file create-file
#create-file()  {
#     r[++rp]=$tos
#     tos=${s[sp]}
#     pack
#     (echo -n > $tos) 2> /dev/null
#     s[sp]="12345678"       # can only use one handle as far
#     tos=$?

#     (( rp-- ))             # ior is not used now
#    if fam=0 then chmod -r filename
#}



# open-file
# read-file
# write-file
# close-file
# file-size
# file-position





# -----------------------------------------------------------------------------  save-system and restore were
# ------------------------------- save-system ---------------------------------  contributed by quaraman-me
# -----------------------------------------------------------------------------

save_array_print() {
   local i
   local inext
   local -n a=$1
   inext=0
   printf 'a0\n'
   for i in "${!a[@]}"; do
      [[ "$inext" != "$i" ]] &&
         printf 'ao %s\n' "$i"
      printf 'a %s\n' "${a[i]}"
      (( inext++ ))
   done
}

# ( a c -- ) writes image of system to file, file name passed as address, count on stack
code saveas saveas
saveas()  {
   local i
   local inext
   local len
   pack
   [[ "$tos" ]] || tos="$sources/saved_system"
   {  printf "version %s\n" "$version"
      printf "wc %s\n" "$wc"
      printf "dp %s\n" "$dp"

      save_array_print m
      save_array_print h
      save_array_print hf
      save_array_print x
   } > "$tos"
   tos=${s[sp--]}
}


# ( <stream> -- ) writes image of system to file, file name taken from input stream. If no name given, "save_system" will be the name.
revealheader "save-system"
colon savesystem    $bl $stream $saveas


# -----------------------------------------------------------------------------
# -------------------------- restore saved system -----------------------------
# -----------------------------------------------------------------------------


# ( a c -- )
code restorefrom restorefrom
restorefrom()  {
   local load_version
   local cmd
   local prg
   local a=0
   local ai=0
   local linenr=0
   pack
   m=()
   h=()
   hf=()
   x=()
   fname="${tos:-$sources/saved_system}"
   tos=${s[sp--]}
   while read -r line; do
      read -a prg <<< "$line"
      cmd="${prg[0]}"
      p1="${prg[1]}"
      p2="${prg[2]}"

      case "$cmd" in
      version)
         load_version="$p1"
         [[ "$load_version" != "$version" ]] &&
            echo "Not same Version : $load_version"
         ;;
      wc)
         wc="$p1"
         ;;
      dp)
         dp="$p1"
         ;;
      a0)
         ai=0
         (( a++ ))
         ;;
      ao)
         ai="$p1"
         ;;
      a)
         case $a in
         1)
            m[ai++]="$p1"
            ;;
         2)
            h[ai++]="$p1"
            ;;
         3)
            hf[ai++]="$p1"
            ;;
         4)
            x[ai++]="$p1"
            ;;
         esac
         ;;
      hlt)
         ai=0
         break;
         ;;
      esac
      (( linenr++ ))
   done < "$fname"
}

# ( <stream> -- ) write image of system to file, file name taken from input stream. If no name given, saved_system will be the name.
revealheader "restore"
colon restore    $bl $stream $restorefrom



# -----------------------------------------------------------------------------
# ------------------------------ init / startup -------------------------------
# -----------------------------------------------------------------------------

code init_stacks init_stacks
init_stacks() {
   sp=$s0
   temp=${r[rp]}
   rp=$r0
   r[rp]=$temp
}


# executed by cold and warm
code init_other init_other
init_other() {
   tos=0
   ssp=$ss0
   ss[ssp]=""
   m[base+1]=10
   m[innerloop+1]=0
   m[state+1]=0
}


# ( ??? -- )
revealheader "(quit)"
colon bracketquit          \
   $init_stacks            \
   $zero $innerloop $store \
   $leftbracket            \
   $query                  \
   $interpret              \
   $prompt                 \
   $branch -4

m[quit+1]=$bracketquit            # set deferred quit




# ( ??? -- )
revealheader "(warm)"
colon warmhandler          \
   $init_stacks            \
   $init_other             \
   $decimal                \
   $prompt                 \
   $quit

m[warm+1]=$warmhandler            # set deferred warm





# ( -- ) prints GPL notice
revealheader "license"
code license license
license() {
   echo "
   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
"
}




# ( -- ) prints the opening screen
revealheader "hello"
code hello hello
hello() {
   echo -e "\nBashForth v$version
   $(license)
   www:      https://github.com/Bushmills/Bashforth

   words <enter>       shows a list of available words
   doc word  <enter>   gives description of word

"
}







# -----------------------------------------------------------------------------
# ------------------------------ misc optionals -------------------------------
# -----------------------------------------------------------------------------

# these may shell to other programs. in fact, several of the following words do

# ----------------------------------- doc -------------------------------------


# ( xt -- x )
code sourceline sourceline
sourceline() {  tos=${m[tos-1]}; }



# calls cat, sed, cut
# ( -- )
code printdoc printdoc
printdoc() {
     temp=$(sed -n $(( tos+1 ))p $0 | cut -f 2 -d " ")
     NAME=${temp:1:${#temp}-2}
     temp=$(sed -n ${tos}p $0 | sed s/"# "//)
     STACKEFFECT=${temp%%)*}
     DESCRIPTION=${temp#*)}
     echo "$NAME  $STACKEFFECT)"
     temp="sorry, this word hasn't been documented yet"
     echo "${DESCRIPTION:-$temp}"
     tos=${s[sp--]}
}


# ( <stream> -- ) print stack effect and description of word, name taken from input stream
revealheader "doc"
colon doc  $tick $sourceline $printdoc




# ----------------- see ------------------

# calls sed
# ( -- )
code printsource printsource
printsource() {
     echo "in file $0:"
     sed -n "1,${tos}d;p;/^ *$/q" "$0"
     tos=${s[sp--]}
}


# ( <stream> -- ) print source of a word (read from the executed bashforth script file)
revealheader "see"
colon see   $tick $sourceline $printsource



# ---------------------- terminal control ---------------------

# ( -- 0 ) returns color code for color black
revealheader "black"
constant black 0

# ( -- 1 ) returns color code for color red
revealheader "red"
constant red 1

# ( -- 2 ) returns color code for color green
revealheader "green"
constant green 2

# ( -- 3 ) returns color code for color yellow
revealheader "yellow"
constant yellow 3

# ( -- 4 ) returns color code for color blue
revealheader "blue"
constant blue 4

# ( -- 5 ) returns color code for color magenta
revealheader "magenta"
constant magenta 5

# ( -- 6 ) returns color code for color cyan
revealheader "cyan"
constant cyan 6

# ( -- 7 ) returns color code for color white
revealheader "white"
constant white 7

# fg: 0:3  bg: 4:7  bold: 8  underscore: 9
(( attributes = 112 ))



# ( color -- ) set foreground color
revealheader "fg"
code fg fg
fg() {
  ((tos&=7,
    attributes&=-16,
    attributes|=tos ))
    printf '%b' "\e[3${tos}m"
    tos=${s[sp--]}
}


# ( color -- ) set background color
revealheader "bg"
code bg bg
bg() {
  ((tos &= 7,
    attributes&=-241,
    attributes|=(tos << 4)))
    printf '%b' "\e[4${tos}m"
    tos=${s[sp--]}
}

# ( -- ) reset colors and attributes to normal
revealheader "normal"
code normal normal
normal() {
   attributes=112
   printf '%b' "\e[0m"
}


# ( -- ) set bold attribute
revealheader "bold"
code bold bold
bold() {
   ((attributes&=-257,
   attributes|=256))
   printf '%b' "\e[1m"
}


# ( -- ) set underscore attribute
revealheader "underscore"
code underscore underscore
underscore() {
   ((attributes&=-513,
   attributes|=512))
   printf '%b' "\e[4m"
}


# ( -- ) reverse screen colors
revealheader "reverse"
code reverse reverse
reverse() { colors; fg; bg; }


# ( -- u ) read all screen attributes, incl color
revealheader "attr@"
code attrfetch attrfetch
attrfetch() {
   s[++sp]=$tos
   tos=$attributes
}


# ( u -- ) set all screen attributes, incl color, as read with attr@
revealheader "attr!"
code attrstore attrstore
attrstore() {
   attributes=$tos
   printf '%b' "\e[3$((tos&7));4$(((tos>>4)&7))"
   ((temp=(tos>>8)&1))
   ((temp)) && printf '%b' ";$temp"
   ((temp=(tos>>7)&4))
   ((temp)) && printf '%b' ";$temp"
   echo -n "m"
   tos=${s[sp--]}
}


# ( -- fg bg ) return current colors
revealheader "colors"
code colors colors
colors() {
   ((s[++sp]=tos,
   s[++sp]=attributes&7,
   tos=(attributes>>4)&7))
}



# ( x y -- ) position cursor at x,y
revealheader "at"
code atxy atxy
atxy() {
   printf '%b' "\e[$((tos+1));$((s[sp--]+1))H"
   tos=${s[sp--]}
}



# ( -- ) position cursor at upper left
revealheader "home"
code home home
home() {   printf '%b' "\e[H"; }




# ---------------------------------------------------------------------



# ( n1 -- n2 ) returns random number between 0 and n1-1 (max 2^30-1 = 1073741823)
revealheader "rnd"
code rnd rnd
rnd() { ((tos="((RANDOM<<15)|RANDOM)%tos")); }



# ( -- s m h d m y ) returns system time: seconds minutes hours day month year
revealheader "time&date"
code timeanddate timeanddate
timeanddate() {
   s[++sp]=$tos   temp=( $( date "+%S %M %H %d %m %Y" ) )
   for i in {0..4}; do
      s[++sp]=$( printf '%g' "${temp[i]}" )
   done
   tos=${temp[5]}
}





# -----------------------------------------------------------------------------
# ---------------------------------- shell ------------------------------------
# -----------------------------------------------------------------------------


# ( -- ) shows environment variables
revealheader "set"
code shellset set


# ( -- ) ( string: name -- contents )  replaces name of an environment variable against contents
revealheader "env"
code environment environment
environment() {
   stos="${!stos}"
}


# ( -- ) shells to bash
revealheader "bash"
code shellbash bash


# ( a n1 -- n2 ) shell, string is command + arguments. returns exit code
revealheader "system"
code system system
system() {
   pack
   $tos
   tos=$?
}


# ( a1 n1 a2 n2 -- n3 ) shell, append a2 n2 as arguments to command a1 n1, returns exit code
revealheader "system2"
code system2 system2
system2() {
   pack
   cmdline=$tos
   tos=${s[sp--]}
   pack
   $tos $cmdline
   tos=$?
}


# ( a n  -- ) takes file name from stack and edits file, using external editor
revealheader "(edit)"
code brtextedit brtextedit
brtextedit() {
   pack
   $EDITOR $tos
   tos=${s[sp--]}
}


# ( <stream> -- ) edit the file with name taken from stream
revealheader "edit"
colon textedit $zero $stream $brtextedit



# ( n -- ) sleeps for n seconds
revealheader "secs"
code secs secs
secs() {
   sleep $tos
   tos=${s[sp--]}
}

# ( n -- ) sleeps for n milliseconds
revealheader "ms"
code ms ms
ms() {
   sleep $((tos/1000)).$((tos%1000))
   tos=${s[sp--]}
}


revealheader "epoche"
code epoche epoche

if (( ${BASH_VERSION%%.*} < 5 )); then

# ( -- n ) returns seconds since 1/1/1970
epoche() {
   s[++sp]=$tos
   tos=$(date +%s)
}

else

# ( -- n ) returns seconds since 1/1/1970
code epoche epoche
epoche() {
   s[++sp]=$tos
   tos=$EPOCHSECONDS
}

fi

# ( -- n ) returns nanoseconds since 1/1/1970
revealheader "nanoseconds"
code nanoseconds nanoseconds
nanoseconds() {  s[++sp]=$tos   tos=$(date +%s%N); }


# ( xt -- n ) measures the time in nanoseconds to execute xt, returned as n
revealheader "time"
colon measuretime  \
    $nanoseconds $to_r $execute $nanoseconds $r_from $minus





# -----------------------------------------------------------------------------
# ------------------------- interpreter entry  point --------------------------
# -----------------------------------------------------------------------------


code commandline commandline
commandline() {
   s[++sp]=$tos
   tos=0                                  # assume no command line
   if [[ $COMMANDLINE ]]; then
      s[++sp]="nop $COMMANDLINE"          # unless one received
      ((m[in+1]=tos=tib+1))               # destination, dest becomes input buffer
      unpack                              # convert string to chars
      m[tos+tib+1]=255                    # end of line delimiter at end of buffer works
      unset COMMANDLINE                   # execute only once
      tos=-1                              # indicate "commandline found"
   fi
}

code setrealthrow setrealthrow
setrealthrow()  {
   m[throw+1]="$realthrow"
}

revealheader "cold"
boot=$dp; colon cold \
   $init_stacks      \
   $init_other       \
   $decimal          \
   $commandline      \
   $branch0 8        \
     $tick $interpret $catch $throw $bye \
   $branch 2         \
      $hello         \
   $setrealthrow     \
   $prompt           \
   $query            \
   $interpret        \
   $prompt           \
   $branch -4
# duplicating part of the outer interpreter loop here is done
# to allow command line actions to carry over stack into the
# interactive interpreter - the "quit" outer interpreter
# initializes the stacks



# -----------------------------------------------------------------------------
# ---------------------------- remove transients ------------------------------
# -----------------------------------------------------------------------------


i=${#remove[*]}
while ((i)); do
   unset "${remove[--i]}"
done




# -----------------------------------------------------------------------------
# ----------------------------- start interpreter -----------------------------
# -----------------------------------------------------------------------------

set +u
[[ -f ~/.bashforthrc ]] && source ~/.bashforthrc
if [[ -f "$sources/$1" ]]; then
   COMMANDLINE="include $*"
else
   COMMANDLINE="$*"
fi
ip=$boot
start

# -----------------------------------------------------------------------------
#                               end of shell script
# -----------------------------------------------------------------------------