Version 13 of Basic in Tcl

Updated 2011-05-13 13:51:37 by RLE

Richard Suchenwirth 2000-08-21 - 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

RFox This is nice stuff. A little nitpick however; the original basic allowed variables that were letter digit pairs e.g A, A0, A1...A9... Z9. I don't recall if the original Dartmouth BASIC had string variables or not (A$, A1$...etc). While we're on BASIC. The name of the language is actually an acronym. Anyone here besides me remember what it stood for?

SEH Beginners All-purpose Symbolic Instruction Code.


KPV Just an historic note. BASIC was invented in the 1964 at Dartmouth College by John Kemeny and Thomas Kurtz. By the time I was there (1980-85), the language, now called BASIC 7, had evolved into a very nice structured language with both advanced matrix operations and very excellent graphics capabilities (part of which I wrote). In many ways, BASIC 7 graphics was/is superior to tk, especially with its built-in chart and 3-D drawing routines.

Unfortunately, the BASIC known (and denigrated) by most of the world has a different ancestry. In the mid-70's Paul Allen, Bill Gates and Monte Davidoff created a version for Altair 8800 microcomputer. It was an extremely bare-bones version implementating only a few of the language's features. They then ported it to many other platforms, most notably the Apple ][ (my first programming language) and the IBM-PC. It was these versions, with its heavy reliance on line numbers and goto's which became widely popular--and widely derogated as promoting bad programming practices.

LV Perhaps you might consider writing comperable functionality for Tk, for distribution in the core? KPV Well, there's a 3-D to 2-D transformation package embedded in Octabug, but a full-blown version is too big a project for my weekend endeavors.


gold

     # partial basic interpreter in TCL.
     #  Reorganized code for drag and drop on script
     #  to Etcl console.
     # written on Windows XP on eTCL
     # working under TCL version 8.5.6 and eTCL 1.0.1
     # on TCL WIKI , 10may2011

  console show
  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
 

 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
 }

 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 ""
 }
  
 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
 }