Version 2 of Trying FORTH in Tcl

Updated 2002-12-11 15:07:55

Prompted by a discussion on the Chat, here's another little experiment - this time to bring a Forth-like system into Tcl -JCW


# basic stack operations, for use in primitives

  proc D> {} {
    global ds
    set r [lindex $ds end]
    set ds [lreplace $ds end end]
    return $r
  }

  proc D< {v} {
    global ds
    lappend ds $v
    return $v
  }

# grab the next token from the code strem

  proc token {} {
    global rs
    set pc [lindex $rs end]
    set op [lindex $rs end-1 [incr pc]]
    lset rs end $pc
    return $op
  }

# the core processing loop runs while the return stack has code

  proc "" {} {
    global rs
    set rs [lreplace $rs end-1 end]
  }

  proc execute {args} {
    # pc = previous counter
    # op = opcode
    # ds = data stack
    # rs = return stack

    global ds rs

    lappend rs $args -1

    while {[llength $rs]} {
      set op [token]
      if {[info exists ::$op]} {
        lappend rs [set ::$op] -1
      } elseif {[llength [info procs $op]] > 0} {
        $op
      } else {
        lappend ds $op
      }
    }
    puts -nonewline "\n$ds: "
  }

# primitive definitions are words which are coded as a Tcl proc

  proc . {}     { puts -nonewline "[D>] " }                     ;# s-
  proc emit {}  { puts -nonewline [format %c [D>]] }            ;# n-

  proc + {}     { set x [D>]; D< [expr {[D>] + $x}] }           ;# nn-n
  proc - {}     { set x [D>]; D< [expr {[D>] - $x}] }           ;# nn-n
  proc * {}     { set x [D>]; D< [expr {[D>] * $x}] }           ;# nn-n
  proc / {}     { set x [D>]; D< [expr {[D>] / $x}] }           ;# nn-n

  proc @ {}     { set x [D>]; D< [lindex [D>] $x] }             ;# na-s
  proc ! {}     { set x [D>]; set y [D>]; lset $x $y [D>] }     ;# sna-

  proc ' {}     { D< [token] }
  proc -> {}    { set ::[token] [D>] }

# high-level Forth-like definitions can be created in Tcl

  proc : {name args} {
    global $name
    set $name $args
  }

  : cr   10 emit ;

# test code

  execute 3
  execute 2 * 4 + .

  : one  1 . ;
  : 2+   2 + ;
  : t1   3 2+ . ;

  execute one cr t1

  execute {11 22 33} 1 @ .

  execute {44 55 66} -> v1

  execute ' v1 1 @ .

See also: RPN in Tcl | Tcl and other languages