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 104by 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
# partial basic language interpreter
# Reorganized code from, http://wiki.tcl.tk/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
gold 23sep2018, 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
}