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 (added later to hold loop indicies). 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. After jcw's comment (above), I deleted a little more code in the ":" proc and used a definition of pop similar to his, although now I might have to admit that I'm reaching for brevity at the expence of simplicity here. ---- I just had to add control structures. I got down my copy of starting FORTH and changed the ":" proc. Now we have a FORTH to tcl translator the inner loop executing FORTH words as compiled tcl. The definitions are not exactally right, I just noticed that LOOP should test at the bottom not the top, but this could be extended to include all of the FORTH control structures. -- JBR, evening 12/11/2002 ---- # Stack Primitives # set S {} ;# Stack set R {} ;# Return Stack (for loop indicies) proc T { } { lindex $::S end } ;# Top value proc S { } { lindex $::S end-1 } ;# Second value proc R { } { lindex $::R end } ;# Top of return stack proc CR { } { puts "" } # Stack Ops # proc psh { x } { lappend ::S $x } ;# Push value stack proc pop { } { lindex [list [T] [set ::S [lrange $::S 0 end-1]]] 0 } ;# Pop value stack proc ! { } { set ::[pop] [pop] } ;# Set named reference top to value proc @ { } { psh [set ::[pop]] } ;# Get named reference top proc . { } { puts -nonewline "[pop] " } ;# Print top proc drop { } { pop } proc swap { } { set ::S [lreplace ::S end-1 end [T] [S]] } 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 } { set code {} foreach word $list { switch -- $word { if { set word "if \{ \[pop] \} \{" } then { set word \} } else { set word "\} else \{" } do { set word "swap; >R; >R; \n\ while \{ \[lindex \$::R end] <= \[lindex \$::R end-1] \} \{" } loop { set word "set ::R \[lreplace \$::R end end \[expr \[R]+1]] \n\ \}; set ::R \[lrange \$::R 0 end-2]" } +loop { set word "set ::R \[lreplace \$::R end end \[expr \[R]+\[pop]]]\n\ \}; set ::R \[lrange \$::R 0 end-2]" } } lappend code $word } proc $name { } [join $code "\n"] } proc >R { } { lappend ::R [pop] } proc I { } { psh [lindex $::R end] } proc J { } { psh [lindex $::R end-2] } proc K { } { psh [lindex $::R end-4] } : Two 2 : setX { X ! } : dotX { X @ . } : Test { Two 4 * 45 + setX dotX CR } Test ;# --> 53 : BranchTest { if True . else False . then CR } : TestTrue { 1 BranchTest } : TestFalse { 0 BranchTest } TestTrue ;# True TestFalse ;# False : TestSwap { First Second swap . . CR } TestSwap ;# First then Second : TestLoop { 10 0 do I . loop } TestLoop : TestLoop2 { 3 1 do 5 1 do J I * . loop loop CR } TestLoop2 : Test+Loop2 { 3 1 do 6 1 do J I * . 2 +loop loop CR } Test+Loop2 ---- [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].