I wrote this about a year ago and am prompted to post it now by [JCW]'s [Trying FORTH in Tcl] [JBR] 12/11/2002

Here FORTH is not nearly as faithfully reproduced as JCW's.  Missing are the ability 
to get at the input stream with token (word in FORTH?) and I have no return stack.
But code is eval'ed as a list and it makes the inner interpreter very fast.  unknown
is used there to push values onto the stack.


 # Stack Primitives
 #
 proc psh { x } {
        global S; lappend S $x
 }

 proc . { } {
        puts [T]; pop
 }

 proc pop { } {
        global S
        set t [expr [llength $S] -1]
        set s [expr $t - 1]
        set T [T]
        set S [lrange $S 0 $s]
        return $T
 }

 proc T { } {
        global S; lindex $S end
 }

 proc S { } {
        global S; lindex $S end
        set s [expr [llength $S] - 2]

        lindex $S $s
 }

 # Stack Ops
 #
 proc +  { } { stkop  + }
 proc -  { } { stkop  - }
 proc *  { } { stkop  * }
 proc /  { } { stkop  / }
 proc %  { } { stkop  % }
 proc |  { } { stkop  | }
 proc &  { } { stkop  & }
 proc ^  { } { stkop  ^ }
 proc && { } { stkop && }
 proc || { } { stkop || }
 proc == { } { stkop == }
 proc <= { } { stkop <= }
 proc >= { } { stkop >= }

 proc stkop { op } {
        global S
        set s [expr [llength $S] - 2]

        set S [lreplace $S $s end  [expr [T] $op [S]]]
 }

 proc ! { } {
        global S

        set var [pop]
        set val [pop]
        global $var
        set $var $val
 }


 proc @ { } {
        global S
        set v [lindex $S end]
        set t [expr [llength $S] - 1]

        global $v
        set S [lreplace $S $t $t [set $v]]
 }




 # Push me
 #
 proc unknown { args } {
        psh $args
 }

 proc 4th { args } {
        eval [string map { " " "\n" } [join $args]]
 }

 proc : { name list } {
           proc $name {} [list 4th $list]
 }

 : x { 1 1 . . }
 x

 puts $S