Version 8 of A different FORTH

Updated 2002-12-11 20:50:13

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 (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 $::$ end] [set ::S [lrange $::S 0 end-1]]}

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.


 # Stack Primitives
 #
 proc T  { } { lindex $::S end   }                      ;# Top value
 proc S  { } { lindex $::S end-1 }                      ;# Second value

 # Stack Ops
 #
 proc psh { x } { lappend ::S $x }                      ;# Push value stack
 proc K { x y } { set x }
 proc pop { } { K [T] [set ::S [lrange $::S 0 end-1]] } ;# Pop  value stack

 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.