A different FORTH

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 (added later to hold loop indicies).

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 $::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.

Category Language