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.

After [RS] made his comment (below) about the code's brevity I actually looked at it in the light of
what I have learned from RS and the rest of the active Wiki authors and I've given it the once over.

Now I'd say its brief.  I'm still stumped about a way to make pop a one liner. - [RS]: Easy if you have the famous K combinator ;-):
 proc K {x y} {set x}
 proc pop {} {K [lindex $::S end] [set ::S [lrange $::S 0 end-1]]}

11dec02 [jcw] - Pesky types like me would say that this is still a two-liner.  How about...
 proc pop {} {lindex [list $::S [set ::S [lrange $::S 0 end-1]]] end}
''Untested code ... (cool stuff, btw!)''
----
I knew that K would be the answer but I couldn't see that I should put the value I wanted to keep first.
Code updated just so I can say that I've used the [K] (I'd never used end-1 eighter) Thanks -- JBR.

----

 # Stack Primitives
 #
 proc T  { } { lindex $::S end   }                      ;# Top value
 proc S  { } { lindex $::S end-1 }                      ;# Second value

 # Stack Ops
 #
 proc psh { x } { lappend ::S $x }                      ;# Push value stack
 proc K { x y } { set x }
 proc pop { } { K [T] [set ::S [lrange $::S 0 end-1]] } ;# Pop  value stack

 proc ! { } { set ::[pop] [pop] }               ;# Set named reference top to value
 proc @ { } { psh [set ::[pop]] }               ;# Get named reference top

 proc .    { } { puts [pop] }                   ;# Print top
 proc drop { } { pop }                          ;# Drop  top

 proc unknown { args } { psh $args }            ;# Push anything thats not a proc (values)


 # Construct a set of useful binary operators
 #
 proc stkops { args } {
     foreach op $args {
         proc $op { }  "set ::S \[lreplace \$::S end-1 end \[expr \[T] $op \[S]]]"
     }
 }
 stkops  + - * / % | & ^ || == <= >=

 proc : { name list } {
     proc $name { } [list eval [join $list "\n"]]
 }

 : Two    2
 : setX { X ! }
 : dotX { X @ . }

 : Test {
     Two 4 *
     45 +
     setX dotX
 }

 Test   ;# --> 53


----
[RS]: I really like this code for its brevity - and the [unknown] redirection ;-) My own attempts in that direction, also a little old, are at [RPN in Tcl].