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+Loop2RS: 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.
