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 about the code's brevity I actually looked at my code 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.
# Stack Primitives
#
proc Si { } { expr { [llength $::S] - 2 } } ;# Index of second
proc T { } { lindex $::S end } ;# Top value
proc S { } { lindex $::S [Si] } ;# Second value
# Stack Ops
#
proc psh { x } { lappend ::S $x } ;# Push value stack
proc pop { } { ;# Pop value stack
set T [T]
set ::S [lrange $::S 0 [Si]]
return $T
}
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 \[Si] 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.