345 lines
8.9 KiB
Tcl
Executable File
345 lines
8.9 KiB
Tcl
Executable File
#!/usr/bin/env jimsh
|
|
# Luxferre's Truly Tiny BASIC (Jim Tcl implementation)
|
|
# Based upon the original Tiny BASIC Design Notes by Dennis Allison
|
|
# Created in 2026 by Luxferre, released into the public domain
|
|
|
|
set lttb_keywords {EN GO IF IN LE PR RE}
|
|
lassign {{} {} {} 0} progmem callstack vars ip
|
|
loop i 65 91 {set vars([format {%c} $i]) 0}
|
|
|
|
# Input line parser (single-pass)
|
|
proc lttb_proginput {rawline} {
|
|
set rawline [string trim $rawline]
|
|
if {[string length $rawline] > 0} {
|
|
lassign {0 0} lno i
|
|
set l [string length $rawline]
|
|
loop i $l {
|
|
set c [string index $rawline $i]
|
|
if {[string is space $c] || [string is digit $c]} {
|
|
if {[string is digit $c]} {set lno $($lno * 10 + int($c))}
|
|
} else {break}
|
|
}
|
|
set linebody [string toupper [string range $rawline $i end]]
|
|
# populate program memory or execute directly
|
|
if {$lno > 0} {
|
|
global progmem
|
|
dict set progmem $lno $linebody
|
|
} else {lttb_exec $linebody}
|
|
}
|
|
}
|
|
|
|
# Main line interpreter
|
|
proc lttb_exec {pline} {
|
|
global lttb_keywords
|
|
set kw [string range [lttb_stripspace $pline] 0 1]
|
|
if {[string index $kw 1] eq {=}} {
|
|
set kw LE
|
|
set pline [string cat {LE } $pline]
|
|
}
|
|
set bi [string first { } $pline]
|
|
set body [string trim [string range $pline $bi end]]
|
|
if {$kw in $lttb_keywords} {
|
|
if {$kw eq {GO} && [string index $pline 2] eq {S}} {
|
|
lttb_GOS $body
|
|
} else {lttb_$kw $body}
|
|
}
|
|
}
|
|
|
|
# Integer number normalizer (for TB-valid signed 16-bit range)
|
|
proc lttb_norm {num} {
|
|
set num $(int($num))
|
|
if {($num > 32767) || ($num < -32768)} {
|
|
set num $($num % 65536)
|
|
if {$num > 32767} {incr num -65536}
|
|
}
|
|
return $num
|
|
}
|
|
|
|
# Whitespace remover
|
|
proc lttb_stripspace {s} {return [regsub -all -- {\s} $s ""]}
|
|
|
|
# List pop helper
|
|
proc _lpop {list_var} {
|
|
upvar $list_var l
|
|
if {[llength $l] == 0} {return 0}
|
|
set val [lindex $l end]
|
|
set l [lreplace $l end end]
|
|
return $val
|
|
}
|
|
|
|
# Tiny BASIC expression evaluator (two-pass)
|
|
proc lttb_eval {lttb_ex} {
|
|
# pre-checks
|
|
set lttb_ex [string trim $lttb_ex]
|
|
if {$lttb_ex eq {}} {return 0}
|
|
if {[string is digit $lttb_ex]} {return [lttb_norm $(int($lttb_ex))]}
|
|
# pass 1: variable and parentheses substitution
|
|
global vars
|
|
lassign {{(((} {}} pre_ex prevc
|
|
foreach c [split $lttb_ex {}] {
|
|
set outc {}
|
|
if {[string is digit $c]} {set outc $c}
|
|
if {[string is upper $c]} {set outc $vars($c)}
|
|
if {$c eq "$"} {set outc [rand 0 10000]}
|
|
if {$c eq "("} {set outc {(((}}
|
|
if {$c eq ")"} {set outc {)))}}
|
|
if {$c eq "*" || $c eq "/"} {set outc [string cat {)} $c {(}]}
|
|
if {$c eq "+" || $c eq "-"} {
|
|
if {$prevc in {{} ( + -}} {
|
|
set outc [string cat 0 $c]
|
|
} else {set outc [string cat {))} $c {((}] }
|
|
}
|
|
append pre_ex $outc
|
|
set prevc $c
|
|
}
|
|
append pre_ex {)))}
|
|
# pass 2: two-stack LTR evaluator
|
|
local proc eval_helper {vsvar osvar} {
|
|
upvar $vsvar valstack
|
|
upvar $osvar opstack
|
|
set res 0
|
|
set op [_lpop opstack]
|
|
set v2 [_lpop valstack]
|
|
set v1 [_lpop valstack]
|
|
switch -exact -- $op {
|
|
"+" { set res $($v1 + $v2) }
|
|
"-" { set res $($v1 - $v2) }
|
|
"*" { set res $($v1 * $v2) }
|
|
"/" { if {$v2 != 0} {set res $(int($v1 / $v2))} }
|
|
default { error "Unknown operator: $op" }
|
|
}
|
|
lappend valstack [lttb_norm $res]
|
|
}
|
|
lassign {{} {} {}} valbuf valstack opstack
|
|
set precmap {+ 1 - 1 * 2 / 2}
|
|
foreach c [split $pre_ex {}] {
|
|
if {[string is space $c]} {continue}
|
|
if {[string is digit $c]} {
|
|
append valbuf $c
|
|
} else {
|
|
if {[string length $valbuf] > 0} {
|
|
lappend valstack $(int($valbuf))
|
|
set valbuf {}
|
|
}
|
|
if {$c eq {(}} {
|
|
lappend opstack $c
|
|
} elseif {$c eq {)}} {
|
|
while {[llength $opstack] > 0 && [lindex $opstack end] ne "("} {
|
|
eval_helper valstack opstack
|
|
}
|
|
if {[lindex $opstack end] eq "("} {_lpop opstack}
|
|
} elseif {$c in {+ - * /}} {
|
|
set prec $precmap($c)
|
|
while {[llength $opstack] > 0} {
|
|
set top_op [lindex $opstack end]
|
|
if {$top_op eq "("} { break }
|
|
if {$precmap($top_op) >= $prec} {
|
|
eval_helper valstack opstack
|
|
} else { break }
|
|
}
|
|
lappend opstack $c
|
|
}
|
|
}
|
|
}
|
|
while {[llength $opstack] > 0} {eval_helper valstack opstack}
|
|
set res [lindex $valstack 0]
|
|
if {$res eq {}} {set res 0}
|
|
return $res
|
|
}
|
|
|
|
# Tiny BASIC routines implementing various commands
|
|
|
|
proc lttb_LE {stmt} {
|
|
global vars
|
|
lassign [split $stmt =] vname ex
|
|
set vname [string index [string trim $vname] 0]
|
|
set vars($vname) [lttb_eval $ex]
|
|
}
|
|
|
|
proc lttb_IF {stmt} {
|
|
lassign {-1 -1 {} 0} thenpos restpos relop istrue
|
|
regexp -indices -- {[>=<][>=<]*} $stmt rores
|
|
lassign $rores ropos roend
|
|
set relop [string range $stmt $ropos $roend]
|
|
set expr1 [string range $stmt 0 $($ropos-1)]
|
|
set rest [string range $stmt $($roend + 1) end]
|
|
foreach kw {THEN LET {=} RETURN GOSUB INPUT PRINT GOTO END IF} {
|
|
set thenpos [string first $kw $rest]
|
|
if {$thenpos > -1} {
|
|
if {$kw eq {=}} {incr thenpos -1}
|
|
set restpos $thenpos
|
|
if {$kw eq {THEN}} {incr restpos 4}
|
|
break
|
|
}
|
|
}
|
|
set expr2 [string range $rest 0 $($thenpos - 1)]
|
|
set exdif $([lttb_eval $expr1] - [lttb_eval $expr2])
|
|
switch -exact -- $relop {
|
|
{=} {set istrue $($exdif == 0)}
|
|
{><} - {<>} {set istrue $($exdif != 0)}
|
|
{>} {set istrue $($exdif > 0)}
|
|
{<} {set istrue $($exdif < 0)}
|
|
{>=} {set istrue $($exdif >= 0)}
|
|
{<=} {set istrue $($exdif <= 0)}
|
|
}
|
|
if {$istrue} {lttb_proginput [string range $rest $restpos end]}
|
|
}
|
|
|
|
proc lttb_GO {stmt} {
|
|
global ip
|
|
set ip $([lttb_eval $stmt] - 1)
|
|
}
|
|
|
|
proc lttb_GOS {stmt} {
|
|
global ip callstack
|
|
lappend callstack $ip
|
|
set ip $([lttb_eval $stmt] - 1)
|
|
}
|
|
|
|
proc lttb_RE {stmt} {
|
|
global ip callstack
|
|
set ip [_lpop callstack]
|
|
}
|
|
|
|
proc lttb_IN {stmt} {
|
|
global vars
|
|
set varlist [split [lttb_stripspace $stmt] ,]
|
|
set vlen [llength $varlist]
|
|
puts -nonewline {? }
|
|
stdout flush
|
|
set inputbuf [string toupper [string trim [stdin gets]]]
|
|
set inputlist [lmap s [split [lttb_stripspace $inputbuf] ,] {
|
|
lttb_eval $s
|
|
}]
|
|
loop i 0 $vlen {
|
|
set vname [string index [lindex $varlist $i] 0]
|
|
set vars($vname) [lindex $inputlist $i]
|
|
}
|
|
}
|
|
|
|
proc lttb_PR {stmt} {
|
|
lassign {0 {} {}} quoting printlist item
|
|
# Build the printlist
|
|
foreach c [split $stmt {}] {
|
|
if {$c eq {"}} {
|
|
set quoting $(1 - $quoting)
|
|
append item $c
|
|
} elseif {$quoting} {
|
|
append item $c
|
|
} elseif {$c in {; ,}} {
|
|
if {[string length $item] > 0} {
|
|
lappend printlist $item
|
|
set item {}
|
|
}
|
|
lappend printlist $c
|
|
} elseif {[string is graph $c]} {
|
|
append item $c
|
|
}
|
|
}
|
|
if {[string length $item] > 0} {lappend printlist $item}
|
|
# Iterate over the printlist
|
|
foreach item $printlist {
|
|
if {[string index $item 0] eq {"}} {
|
|
puts -nonewline [string trim $item {"}]
|
|
} elseif {$item eq {,}} {
|
|
puts -nonewline "\t"
|
|
} elseif {$item ne {;}} {
|
|
puts -nonewline [lttb_eval $item]
|
|
}
|
|
}
|
|
if {$item ni {; ,}} {puts {}}
|
|
stdout flush
|
|
}
|
|
|
|
proc lttb_EN {stmt} {
|
|
global ip callstack
|
|
lassign {-1 {}} ip callstack
|
|
}
|
|
|
|
# Interactive-only routines start here
|
|
|
|
proc ext_LIST {} {
|
|
global progmem
|
|
loop i 1 32768 {
|
|
if {[dict exists $progmem $i]} {
|
|
puts [format "%d\t%s" $i $progmem($i)]
|
|
}
|
|
}
|
|
}
|
|
|
|
proc ext_RUN {} {
|
|
global progmem ip
|
|
set ip 1
|
|
while {$ip > 0 && $ip < 32768} {
|
|
if {[dict exists $progmem $ip]} {lttb_exec $progmem($ip)}
|
|
incr ip
|
|
}
|
|
}
|
|
|
|
proc ext_CLEAR {} {
|
|
global progmem callstack vars ip
|
|
lassign {{} {} {} 0} progmem callstack vars ip
|
|
loop i 65 91 {set vars([format {%c} $i]) 0}
|
|
}
|
|
|
|
proc ext_LOAD {fname} {
|
|
if {$fname eq {}} {
|
|
puts -nonewline "File name? "
|
|
stdout flush
|
|
stdin gets fname
|
|
}
|
|
if {[file exists $fname]} {
|
|
ext_CLEAR
|
|
set fh [open $fname r]
|
|
while {![eof $fh]} {
|
|
$fh gets progline
|
|
set progline [string trim $progline]
|
|
if {$progline ne {}} {lttb_proginput $progline}
|
|
}
|
|
$fh close
|
|
puts [format {Loaded %s} $fname]
|
|
} else {puts {Given file doesn't exist, skipping!}}
|
|
}
|
|
|
|
proc ext_SAVE {} {
|
|
global progmem
|
|
puts -nonewline "File name? "
|
|
stdout flush
|
|
stdin gets fname
|
|
set fh [open $fname w]
|
|
loop i 1 32768 {
|
|
if {[dict exists $progmem $i]} {
|
|
$fh puts [format {%d %s} $i $progmem($i)]
|
|
}
|
|
}
|
|
$fh flush
|
|
$fh close
|
|
puts [format {Saved %s} $fname]
|
|
}
|
|
|
|
# Interpreter entry point
|
|
|
|
puts {----------------------------
|
|
Luxferre's Truly Tiny BASIC
|
|
Jim Tcl Edition
|
|
@Copyleft 2026
|
|
All wrongs reserved
|
|
----------------------------}
|
|
|
|
if {$argc > 0} {ext_LOAD [lindex $argv 0]} else {ext_CLEAR}
|
|
|
|
while {1} {
|
|
puts -nonewline {> }
|
|
stdout flush
|
|
set cmd [string toupper [string trim [stdin gets]]]
|
|
switch -exact -- $cmd {
|
|
BYE {puts "Bye!"; break}
|
|
RUN {ext_RUN; continue}
|
|
LIST {ext_LIST; continue}
|
|
NEW - CLEAR {ext_CLEAR; continue}
|
|
LOAD {ext_LOAD {}; continue}
|
|
SAVE {ext_SAVE; continue}
|
|
default {lttb_proginput $cmd}
|
|
}
|
|
}
|