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!)*RS: pop

*is*a one-liner, and K is a useful tool in the box for many cases ;-)

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 either) 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.