Version 0 of Basic in Tcl

Updated 2000-08-21 10:13:45

Richard Suchenwirth -- So here we are, with one of the best programming languages in the world, and what do we do but try to emulate one of the worst? It's just the thought "Everything's possible with Tcl, even the impossible", some nostalgia (you get the kicks only if you really worked/played with BASIC in the 19[78]0's), and the sheer fun of programming.

I start with a small subset of the language, but arithmetic assignment, GOTO (see Goto in Tcl), ON..GOTO, FOR/NEXT, GOSUB/RETURN, IF and PRINT are there already.. Consider this call

 basic {
    100 J=1:K=1
    110 GOSUB 300
    120 PRINT I,J;K
    130 IF I<5 GOTO 110: REM DONE
    135 for a=100 to J+103
    137    print a
    140 next a
    150 END
    300 REM---------- slight increment
    310 I=I+J: K=K*2
    320 RETURN
 }

giving these results:

 1       1 2
 2       1 4
 3       1 8
 4       1 16
 5       1 32
 100
 101
 102
 103
 104

by using the following "compiler" (it produces Tcl code for a state machine)

 proc basic {script} {
    # old BASIC had 26 numeric variables..
    foreach i {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
        set $i 0
    }
    set states ""
    set Stack [list Error:Stack]
    foreach line [split [string toupper $script] \n] {
        if [regexp { *([0-9]+) +(.+)} $line -> label rest] {
            set outline ""
            foreach stmt [split $rest :] {
                set step 1
                if [regexp { ?('|REM)} $stmt] {
                    break ;# no statements to be expected after comment

                } elseif [regexp {PRINT +(.+)} $stmt -> what] {
                    regsub -all ", *" $what "\t" what
                    regsub -all "; *" $what " " what
                    regsub -all {([A-Z])} $what {$\1} what
                    append outline "puts \"$what\"; "

                } elseif [regexp {FOR +([A-Z]) *= *(.+) TO (.+)( STEP (.+))?} \
                        $stmt -> looper from to - step] {
                    regsub -all {([A-Z])} $from {$\1} from
                    regsub -all {([A-Z])} $to {$\1} to
                    set here -[intgen]
                    set step 1 ;# to start with
                    set next($looper) "incr $looper $step; if {\$$looper<=$to} {goto $here}"
                    append outline "set $looper $from\}\n$here \{"

                } elseif [regexp {NEXT (.+)} $stmt -> id] {
                    append outline $next($id)
                    unset next($id)

                } elseif [regexp {IF +([^ ]+) +(THEN|GOTO) +([0-9]+)}\
                        $stmt -> cond - goto] {
                    regsub -all {([A-Z])} $cond {$\1} cond
                    append outline "if {$cond} {goto $goto}; "

                } elseif [regexp {ON (.+) GOTO +(.+)} $stmt -> cond labels] {
                    regsub -all {([A-Z])} $cond {$\1} cond
                    append outline "goto \[lindex \{- [split $labels ,]\} \[expr $cond\]\]; "   

                } elseif [regexp {GO *TO ([0-9]+)} $stmt -> id] {
                    append outline "goto $id; "

                } elseif [regexp {GO *SUB ([0-9]+)} $stmt -> id] {
                    set here -[intgen]
                    append outline "lpush Stack $here; goto $id\}\n$here \{ "

                } elseif [regexp {RETURN} $stmt] {
                    append outline "goto \[lpop Stack\]; "

                } elseif [regexp { *END} $stmt] {
                    append outline "break; "
                } elseif [regexp {([A-Z])=(.+)} $stmt -> lhs rhs] {
                    regsub -all {([A-Z])} $rhs {$\1} rhs
                    append outline "set $lhs \[expr $rhs\]; "  
                } 
            }
            append states "$label {$outline}\n"
        }
    }
    states $states
 }

The output of basic, what is fed into states, is a mix of Basic labels and Tcl code, and looks like this:

 100 {set J [expr 1]; set K [expr 1]; }
 110 {lpush Stack -1; goto 300}
 -1 { }
 120 {puts "$I   $J $K"; }
 130 {if {$I<5} {goto 110}; }
 135 {set A 100}
 -2 {}
 137 {puts "$A"; }
 140 {incr A 1; if {$A<=$J+103} {goto -2}}
 150 {break; }
 300 {}
 310 {set I [expr $I+$J]; set K [expr $K*2]; }
 320 {goto [lpop Stack]; }

and here is the little state machine that processes this:

 proc states body {
    proc goto {id} {uplevel set goto $id; return -code continue}
    uplevel set goto [lindex $body 0]
    set tmp [lindex $body 0]
    foreach {cmd label} [lrange $body 1 end] {
        if {$label==""} {set label default}
        lappend tmp "$cmd; goto [list $label]" $label
    }
    lappend tmp break ;# to match last "default" label
    uplevel while 1 "{switch -- \$goto [list $tmp]}"
    rename goto ""
 }

See Retrocomputing for a matching old-fashioned display... RPN in Tcl for a first shot at a FORTH-like Reverse Polish Notation interpreter.


Here are some helper procs: lpush and lpop to make a stack, intgen to generate unique integers, which (with prefixed minus) serve as generated labels in FOR and GOSUB constructs (they cannot collide with real line numbers, since these are positive ;-):

 proc lpush {_list what} {
    upvar $_list L
    if ![info exists L] {set L {}}
    set L [concat [list $what] $L]
 }
 proc lpop {_list} {
    upvar $_list L
    if ![info exists L] {return ""}
    set t [lindex $L 0]
    set L [lrange $L 1 end]
    return $t
 }
 proc intgen {{seed 0}} {
    set self [lindex [info level 0] 0]
    proc $self "{seed [incr seed]}" [info body $self]
    set seed
 } ;# RS