Basic in Tcl
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
} ;# RSRFox 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 # [RS} source code above left unchanged.
# partial basic language interpreter
# Reorganized code from, https://wiki.tcl-lang.org/915
# 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 , 12may2011
#start of deck
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
} ;#RS
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 ""
} ;#RS
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
}
#end of deck
possible modified code
gold 23sep2018,Above Basic_RS code left unchanged, but possible modified code statements. Added cosmetics and "self_help" to "basic" in windows console.
# add cosmetics below to bottom of file or source Basic_RS.tcl
console show
console eval {.console config -bg palegreen}
console eval {.console config -font {fixed 20 bold}}
console eval {wm geometry . 40x20}
console eval {wm title . "Basic_RS in TCL , screen grab and paste from console to texteditor"}
console eval {. configure -background orange -highlightcolor brown -relief raised -border 30}
console eval { proc self_helpx {} {
set msg "Basic_RS in TCL, large black type on green
from TCL,
self help listing
Conventional text editor formulas grabbed
from internet screens can be pasted
into green console
# demo basic from RS, (wiki 2000-08-21) "
tk_messageBox -title "self_helpxx" -message $msg } }
console eval {.menubar.help add command -label Self_help -command self_helpx } 
gold Above Basic_RS code left unchanged, but possible modified code statements to output text.
if [regexp { ?('|REM)} $stmt] {
# wish to print all comments
puts $stmt
break ;# no statements to be expected after comment
} elseif [regexp { ?('|PRINT_TXT)} $stmt] {
# wish to print specific text
puts $stmt
break ;# no statements to be expected
basic {
50 REM gold on basic_RS, TCL 8.6
100 a=1.
137 print a
300 REM wish to print all REM strings
315 PRINT_TXT de on TCL 8.6
318 PRINT_TXT [* 5 6 ]
400 RETURN
}References
- BASIC
- en.wikipedia.org wiki BASIC
- en.wikipedia.org wiki QBasic