Updated 2008-12-07 01:28:51 by LEG

Some references:

Although there are already some Forth emulations in Tcl, this one has - of course - a distinct focus: it is an intent, to integrate Forth and Tcl as harmonically as possible.

f4t extends the Tcl interpreter with a data stack and natural RPN operations. Just like A different FORTH it makes use of the unknown function, however only numbers (integer and float) are pushed on the stack.

There is a wealth of possibilities to implement different aspects of a Forth System in Tcl. f4t strives to be be most simple and understandable in implementation, and to implement a subset of the ANS Forth wordsets, i.e., names and semantics are cloned from there. f4t can be used for simple scripts, but is not intended to be of production use or for big programs.

As of now, f4t is incomplete, just stack operations, some math, the colon compile and IF,ELSE,THEN are implemented. The following is not the whole thing, but rather a tutorial introduction to the building concepts.
 #   The Tcl syntax (man tcl) is expanded in the following  way:
 #
 #   1. Each line is Tcl-interpreted as usual
 #   2. If the first word is unknown, the line is forth-interpreted,
 #      which removes the word itself, and maybe some more text from
 #      the line.
 #   3. The rest of the line is Tcl-interpreted
 #
 #   Since Tcl already interprets the characters [ ] ;
 #   which are essential to forth, we cannot - and need not - make use
 #   of them.  Compilation always stops at the end of line or ;
 #   whichever comes first.  You can use line continuation to create
 #   forth words longer then one line.
 #
 #   Traditionally forth uses uppercase letters, this stems from times
 #   where teletypes did not have a shift key.  We take advantage from
 #   this and write all forth words in UPPERCASE.  Thus you can switch
 #   to and fro "forth context" with CAPS LOCK when writing TF Tcl
 #   scripts, and when you read TF Tcl scripts you can switch mentally
 #   to the stack model whenever you see an uppercase WORD.

... Here comes the interpreter, we use the array "FORTH" as dictionary. FORTH(DUP) contains a Tcl script, which implements the semantic of DUP.
 namespace eval forth {
    array set FORTH {}
    variable STATE 0   HERE {}

    proc defined {word} {# find word
        variable FORTH
        info exists FORTH($word)}

    proc ' word {#return code of word
        variable FORTH
        set FORTH($word)}
    namespace export '

    # Note: we use the functions compile LITERAL and reveal,  which
    # are safely defined later.  While we have no compiler we never
    # need them.
    proc interpret {word} {
        variable STATE
        if $STATE {compile $word} else [' $word]}

    proc number word {
        variable STATE
        if [catch {expr $word+0}] {error "$word ?"}
        if $STATE {LITERAL $word} else {PUSH $word}}

    proc evaluate {word args} {# forth interpret word
        variable S
        variable STATE

        if [defined $word] {interpret $word} \
        else {number $word}

        if [llength $args] {namespace eval :: $args} \
        else {
            if $STATE {reveal} else {return [tos S]}}}
 }

... and here is the compiler:
 namespace eval forth {

    proc (nest) args {# recurse the forth interpreter
        variable R
        upvar \#3 args line
        push R $line
        eval $args
        eval [pop R]}

    proc (lit) {number args} {# push number on stack
        PUSH $number
        if [llength $args] {evaluate $args}}

    proc word {name body} {# craft a forth primitive
        # forth primitives don't have arguments, they operate on the
        # stacks only
        variable FORTH
        set FORTH($name) $name
        proc $name {} $body}

    proc compile word {# insert word in the current definition
        variable FORTH; variable HERE
        append FORTH($HERE) $word " "}

    proc LITERAL number {
        compile (lit); compile $number}

    proc HEADER name {
        variable FORTH; variable HERE $name
        set FORTH($HERE) {}}

    proc reveal {} {# end compilation
        variable STATE 0; variable HERE {}}

 }

... Forth "primitives" are Tcl procedures, defined in the ::forth namespace. The wordlist FORTH(DUP) just contains the name of the procedure to execute. These are found by the interpreter when executing 'evaluate' as the unknown function.

Forth colon definitions however are lists of the names of Forth words, preceded by the (nest) function. When (nest) is executed, it pushes the currently executed line (the rest of it) to R and starts to (Tcl) eval the list of (Forth) commands stored in the callee's FORTH(...) definition.

So let's start building those primitives:
 # STACKS: are implemented as arrays.  This might seem odd, since Tcl
 #   normally implements stacks as lists.  However it allows as to
 #   encapsulate stacks as a data type and to access all of its members
 #   quickly, intuitively and consistently. Last not least: i like Tcl
 #   arrays.

...

A handful of stack manipulation primitives are defined in a proper namespace; see [Implementing Stacks with Arrays]. These are used to define the Forth stack manipulation words, both for data and return stack. The f4t Forth words are defined in their own namespace 'forth', as we do not want them to be found by the Tcl interpreter loop:
 namespace eval forth {

    # Create the data and return stack of the forth engine
    namespace import ::stack::*
    init S
    init R

    word >R {# ( n -- ) (R: -- n )
        variable S; variable R
        push R [pop S]}

    word R> {# ( -- n ) (R: n -- )
        variable S; variable R
        push S [pop R]}

    word R@ {# ( -- n ) (R: n -- n )
        variable S; variable R
        push S [tos R]}

    word PICK {# ( ni .. n i -- .. n ni )
        variable S; push S [index S [pop S]]}

    word DUP {# ( n -- n n )
        0 PICK}

    word OVER {# ( n1 n2 -- n1 n2 n1 )
        1 PICK}

... and so on.

Most math functions work in a similar way, so we generate them 'automatically':
 # Math primitives, Logical and bitwise operations

namespace eval forth {
 proc op1 op {# apply an unary operator to tos
        variable S
        push S [expr $op [pop S]]}

    foreach {word operator} {
        INVERT ~   LSHIFT <<   RSHIFT >>
        NEGATE -   0= !
    } {word $word "op1 $operator"}

    proc op2 op {# apply a two argument operator to the stack
        variable S
        push S [expr [pop S] $op [pop S]]}

    foreach {word operator} {
        + +   - -   * *   / /   MOD %   < <   > >   = ==
        AND &       OR |  XOR ^
    } {word $word "op2 $operator"}

...

And here comes the flow control. We have two elements, the (if) procedure which is compiled into the definition of a colon word, and IF ELSE THEN, which do the compiling and manipulate the Forth code in such a way, that (if) 'sees' one or two { lists } of Forth code, which it executes conditionally on behalf of the top of stack.

IF ELSE THEN are so called "immediate" words, they are executed during compilation of a word. We do not need to implement an "IMMEDIATE" flag, we just define or export the procedure to the global namespace, so the procedure is always found before the Forth extension to unknown is invoked.
 namespace eval forth {
    proc (if) {t {e {}} args} {
        variable S
        eval [expr [list [pop S] ? $t : $e]]}

    proc IF args {
        variable FORTH; variable HERE
        compile (if); compile \{
        eval $args}

    proc THEN args {
        compile \}
        eval $args}

    proc ELSE args {
        compile \}; compile \{
        eval $args}

    namespace export IF THEN ELSE
 }

Finally we have two commands to start/stop the f4t extensions: proc f4t {} {# set up Forth for Tcl
    namespace import ::forth::*
    if ![catch {info args unknown}] {rename unknown TFuk}
    interp alias {} unknown {} ::forth::evaluate
    puts "Forth 4 Tcl"}

proc BYE {} {
    rename unknown {}
    if ![catch {info args TFuk}] {rename TFuk unknown}

}

after invoking "4ft" from the tclsh, you can do fancy stuff like:
 set result [3 4 +]; 3 OVER *

and you will get 21 as the result of this line

Oh: want to inspect the stack?!

# Stack utility and Tcl glue functions
 namespace eval forth {

    proc . {} {# ( n -- )
        variable S
        puts -nonewline [pop S]
        flush stdout}

    proc .s {{i 0}} {#print the stack, withouth altering it
        variable S
        if $i {
            incr i -1
            puts -nonewline " [index S $i]"
            .s $i
            return}}
    proc .S {} {
        variable S; .s [top S]; flush stdout}

    proc PUSH value {# push a value to the forth stack
        variable S; push S $value}

    proc EMPTY {} {# empty the data stack
        variable S; init S}

    proc >S args {# push result of script args to data stack
        # useful as in: .. >S tcl script; FORTH WORDS ..
        PUSH [eval $args]}

    namespace export .S PUSH EMPTY >S .
 }