Trying FORTH in Tcl

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

A different FORTH by JBR

# 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 {
        # allows a character literal on the stack (as a single item)
        # so doesn't report bad words!!
        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} {
    # no compile mode so no immediate words!
    # can not be run as  execute :  ...  , i.e is not a forth word at all!
    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 @ .

Category Language