#!/bin/bash
# set -u


# requires bash 2.04 or more recent.


version="0.54a"
# bashforth - forth interpreter in bash
# v0.03 20030219 Speuler added bool, logical, constants, fixed nip and other
# v0.04 20030219 Speuler added ?dup, fixed 0branch 
# v0.05 20030220 Speuler reviewed auto-inc/dec addressing modi, fixed 0branch again
# v0.06 20030220 Speuler constants redone
# v0.07 20030220 Speuler added lshift rshift
# v0.08 20030220 Speuler emit outputs correctly decimal numbers on stack. thanks dufflebunk 
# v0.09 20030220 Speuler simplified asc table building. 
# v0.10 20030220 Speuler accept works. uses external command  cut  right now.
# v0.11 20030220 Speuler added pad c@ @ c! ! count
# v0.12 20030221 Speuler key and accept return asciis, rather than chars.
#                        emit, type, find work on asciis 
# v0.13 20030221 Speuler word,  input stream parser, query, interpret, quit added
#                        this enables multiple words on input line
# v0.14 20030221 Speuler ?number added, extended interpreter. numbers work, but
#                         only decimal
# v0.15 20030221 Speuler added deferred words, improved error handler. first
#                        defining words. creation of variables works.
# v0.16 20030221 Speuler immediate, colon definitions work
# v0.17 20030222 Speuler 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 Speuler if..then, if..else..then begin..while..repeat work. structure is tested
# v0.19 20030222 Speuler do..loop, i, j, negative numbers input, commented out debug output
#                        from virtual machine for 50% speed improvement
# v0.20 20030223 Speuler added  does>  2+  
# v0.21 20030223 Speuler hide, reveal, constant. started redoing error handler. loops broken
# v0.22 20030223 Speuler loops fixed. ?comp
# v0.23 20030223 Speuler added  catch throw ?exec  . fixed key (space). ctrl chars return asc of space too.
# v0.24 20030224 Speuler added  ." , s" , $, .(      fixed bug in word .  tests stack underflow
# v0.26 20030225 Speuler added s( \ (
# v0.27 20030225 Speuler errorhandler through throw. top level error handler catches gracefully
# v0.28 20030225 Speuler speed increase of about 50 %
# v0.29 20030225 Speuler exit, outputs asciis 0...31, speeded up compares, improved move
# v0.30 20030225 Speuler .. outputs decimal (quick), . respects base (slower), number input respects base
#                        added hex, decimal, binary
# v0.31 20030226 Speuler pictured number output added ( <# # #s #> #>type sign )
# v0.31a20030226 Speuler hold (forgotten, pictured number output), rot, -rot
# v0.32 20030226 Speuler 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 Speuler added bash, fixed does>, started include.  sent out for does> fix
# v0.34 20030226 Speuler first rough version of include works. no nesting yet. thanks deltab for getting the source into vars
# v0.35 20030226 Speuler 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 Speuler 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 Speuler number output with . doesn't complain about zero-string stack elements.
#                        stack order  reversed.  added */  */mod  ?do  leave . speeded up type
# v0.37a20030310 Speuler fixed include, broken in 0.37 because of changed do
# v0.37b20030310 Speuler fixed include again. * in source was expanded to file list
# v0.37c20030310 Speuler fixed ." which had cr appended
# v0.38 20030310 Speuler added skip, scan, tuck, compare
# v0.39 20030310 Speuler added min max abs fill doc,   abort throws,  removed ?exec
# v0.40 20030311 Speuler bugfix for 2.05a, hopefully for 2.04 too. incompatible with 2.03
# v0.41 20030311 Speuler redone doc. this implementation writes line number to word body. added rnd +! cell cells chars
# v0.42 20030311 Speuler more consistent use of addressing modes, added
#                date&time.fixed negative number big introduced with .40
# v0.42a20030313 Speuler changed email address. verified function on bash 2.04. thanks, stepan
# v0.42b20030315 Speuler fixed sign bug, result of v0.40, added >name
# v0.43 20030316 Speuler added .name, roll, improved locate and >name, last points now to cfa of last word
# v0.44 20030316 Speuler added cell+ char +loop ?leave **
# v0.45 20030316 Speuler added 2>r 2r>, cleaned up code, speeded up some words (type, #, words)
# v0.46 20030316 Speuler added literal, compiling, addressing modes optimizations
# v0.46a20030316 Speuler bugfix addressing modes v0.46. untested with bash 2.04
# v0.47 20030319 Speuler added black yellow green red blue magenta cyan white fg bg colors
# v0.47a20030320 Speuler added normal bold underscore reverse attr@ attr!
# v0.47b20030320 Speuler added at home
# v0.47c20030325 Speuler added ?at (doesn't work yet) number /string right$ left$
# v0.48 20030325 Speuler added system2 2swap dup$ drop$ depth$ 2dup$ swap$ over$ nip$ rot$ push$ pop$ merge$
#                        modified left$ right$, these work on stop string stack element now
#                        modified doc to show word description, besides stack effect. optimized does>
# v0.48a20030325 Speuler added/modified descriptions
# v0.48b20030526 Speuler replaced hide/reveal against versions by h-peter recktenwald. these ones seem
#                        to be less sensitive for the used version of bash
# v0.48c20030527 Speuler bug fix "hold", bug discovered by h-peter recktenwald
# v0.48d20030530 Speuler 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 Speuler attempted fix of ?number, number and * for bash v2.04 on BEOS
# v0.49 20030809 Speuler fixed time&date, broken after 2.04 fix in 0.48e
# v0.49a20030809 Speuler fixed loop +loop for 2.04
# v0.49b20030818 Speuler found a better fix for time&date
# v0.49c20031019 Speuler fixed : foo ." *" ;  bug which displayed current directory
# v0.49d20031019 Speuler added for .. next, compatible with i j  , added spaces.
#                        made count tolerant for non-initialized memory locations
# v0.49e20031019 Speuler attempt to include nonexisting file throws -38
# 0.50  20031028 Speuler added see  (does not decompile, shows script source instead)
# 0.50a 20040101 Speuler fixed : $structured, not structured in until   
# 0.50b 20040928 Speuler optional doc <word> uses sed rather than tail - recently tail args were changed.
# 0.51  20041004 Speuler added 2@ and 2!, suggested by Antonio Maschio
# 0.52  20041116 Speuler slow (1sec) version of key?, added secs and epoche
# 0.52a 20041123 Speuler can emit ascii <32 correctly
# 0.53  20041217 Speuler ***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 Speuler trapped Ctrl-C: warm start
# 0.53b 20041220 Speuler added >body body>
# 0.53c 20041222 Speuler include appends .bashforth extension and retries if file not found
# 0.54  20050119 Speuler fixed bug in move
# 0.54a 20050222 Speuler added ?



# 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 next catch 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 #####################################
# info $LINENO          # marks line number of stack diagram/documentation, for "doc foo"
# # ( -- ) 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 ----------
# function foo {        # executable implementated as function
#    s[++sp]=$tos       # stack push
#    tos=${s[sp--]}     # stack pop
# }
#########################################################################################




################################# example hi-level word #####################################
# info $LINENO          # marks line number of stack diagram/documentation, for "doc foo"
# # ( -- ) 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
#########################################################################################




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


ctrl-c () { tos=-28 ; exception ; } ; trap  ctrl-c 2



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

tos=0
stos=""

declare -i ip w					# instruction and word pointer of virtual machine
declare -i s0 sp   ; s0=0  ; sp=$s0 ; s[sp]=0	# data stack origin and pointer
declare -i r0 rp   ; r0=0  ; rp=$r0 ; r[rp]=0	# return stack origin and pointer
declare -i ss0 ssp ; ss0=0;ssp=$ss0 ;ss[ssp]="" # string stack origin and pointer
declare -i dp=0                			# dictionary pointer
declare -i wc=0					# word count
declare -i state=0
declare -i catchframe=0        			# pointer to latest catch frame, or 0



# ---- 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=0 ; i<32 ; i++ )) ; do
   asc[i]="\x$(printf %x $i)"              # ascii 0-31 
done
for (( i=32 ; i<256 ; i++ )) ; do
   asc[i]=`echo -en "\x$(printf %x $i)"`  # ascii 32-255
done


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


# --- array of variables and functions which will be removed after building ---
remove=()

function transient  {
   remove[${#remove[*]}]=$1
}

transient remove              # remove may not be other than first transient
transient transient




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




transient code
function code  {
   let $1=$dp
   shift 1
   m[dp++]="$*"
}



transient var
function var {
   let $1=$dp
   compile dovar 0
}



var lastxt

function header {
   m[lastxt+1]=$dp          # points to execution adress of last word
   x[wc]=$dp                # execution token
   hf[wc]=0                 # header flags (precedence bit)
   h[wc++]="$1"             # header count
}




#\ --- these two words may fail with pre-2.05a
#\ function reveal {
#\   (( hf[wc-1] |= $smudgebit ))
#\ }
#\
#\
#\ function hide {
#\    (( hf[wc-1] &= (~$smudgebit) ))
#\ }
#\


#\ -- i have received these versions from hans-peter recktenwald
#\ ( http://www.lxhp.in-berlin.de/index-lx.shtml )
#\ which hopefully improves operation on 2.05 and before.
#\ thanks, hans-peter !

function reveal () { hf[wc-1]=$((hf[wc-1] | ${smudgebit})); }
function hide   () { (( hf[wc-1] &= "~${smudgebit}" )); }






transient revealheader
function revealheader {
   header "$1"
   reveal
}


transient semicolon
function semicolon {
   compile $unnest 
   reveal
}


transient colon
function colon  {
   let $1=$dp
   shift 1
   compile nest
   compile "$*"
   semicolon
}


transient constant
function constant {
   let $1=$dp
   shift
   compile doconst $1
}


transient defer
function defer {
   let $1=$dp
   compile dodefer 0
}


transient info
function info {
   m[dp++]=$(($1+1))
}




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

revealheader ""

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





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


function next {
   w=${m[ip++]}
   ${m[w++]}
}


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


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




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

info $LINENO
# ( -- -1 )
revealheader "true"
revealheader "-1"
constant minone -1


info $LINENO
# ( -- 0 )
revealheader "false"
revealheader "0"
constant zero 0


info $LINENO
# ( -- 1 )
revealheader "cell"
revealheader "1"
constant one 1


info $LINENO
# ( -- 2 )
revealheader "2"
constant two 2


info $LINENO
# ( -- 3 )
revealheader "3"
constant three 3


info $LINENO
# ( -- 4 )
revealheader "4"
constant four 4


info $LINENO
# ( -- 5 )
revealheader "5"
constant five 5


info $LINENO
# ( -- 6 )
revealheader "6"
constant six 6


info $LINENO
# ( -- 27 )
revealheader "esc"
constant esc 27


info $LINENO
# ( -- 32 )
revealheader "bl"
constant bl 32


info $LINENO
# ( -- a )
revealheader ">in"
var in


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


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


info $LINENO
# ( -- a )
revealheader "tib"
var tib
(( dp+=255 ))


info $LINENO
# ( -- a )
revealheader "base"
var base 





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



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


function dovar {
   s[++sp]=$tos
   tos=$w
}
   

function dodefer  {
   ip=$w
}

   

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



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




info $LINENO
# ( -- x ) run time word - to be compiled by another word
revealheader "lit"
code lit lit
function lit {
   s[++sp]=$tos
   tos=${m[ip++]}
}




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




info $LINENO
# ( x a -- n ) unpacks string in tos to asciis at a 
revealheader "unpack"
code unpack unpack
function unpack {
   local string=${s[sp--]}
   stringlen=${#string}
   dest=$(( $tos + $stringlen ))
   prevdest=$dest
   for (( i=stringlen ; i ; i-- )) ; do
      tos="${string:i-1:1}"
      char2asc
      m[--dest]="$tos"
   done
   tos=$(( $prevdest - $dest ))
}




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



info $LINENO
# ( -- ) run time word - to be compiled by ."
revealheader '(.")'
code bracketdotquote bracketdotquote
function bracketdotquote {
   bracketsquote
   pack
   echo -n "$tos"
   tos=${s[sp--]}
}



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


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





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



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



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



info $LINENO
# ( -- ) run time word - to be compiled by ?leave
revealheader "(?leave)"
code parenqleave parenqleave
function parenqleave {
   if [ $tos -ne 0 ] ; then
      parenleave
   else
      (( ip+=1 ))
   fi
   tos=${s[sp--]}
}





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



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




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








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


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




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




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




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




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




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




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




info $LINENO
# ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) swap top two stack elements with next two elements
revealheader "2swap"
code swap2 swap2
function swap2 {
   temp=${s[sp-1]}
   s[sp-1]=$tos
   tos=$temp
   temp=${s[sp-2]}
   s[sp-2]=${s[sp]}
   s[sp]=$temp
}




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




info $LINENO
# ( x1 x2 -- x2 ) discard second stack element
revealheader "nip"
code nip nip
function nip {
   (( sp-=1 ))
}




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


   

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




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




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




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



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




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




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




info $LINENO
# ( -- ) drops top of return stack
revealheader "rdrop"
code rdrop rdrop
function rdrop {
   (( rp-=1 ))
}




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




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




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




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




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


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




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




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




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




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




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




info $LINENO
# ( n -- u ) remove sign
revealheader "abs"
code abs abs
function abs  {
   if [ $tos -lt 0 ] ; then
      tos=$(( -$tos ))
   fi
}




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




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




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




info $LINENO
# ( n1 n2 n3 -- n4 ) multiply n1 with n2, divide by n3
revealheader "*/"
code starslash starslash
function starslash  {
   tos=$(( ${s[sp--]} * ${s[sp--]} / $tos ))
}




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




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




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




info $LINENO
# ( u1 n -- u2 ) shift right u1 by n
revealheader "rshift"
code rshift rshift
function rshift  {
   tos="$(( ${s[sp--]} >> $tos ))"
}




info $LINENO
# ( u1 n -- u2 ) shift left u1 by n
revealheader "lshift"
code lshift lshift
function lshift  {
   tos="$(( ${s[sp--]} << $tos ))"
}




info $LINENO
# ( n1 -- n2 ) multiply n1 by 2, impemented as (quicker) shift left by 1
revealheader "2*"
code mul2 mul2
function mul2  {
   (( tos<<=1 ))
}




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




info $LINENO
# ( n1 -- n2 ) reverse sign of n1
revealheader "negate"
code negate negate
function negate  {
   tos=$(( -$tos ))
}




info $LINENO
# ( n1 n2 -- n1|n2 ) return the smaller one of two numbers
revealheader "min"
code min min
function min {
   temp=${s[sp--]}
   if [ $tos -gt $temp ] ; then
      tos=$temp
   fi
}




info $LINENO
# ( n1 n2 -- n1|n2 ) return the greater one of two numbers
revealheader "max"
code max max
function max {
   temp=${s[sp--]}
   if [ $tos -lt $temp ] ; then
      tos=$temp
   fi
}









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




info $LINENO
# ( a n -- x -1 | 0 ) try to convert n chars at a to number, respecting base
revealheader "?number"
code qnumber qnumber
function qnumber {
   local digit sign=0 radix=${m[base+1]}
   i=$tos				# number of digits to test/convert
   tos=-1				# assume number   
   temp=${s[sp]}                   	# addr of next digit
   s[sp]=0                       	# accumulator
   if [ ${m[temp]} -eq 45 ] ; then 	# leading -
      sign=-1
      (( temp+=1 ))			# strip
      (( i-=1 ))
   fi
   for (( ; i ; i-- )) ; do		# for all digits
      digit=$(( ${m[temp++]} - 48 ))	# read ascii of digit
      if [ $digit -gt 9 ] ; then
         (( digit-=39 ))
      fi
      if [[ ($digit -ge 0) && ($digit -lt $radix) ]] ; then
         s[sp]=$(( $radix * ${s[sp]} ))
         s[sp]=$(( $digit + ${s[sp]} ))
      else
         tos=0 				# flag "not a valid number"
         break
      fi
   done
   if [ $tos -eq 0 ] ; then
      (( sp-=1 ))                        # drop string address
   elif [ $sign -ne 0 ] ; then
      s[sp]=$(( -${s[sp]} ))
   fi
}




# 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
info $LINENO
# ( a n -- x 0 | x n ) try to convert n chars at a to number, respecting base
revealheader "number"
code number number
function number {
   local digit sign=0 radix=${m[base+1]}

   src=${s[sp]}                   	# addr of next digit
   s[sp]=0                       	# accumulator

   if [ ${m[src]} -eq 45 ] ; then 	# leading -
      sign=-1
      (( src+=1 ))			# strip
      (( tos-=1 ))
   fi

   for (( ; tos ; tos-- )) ; do		# for all digits
      digit=$(( ${m[src++]} - 48 ))	# read ascii of digit
      if [ $digit -gt 9 ] ; then
         (( digit-=39 ))
      fi
      if [[ ($digit -ge 0) && ($digit -lt $radix) ]] ; then
         s[sp]=$(( $radix * ${s[sp]} ))
         s[sp]=$(( $digit + ${s[sp]} ))
      else
         break
      fi
   done

   if [ $sign -ne 0 ] ; then
      s[sp]=$(( -${s[sp]} ))
   fi
}






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



info $LINENO
# ( n1 n2 f -- c n3 n4 f  ) pictured number conversion: convert a single digit
revealheader "#"
code hash hash
function hash {
   r[++rp]=$tos
   r[++rp]=$(( ${s[sp]} / ${m[base+1]} ))
   tos=$(( ${s[sp--]} % ${m[base+1]} ))
   (( tos+=48 ))
   if [ $tos -gt 57 ] ; then
      (( tos+=39 ))
   fi
   temp=${s[sp]}
   s[sp]=$tos
   s[++sp]=$(( $temp + 1 ))
   s[++sp]=${r[rp--]}
   tos=${r[rp--]}
}




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




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



info $LINENO
# ( n1 n2 f -- c n3 n4 f  ) pictured number conversion: insert minus sign if converted number is negative
revealheader "sign"
code sign sign
function sign {
   if [ $tos -ne 0 ] ; then
      twoto_r
      (( tos+=1 ))
      s[++sp]=45
      twor_from
   fi
}   




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




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




# ( char -- asc ) converts character to decimal ascii
code char2asc char2asc
function char2asc  {
   char=$tos
   tos=64
   temp="$(( $tos >> 1 ))"
   while [[ "${asc[tos]}" != "$char" ]] ; do
      if [ $temp -eq 0 ] ; then
         tos=32
         break
      fi
      if [[ "${asc[tos]}" < "$char" ]]  ; then
         (( tos+=$temp ))
      else
         (( tos-=$temp ))
      fi
      (( temp>>=1 ))
   done
}






# -----------------------------------------------------------------------------
# ---------------------------------- logical ----------------------------------
# -----------------------------------------------------------------------------



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




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





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



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




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



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





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


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



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




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




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






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




info $LINENO
# ( c -- ) output the character which ascii is on top of stack
revealheader "emit"
code emit emit
function emit {
   echo -ne "${asc[tos]}"
   tos=${s[sp--]}
}



info $LINENO
# ( -- ) output a space character
revealheader "space"
code space space
function space {
    echo -n " "
}
    

info $LINENO
# ( n -- ) output spaces
revealheader "spaces"
code spaces spaces
function spaces {
   for (( ; tos ; tos-- )) ; do
    echo -n " "
   done
   tos=${s[sp--]}
}



info $LINENO
# ( -- ) clear screen
revealheader "page"
revealheader "cls"
code page clear




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



info $LINENO
# ( -- ) output a line feed
revealheader "cr"
code cr echo




info $LINENO
# ( n -- ) outputs tos, the way it is (does not respect base, outputs strings)
revealheader ".."
code dotdot dotdot
function dotdot {
   echo -n "$tos "
   tos=${s[sp--]}
}



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




info $LINENO
# ( -- c ) return (after 1 sec) 0 or (immediately) ascii of keystroke
# would need to stuff ascii into a key buffer, read by key
revealheader "key?"
code keyq keyq
function keyq {
   s[++sp]=$tos
   tos=
   read -rsn 1 -t 1 tos
   if [ ! -z $tos ] ; then
      char2asc
   else
      tos=0
   fi
}

# -------------- earlier attempt --------------
# ( -- c )
#revealheader "key?"
#code keyq keyq
#function keyq {
#   s[++sp]=$tos
#   tos=-1                               # assume true
#   if [ "$keybuf" == "" ] ; then
#      read -rs -t 0 -n 1 keybuf
#      if [ "$keybuf" == "" ] ; then
#         tos=0
#      fi
#echo $tos -"$keybuf"-
#sleep 0.5
#   fi
#}


# ( -- c )
#revealheader "key"
#code key key
#function key {
#   s[++sp]=$tos
#   if [ "$keybuf" == "" ] ; then
#      read -rsn 1 keybuf
#   fi
#   tos="$keybuf"
#   keybuf=""
#   char2asc
#}


info $LINENO
# key: ( -- c ) read one char from input, return ascii
revealheader "key"
code key key
function key {
   s[++sp]=$tos
   read -rsn 1 tos
   char2asc
}




info $LINENO
# ( a n1 -- n2 ) read n1 chars from input, store at a. number of actually entered chars returned as n2
revealheader "accept"
code accept accept
function accept {
   read -ersn $tos tos
   swap
   unpack
}






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



info $LINENO
# ( -- ) output the prompt
revealheader "prompt"
code prompt prompt
function prompt {
   if [ ${m[state+1]} -eq 0 ] ; then
      echo -n " ok"
      for (( i=sp ; i>s0 ; i-- )) ; do
         echo -n "."
      done
      echo
   fi
}


info $LINENO
# ( -- ) show numbers on stack
revealheader ".s"
code dot_s dot_s
function dot_s {
   temp=$(( $s0 + 1 ))
   if [ $temp -le $sp ] ; then
      while [ $temp -lt $sp ]
      do
         echo -n "${s[++temp]} "
      done
      echo -n "$tos "
   fi
}




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









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



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



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



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



info $LINENO
# ( xt -- a ) given xt, return word body address
revealheader ">body"
code tobody tobody
function tobody {
   (( tos++ ))
}



info $LINENO
# ( a -- xt ) given word body address, return xt
revealheader "body>"
code bodyfrom bodyfrom
function bodyfrom {
   (( tos-- ))
}



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



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



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



info $LINENO
# ( wordnum --  ) output word name, given word number
revealheader ".name"
code dotname dotname
function dotname {
   echo -n "${h[tos]}"
   tos=${s[sp--]}
}



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



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




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



info $LINENO
# ( -- ) show list of words in vocabulary
revealheader "words"
code words words
function words {
   for (( i=$wc ; i-- ; )) ; do
      echo -n "${h[$i]}  "
   done
}




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


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


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




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




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



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



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






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


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


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



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



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



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



info $LINENO
# ( a1 -- a2 c ) a1+1 -> a2,  [a1] -> c
revealheader "count"
code count count
function count {
   s[++sp]=$(( $tos + 1 ))
   tos=${m[tos]}
   if [ -z $tos ] ; then
      tos=0
   fi
   tos=$(( $tos & 255 ))
}



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



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

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




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




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



info $LINENO
# ( a n1 c -- n2 ) search for c in string a n1. n2 is len of remainder, including first c
revealheader "scan"
code scan scan
function scan {
   temp=$tos
   tos=${s[sp--]}
   dest=${s[sp--]}
   while [ $tos -gt 0 ] ; do
      if [ ${m[dest++]} -eq $temp ] ; then
         break
      fi
      (( tos-=1 ))
   done
}



info $LINENO
# ( a n1 c -- n2 ) skip all leading c in atring a n1. n2 is len of remainder
revealheader "skip"
code skip skip
function skip {
   temp=$tos
   tos=${s[sp--]}
   dest=${s[sp--]}
   while [ $tos -gt 0 ] ; do
      if [ ${m[dest++]} -ne $temp ] ; then
         break
      fi
      (( tos-=1 ))
   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
function compare1 {
      while [ $tos -gt 0 ] ; do
         temp=$(( ${m[source++]} - ${m[dest++]} ))
         if [ $temp -ne 0 ] ; then
            if [ $temp -lt 0 ] ; then
               tos=-1
            else
               tos=1
            fi         
            break
         fi
         (( tos-=1 ))
      done
}

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







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




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




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




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





info $LINENO
# ( 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 ---------------------------------
# -----------------------------------------------------------------------------



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




info $LINENO
# ( -- a n ) pop string from string stack to here
revealheader "pop$"
code popstr popstr
function popstr {
   s[++sp]=$tos
   tos=$dp
   s[++sp]=$tos
   s[++sp]=$stos
   stos=${ss[ssp]}
   ss[ssp--]=""
   unpack
}




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




info $LINENO
# ( -- ) show strings on string stack
revealheader ".s$"
code dot_sstr dot_sstr
function dot_sstr {
   temp=$(( $ss0 + 1 ))
   if [ $temp -le $ssp ] ; then
      while [ $temp -lt $ssp ]
      do
         echo -n "${ss[++temp]} "
      done
      echo -n "$stos "
   fi
}




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




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




info $LINENO
# ( x -- ) drop top stringstack element
revealheader "drop$"
code dropstr dropstr
function dropstr {
   stos=${ss[ssp]}
   ss[ssp--]=""
}




info $LINENO
# ( x1 x2 -- x2 x1 ) swap top two string stack elements
revealheader "swap$"
code swapstr swapstr
function swapstr {
   temp=$stos
   stos=${ss[ssp]}
   ss[ssp]=$temp
}




info $LINENO
# ( x1 x2 -- x1 x2 x1 ) copies next-of-stack of string stack to top
revealheader "over$"
code overstr overstr
function overstr {
   ss[++ssp]=$stos
   stos=${ss[ssp-1]}
}




info $LINENO
# ( x1 x2 -- x2 ) discards next-of-stack string stack element
revealheader "nip$"
code nipstr nipstr
function nipstr {
   ss[ssp--]=""
}




info $LINENO
# ( x1 x2 x3 -- x2 x3 x1 ) rotate 3rd string stack element to top
revealheader "rot$"
code rotstr rotstr
function rotstr {
   temp=${ss[ssp]}
   ss[ssp]=$stos
   stos=${ss[ssp-1]}
   ss[ssp-1]=$temp
}




info $LINENO
# ( --  ) joins top two string stack elements together
revealheader "merge$"
code mergestr mergestr
function mergestr {
   stos="${ss[ssp--]}$stos"
}



info $LINENO
# ( a1 n1 n -- a2 n2 ) return first n chars of string, or discard last -n chars from string on string stack
revealheader "left$"
code leftstr leftstr
function leftstr  {
   if [ $tos -lt 0 ] ; then
      (( tos+=${#stos} ))
      if [ $tos -lt 0 ] ; then
         tos=0
      fi
   fi
   stos=${stos:0:$tos}
   tos=${s[sp--]}
}   




info $LINENO
# ( a1 n1 n -- a2 n2 ) return last n chars of string, or discard first -n chars from string
revealheader "right$"
code rightstr rightstr
function rightstr  {
   if [ $tos -lt 0 ] ; then
      tos=$(( -$tos ))
   else
      tos=$(( ${#stos} - $tos ))
      if [ $tos -lt 0 ] ; then
         tos=0
      fi
   fi
   stos=${stos:$tos}
   tos=${s[sp--]}
}


info $LINENO
# ( a n -- ) creates header. expects ascii array type string
revealheader "create$"
code createstr createstr
function 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
function dodoes {
   s[++sp]=$tos
   tos=$w			# push body addr
   r[++rp]=$ip
   ip=$1			# nest using does> action
}




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




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





	     

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



throw[1]="aborted"
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]="word 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 without catch frame - top level error handler
code exception exception
function exception {
   if [ $tos -lt 0 ] ; then
      if [ "${throw[$(( -$tos ))]}" = "" ] ; then
         echo "caught $tos"
      else
         echo ${throw[$(( -$tos ))]}
      fi
   else
      echo "caught $tos"
   fi
   w=$warm
   ${m[w++]]}
}


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

brthrow0=$throw0



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


info $LINENO
# ( n -- ) part of catch / throw exception handling mechanism
revealheader "throw"
code throw throw
function throw {
   if [ $tos -eq 0 ] ; then
      tos=${s[sp--]}
   else
      if [ $catchframe -eq 0 ] ; then
         exception
      else
         rp=$catchframe
         catchframe=${r[rp--]}
         sp=${r[rp--]}
         ip=${r[rp--]}
      fi
   fi
}    



info $LINENO
# ( -- ) 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








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


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



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


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



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


info $LINENO
# ( <stream> -- w# | 0 ) returns 0 or xt of next word in input stream 
revealheader "find"
colon find         $bl $stream $locate $qdup $branch0 3 $branch 2 $notfound 



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




info $LINENO
# ( <stream> -- a ) return execution token of word which name is read from input stream
revealheader "'"
colon tick         $find $name_from


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



info $LINENO
# ( n1 -- n2 ) convert into number of memory locations
revealheader "cells"     
revealheader "chars"     
colon cells
immediate


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


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


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


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


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


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

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

info $LINENO
# ( <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

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



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


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


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


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




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


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



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


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


info $LINENO
# ( <stream> -- c ) return ascii of next char on stack
revealheader 'char'
colon char         $bl $stream $drop $cfetch $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


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


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


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


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


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


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


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


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

var innerloop


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

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





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


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


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


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



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


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


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









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





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





info $LINENO
# ( a n -- ) interpreter for a single word
revealheader "interpret1"
colon interpret1			\
   $dup2 $locate  			\
   $qdup $branch0 23			\
      $nip $nip				\
      $dup $name_from			\
      $swap $qimm $equ0			\
      $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				\
   $drop2				\
   $notfound




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








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


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


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


# ( n -- )
code line line
function line {
   echo "${f[tos]}"
   s[++sp]=${f[tos]}
   unset f[tos]
   tos=${m[tib+1]}
   m[in+1]=$tos
   unpack
   m[tos+${m[tib+1]}]=255
   tos=${s[sp--]}
}



info $LINENO
# ( <stream> -- ) read forth source from file
revealheader "include"
colon include    		\
	$bl $stream $from		\
        $zero $doruntime 6	\
        $i $line		\
	$interpret		\
        $loopruntime -4         \
        $endfrom



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

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

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


#info $LINENO
# ( a n fam -- fileid ior ) 
#revealheader "create-file"
#code create-file create-file
#function 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 ---------------------------------
# -----------------------------------------------------------------------------


# ( a c -- )
code saveas saveas
function saveas  {
   pack
   echo "bashforth_v$version memory dump" > $tos
   echo "${m[*]}" >> $tos
   echo "${h[*]}" >> $tos
   echo "$wc" >> $tos
   echo "${hf[*]}" >> $tos
   echo "${x[*]}" >> $tos
}


info $LINENO
# ( <stream> -- ) write image of system to file, file name taken from input stream
revealheader "save-system"
colon savesystem    $bl $stream $saveas


# doesn't work
#info $LINENO
# ( a c -- )
#code loadfrom loadfrom
#function loadfrom  {
#   pack
#   temp="$(cat $tos |sed -n 1p)"
#   if [ "$temp" != "bashforth_v$version memory dump" ] ; then
#      echo version mismatch
#   else
#      m=("$(cat $tos |sed -n 2p)")  ; echo "${m[*]}"
#      h=("$(cat $tos |sed -n 3p)")  ; echo "${h[*]}"
#      wc=("$(cat $tos |sed -n 4p)") ; echo "${wc}"
#      hf=("$(cat $tos |sed -n 5p)") ; echo "${hf[*]}"
#      x=("$(cat $tos |sed -n 6p)")  ; echo "${x[*]}"
#   fi
#   echo loading done
#}


#info $LINENO
# ( <stream> -- )
#revealheader "load"
#colon load     $bl $stream $loadfrom








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

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



info $LINENO
# ( ??? -- )
revealheader "(quit)"
colon bracketquit                       \
   $init_stacks				\
   $leftbracket				\
   $query				\
   $interpret				\
   $prompt				\
   $branch -4

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




info $LINENO
# ( ??? -- )
revealheader "(warm)"
colon warmhandler $init_stacks   $lit 10 $base $store   $zero $innerloop $store  $prompt $quit

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





info $LINENO
# ( -- ) prints GPL notice
revealheader "license"
code license license
function 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
"
}




info $LINENO
# ( -- ) prints the opening screen
revealheader "hello"
code hello hello
function hello {
   echo -e "\nBashForth v$version"
   license
   echo
   echo    "   email:    bashforth@forthfreak.net"
   echo    "   www:      http://www.forthfreak.net"
   echo    "   icq:      107248697"
   echo
   echo    "   words <enter>       shows a list of available words"
   echo    "   doc word  <enter>   gives description of word"
   echo 
}






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

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

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


# ( a -- )  
code sourceline sourceline
function sourceline {
   tos=${m[tos-1]}
}



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


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




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

# calls cat and tail
# ( -- )
code printsource printsource
function printsource {
     echo $0
     cat $0 | sed 1,${tos}d |
     while read LINE ; do
        if [ "$LINE" == "" ] ; then
           break
        fi
        echo $LINE
     done
     tos=${s[sp--]}
}


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






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

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

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

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

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

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

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

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

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

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



info $LINENO
# ( color -- ) set foreground color
revealheader "fg"
code fg fg
function fg {
   (( tos &= 7 ))
   echo -ne "\e[3${tos}m"
   attributes=$(( ($attributes & -16) | $tos ))
   tos=${s[sp--]}
}

info $LINENO
# ( color -- ) set background color
revealheader "bg"
code bg bg
function bg {
   tos=$(( $tos & 7 ))
   echo -ne "\e[4${tos}m"
   attributes=$(( ($attributes & -241) | ($tos<<4) ))
   tos=${s[sp--]}
}

info $LINENO
# ( -- ) reset colors and attributes to normal
revealheader "normal"
code normal normal
function normal {
   attributes=112
   echo -ne "\e[0m"
}


info $LINENO
# ( -- ) set bold attribute
revealheader "bold"
code bold bold
function bold {
   attributes=$(( ($attributes & -257) | 256 ))
   echo -ne "\e[1m"
}


info $LINENO
# ( -- ) set underscore attribute
revealheader "underscore"
code underscore underscore
function underscore {
   attributes=$(( ($attributes & -513) | 512 ))
   echo -ne "\e[4m"
}


info $LINENO
# ( -- ) reverse screen colors
revealheader "reverse"
code reverse reverse
function reverse {
   colors
   fg
   bg
}


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


info $LINENO
# ( u -- ) set all screen attributes, incl color, as read with attr@
revealheader "attr!"
code attrstore attrstore
function attrstore {
   attributes=$tos
   echo -ne "\e[3$(( $tos & 7 ));4$(( ($tos>>4) & 7 ))"
   temp=$(( ($tos>>8) & 1 ))
   if [ $temp -ne 0 ] ; then
      echo -ne ";$temp"
   fi
   temp=$(( ($tos>>7) & 4 ))
   if [ $temp -ne 0 ] ; then
      echo -ne ";$temp"
   fi
   echo -n "m"
   tos=${s[sp--]}
}


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



info $LINENO
# ( x y -- ) position cursor at x,y
revealheader "at"
code atxy atxy
function atxy {
   echo -ne "\e[$(( $tos+1 ));$(( ${s[sp--]}+1 ))H"
   tos=${s[sp--]}
}


#info $LINENO
# ( -- x y ) returns cursor position. doesn't work yet
#revealheader "?at"
#code qat qat
#function qat {
#   s[++sp]=$tos
#   read -s -d R -e -p $(echo -e "\e[6n") tos
#   echo "doesn't work yet. result is $tos"
#   tos=${s[sp--]}  
#}




info $LINENO
# ( -- ) position cursor at upper left
revealheader "home"
code home home
function home {
   echo -ne "\e[H"
}




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



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



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







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


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


info $LINENO
# ( -- ) shells to bash
revealheader "bash"
code shellbash bash


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


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



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


info $LINENO
# ( n -- ) returns #seconds since 1970jan1
revealheader "epoche"
code epoche epoche
function epoche {
   s[++sp]=$tos
   tos=$(date +%s)
}





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


cold=$dp
   compile $init_stacks $hello $cr $warm




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


i=${#remove[*]}
while [ $i -ne 0 ] ; do
   unset ${remove[--i]}
done




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


ip=$cold
while :
do
   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++]}
   w=${m[ip++]} ; ${m[w++]}
done



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