# Note that it is possible to define any word either in Tcl ({}) format or Forth
# comment... everything between ( and ) words is ignored ... ) must be its own word
: ( {concat [list $stack] [list $rstack] [list [lindex [pivot $args )] 1]]} ;
: ( {concat [list $stack] [list $rstack] [list [lindex [pivot [lindex $args 0] )] 1]]} immediate ;
# stack operations:
: swap {list [concat [lrange $stack 0 end-2] [lindex $stack end] [lindex $stack end-1]] $rstack $args} ;
: dup {list [concat $stack [lindex $stack end]] $rstack $args} ;
: over {list [concat $stack [lindex $stack end-1]] $rstack $args} ;
: rot {list [concat [lrange $stack 0 end-3] [lrange $stack end-1 end] [lindex $stack end-2]] $rstack $args} ;
: drop {list [lrange $stack 0 end-1] $rstack $args} ;
: 2swap {list [concat [lrange $stack 0 end-4] [lrange $stack end-1 end] [lrange $stack end-3 end-2]] $rstack $args} ;
: 2dup {list [concat $stack [lrange $stack end-1 end]] $rstack $args} ;
: 2over {list [concat $stack [lrange $stack end-3 end-2]] $rstack $args} ;
: 2drop {list [lrange $stack 0 end-2] $rstack $args} ;
# return stack operations:
: >r {list [lrange $stack 0 end-1] [concat $rstack [lindex $stack end]] $args} ;
: r> {list [concat $stack [lindex $rstack end]] [lrange $rstack 0 end-1] $args} ;
: i {list [concat $stack [lindex $rstack end]] $rstack $args} ;
: i' {list [concat $stack [lindex $rstack end-1]] $rstack $args} ;
: j {list [concat $stack [lindex $rstack end-2]] $rstack $args} ;
# unary operations:
: 1- {list [forth2op [concat $stack 1] -] $rstack $args} ;
: 1+ {list [forth2op [concat $stack 1] +] $rstack $args} ;
: 2- {list [forth2op [concat $stack 2] -] $rstack $args} ;
: 2+ {list [forth2op [concat $stack 2] +] $rstack $args} ;
: 2* {list [forth2op [concat $stack 2] *] $rstack $args} ;
: 2/ {list [forth2op [concat $stack 2] /] $rstack $args} ;
: abs {list [forth1op $stack abs] $rstack $args} ;
: sqrt {list [forth1op $stack sqrt] $rstack $args} ;
: negate {list [forth1op $stack -] $rstack $args} ;
: 0= ( n -- f ) 0 = ;
: 0< ( n -- f ) 0 < ;
: 0> ( n -- f ) 0 > ;
: not {list [forth1op $stack !] $rstack $args} ;
: ?dup {set top [lindex $stack end] ; if {$top} {lappend stack $top} ; list $stack $rstack $args} ;
# binary operations:
: + {list [forth2op $stack +] $rstack $args} ;
: - {list [forth2op $stack -] $rstack $args} ;
: * {list [forth2op $stack *] $rstack $args} ;
: / {list [forth2op $stack /] $rstack $args} ;
: mod {list [forth2op $stack %] $rstack $args} ;
: /mod ( u1 u2 -- u-rem u-quot ) over over mod rot rot / ;
: < {list [forth2op $stack <] $rstack $args} ;
: <= {list [forth2op $stack <=] $rstack $args} ;
: = {list [forth2op $stack ==] $rstack $args} ;
: >= {list [forth2op $stack >=] $rstack $args} ;
: > {list [forth2op $stack >] $rstack $args} ;
: and {list [forth2op $stack &&] $rstack $args} ;
: or {list [forth2op $stack ||] $rstack $args} ;
: min {list [forth2op $stack , min] $rstack $args} ;
: max {list [forth2op $stack , max] $rstack $args} ;

# ternary operations:
: between ( n n1 n2 -- f ) rot swap over >= rot rot <= and ;
: */ ( n1 n2 n3 -- n1*n2/n3 ) rot rot * swap / ;
: */mod ( u1 u2 u3 -- u1*u2/u3-rem u1*u2/u3-quot ) rot rot * swap /mod ;

# ascii operations:
: ascii {set a [string index $args 0] ; set b [lrange $args 1 end] ; binary scan $a c x ; concat [list $stack] [list $rstack] [list [concat $x $b]]} ;
: ascii {set a [string index [lindex $args 0] 0] ; set b [lrange [lindex $args 0] 1 end] ; binary scan $a c x ; concat [list $stack] [list $rstack] [list [concat $x $b]]} immediate ;
: emit {puts -nonewline [binary format c [lindex $stack end]]; list [lrange $stack 0 end-1] $rstack $args } ;
: cr 10 emit ;
: space 32 emit ;
: spaces {
 for {set i [lindex $stack end]} {$i > 0} {incr i -1} {puts -nonewline " "}
 list [lrange $stack 0 end-1] $rstack $args
} ;
#control structures
: iff {
 set list1 [pivot $args then]
 set body [lindex $list1 0]
 set rest [lindex $list1 1]
 set retval {}
 if {[llength $body]} {
 set list2 [pivot $body else]
 set main [lindex $list2 0]
 if {[llength $main]} {
 set else [lindex $list2 1]
 } else {
 set main $body
 set else {}
 }
 if {[lindex $stack end]} {
 set retval $main
 } else {
 set retval $else
 }
 }
 list [lrange $stack 0 end-1] $rstack [concat $retval $rest]
} ;
: do {
 set list1 [pivot $args +loop]
 set body [lindex $list1 0]
 set rest [lindex $list1 1]
 if {[llength $body]} { # used do ... +loop construct (specified increment)
 set inc [lindex $body end]
 set body [lrange $body 0 end-1]
 } else { # used do ... loop construct (increment of 1 implicit)
 set inc 1
 set list1 [pivot $args loop]
 set body [lindex $list1 0]
 set rest [lindex $list1 1]
 }
 if {[llength $body]} {
 lappend rstack [lindex $stack end] [lindex $stack end-1]
for {set stack [lrange $stack 0 end-2]} {[lindex $rstack end] < [lindex $rstack end-1]} {set rstack [concat [lrange $rstack 0 end-1] [expr [lindex $rstack end] + $inc]]} {
set retval [eval feval [list $stack] [list $rstack] [list {}] $body]
 set stack [lindex $retval 0]
 set rstack [lindex $retval 1]
 }
 set rstack [lrange $rstack 0 end-2]
 }
 list $stack $rstack $rest
} ;
: begin {
 set list1 [pivot $args until]
 set body [lindex $list1 0]
 set rest [lindex $list1 1]
if {[llength $body]} { # used begin ... until construct
 for {set flag 0} {! $flag} {set stack [lrange $stack 0 end-1]} {
set retval [eval feval [list $stack] [list $rstack] [list {}] $body]
 set stack [lindex $retval 0]
 set rstack [lindex $retval 1]
 set flag [lindex $stack end]
 }
 } else { # used begin ... while ... repeat construct
 set list1 [pivot $args repeat]
 set body [lindex $list1 0]
 set rest [lindex $list1 1]
if {[llength $body]} {
 set list2 [pivot $body while]
 set body1 [lindex $list2 0]
 set body2 [lindex $list2 1]
for {set flag 1} {$flag} {if {$flag} {
 set retval [eval feval [list $stack] [list $rstack] [list {}] $body2]
 set stack [lindex $retval 0]
 set rstack [lindex $retval 1]
 }} {
set retval [eval feval [list $stack] [list $rstack] [list {}] $body1]
 set stack [lindex $retval 0]
 set rstack [lindex $retval 1]
 set flag [lindex $stack end]
 set stack [lrange $stack 0 end-1]
 }
 }
 }
list $stack $rstack $rest
} ;
: leave { # ( -- ) r> drop i >r
 list $stack [concat [lrange $rstack 0 end-1] [lindex $rstack end-1]] $args };
: var {
 set name [lindex $args 0]
 set def [concat list \[lappend stack $name\] \$rstack \$args]
proc $name {{stack {}} {rstack {}} args} $def
 list $stack $rstack [lrange $args 1 end]
} ;
: constant {
 set val [lindex $stack end]
 set name [lindex $args 0]
 set def [concat list \[lappend stack $val\] \$rstack \$args]
puts "defining proc $name as $def"
 proc $name {{stack {}} {rstack {}} args} $def
 list [lrange $stack 0 end-1] $rstack [lrange $args 1 end]
} ;
: ! {
 global [set varname [lindex $stack end]]
set $varname [lindex $stack end-1]
 list [lrange $stack 0 end-2] $rstack $args
} ;
: @ {
 global [set varname [lindex $stack end]]
 list [concat [lrange $stack 0 end-1] [set $varname]] $rstack $args
} ;
: +! ( n ptr -- ) swap ( ptr n ) over ( ptr n ptr ) @ + swap ( n2 ptr ) ! ;
: ? ( ptr -- ) @ . space ;
: .' {
 set list1 [pivot $args \']
 set text [lindex $list1 0]
 set rest [lindex $list1 1]
if {[llength $text]} {
 puts -nonewline "$text"
 } elseif {[lindex $args 0] eq "\'"} {
 space
 } else {
 error "missing ' after .' $rest" ;
 }
 list $stack $rstack $rest
} ;
: . {
 puts -nonewline [lindex $stack end]
 list [lrange $stack 0 end-1] $rstack $args
} ;
: .s {
 puts -nonewline "$stack"
 list $stack $rstack $args
} ;
: quit { error [list $stack $rstack $args] } ;