proc pivot {lst piv} { # return two lists separated by (removed) piv element
set pos [lsearch -exact $lst $piv]
list [lrange $lst 0 $pos-1] [lrange $lst $pos+1 end]
}
proc extrarg {lst argname} { # remove arg name field, return arg up front
set duo [pivot $lst $argname]
 set h [lindex $duo 0]
 set t [lindex $duo 1]
concat [list [lindex $t 0]] $h [lrange $t 1 end]
}
proc forth1op {stack oper} { # for definitions doing unary op on top stack element
set a [lindex $stack end]
concat [lrange $stack 0 end-1] [expr $oper ($a)] ;# the updated stack
}
proc forth2op {stack oper {prefix {}}} { # for definitions doing binary operations
set a [lindex $stack end-1]
 set b [lindex $stack end]
concat [lrange $stack 0 end-2] [expr $prefix ($a $oper $b)] ;#the updated stack
}
proc feval {stack rstack lineargs args} { # wrapper for forth definitions by ':'
 set retval [eval forth2 -stack [list $stack] -rstack [list $rstack] $args]
 list [lindex $retval 0] [lindex $retval 1] $lineargs
}
proc : {word firstarg args} { # define a new forth word
 set stack {}
 set rstack {}
if {[llength $firstarg] > 1} { # defined in terms of tcl commands
 set task $firstarg
 if {[lindex $args 0] eq "immediate"} {
 proc ${word}_imm {{stack {}} {rstack {}} args} $task
 return ;# must define any non-immediate version separately
 }
} else { # normal definitions in terms of other forth words
 set def $args
 set task { eval feval \$stack \$rstack \$args }
for {set inp $firstarg} {[llength $inp]} {set def [lrange $def 1 end]} {
if {"$inp" eq ":"} {
 error "illegal nested definition: $word $firstarg $args ;"
 }
if {[catch {${inp}_imm {} {} $def} result]} { # not immediate
 lappend task $inp
} else { # immediate, result is three lists: stack rstack revised-def
 set def [lindex $result 2]
 }
set inp [lindex $def 0] ;# grab head for next iteration
 }
}
proc $word {{stack {}} {rstack {}} args} $task
}
proc forth2 {args} { # act upon a list of forth constants/words
set trim $args
 set stack {}
 set rstack {}
foreach var {stack rstack} { # initial stack and rstack contents are options
 set val [extrarg $trim -$var]
 if {[llength $val] < [llength $trim]} { # match found, removed
 set $var [lindex $val 0]
 set trim [lrange $val 1 end]
 }
 }
while {[llength $trim]} {
 set word [lindex $trim 0]
 set rest [lrange $trim 1 end]
if {[string is double $word]} {
 lappend stack $word
 set trim $rest
} else {
 set result [eval $word [list $stack] [list $rstack] $rest]
 set stack [lindex $result 0]
 set rstack [lindex $result 1]
 set trim [lindex $result 2]
 }
 }
list $stack $rstack
}
proc forth {args} { # call forth2 and strip off to rstack, only return stack
 catch {eval forth2 $args} retval
 lindex $retval 0
}