I wrote this about a year ago and am prompted to post it now by JCW's Trying FORTH in Tcl
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.
# Stack Primitives
#
proc psh { x } {
global S; lappend S $x
}
proc . { } {
puts [T]; pop
}
proc pop { } {
global S
set t [expr [llength $S] -1]
set s [expr $t - 1]
set T [T]
set S [lrange $S 0 $s]
return $T
}
proc T { } {
global S; lindex $S end
}
proc S { } {
global S; lindex $S end
set s [expr [llength $S] - 2]
lindex $S $s
}
# Stack Ops
#
proc + { } { stkop + }
proc - { } { stkop - }
proc * { } { stkop * }
proc / { } { stkop / }
proc % { } { stkop % }
proc | { } { stkop | }
proc & { } { stkop & }
proc ^ { } { stkop ^ }
proc && { } { stkop && }
proc || { } { stkop || }
proc == { } { stkop == }
proc <= { } { stkop <= }
proc >= { } { stkop >= }
proc stkop { op } {
global S
set s [expr [llength $S] - 2]
set S [lreplace $S $s end [expr [T] $op [S]]]
}
proc ! { } {
global S
set var [pop]
set val [pop]
global $var
set $var $val
}
proc @ { } {
global S
set v [lindex $S end]
set t [expr [llength $S] - 1]
global $v
set S [lreplace $S $t $t [set $v]]
}
# Push me
#
proc unknown { args } {
psh $args
}
proc 4th { args } {
eval [string map { " " "\n" } [join $args]]
}
proc : { name list } {
proc $name {} [list 4th $list]
}
: x { 1 1 . . }
x
puts $S