lttb/lttb.tcl

#!/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

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} {
  set kw [string range [lttb_stripspace $pline] 0 1]
  if {[string index $kw 1] eq {=}} {
    set kw LE
    set pline [string cat {LE } $pline] 
  }
  if {$kw in {EN GO IF IN LE PR RE}} {
    set bi [string first { } $pline]
    set body [string trim [string range $pline $bi end]]
    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} {
  if {$num eq {}} {return 0}
  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
}

# Simple evaluation helper
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 [rand 0 $(($v2 + 32768) % 32768)] }
    {+} { 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]
}

# Tiny BASIC expression evaluator (single-pass)
proc lttb_eval {lttb_ex} {
  global vars
  # 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))]}
  lassign {{( 0 + 1 - 1 * 2 / 2 $ 3} {} {} {} {} 0} precmap valbuf prevc valstack opstack i
  set l [string length $lttb_ex]
  for {set i 0} {$i < $l} {incr i} {
    set c [string index $lttb_ex $i]
    if [string is space $c] {continue}
    if [string is digit $c] {
      append valbuf $c
    } else {
      if {$valbuf ne {}} {
        lappend valstack [lttb_norm $valbuf]
        set valbuf {}
      }
      if {[string range $lttb_ex $i $($i+2)] eq {RND}} {
        set c {$}
        incr i 2
      } elseif {[string is upper $c]} {
        lappend valstack [lttb_norm $vars($c)]
      } elseif {$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}
      }
      if {$c in {+ - * / $}} {
        if {$c in {+ -} && $prevc in {{} ( + - * / $}} {
          lappend valstack 0
        }
        while {[llength $opstack] > 0 && $precmap([lindex $opstack end]) >= $precmap($c) } {
          eval_helper valstack opstack
        }
        lappend opstack $c
      }
    }
    set prevc $c
  }
  if {$valbuf ne {}} {lappend valstack [lttb_norm $valbuf]}
  while {[llength $opstack] > 0} {eval_helper valstack opstack}
  return [lttb_norm [lindex $valstack 0]]
}

# 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 IF LET {=} RETURN GOSUB INPUT PRINT GOTO END} {
    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 [split [lttb_stripspace $inputbuf] ,]
  loop i 0 $vlen {
    set vname [string index [lindex $varlist $i] 0]
    set vars($vname) [lttb_eval [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 int_LIST {} {
  global progmem
  foreach i [lsort -integer [dict keys $progmem]] {
    if {$progmem($i) ne {}} {
      puts [format "%d\t%s" $i $progmem($i)]
    }
  }
}

proc int_RUN {} {
  global progmem ip
  set ip 1
  while {$ip > 0 && $ip < 32768} {
    if {[dict exists $progmem $ip] && [string first REM $progmem($ip)] != 0} {lttb_exec $progmem($ip)}
    incr ip
  }
}

proc int_CLEAR {} {
  global progmem callstack vars ip
  lassign {{} {} {} 0} progmem callstack vars ip
  loop i 65 91 {set vars([format {%c} $i]) 0}
}

proc int_LOAD {fname} {
  if {$fname eq {}} {
    puts -nonewline "File name? "
    stdout flush
    stdin gets fname
  }
  if {[file exists $fname]} {
    int_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 int_SAVE {} {
  global progmem
  puts -nonewline "File name? "
  stdout flush
  stdin gets fname
  set fh [open $fname w]
  foreach i [lsort -integer [dict keys $progmem]] {
    if {$progmem($i) ne {}} {
      $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} {int_LOAD [lindex $argv 0]}

while {1} {
  puts -nonewline {> }
  stdout flush  
  set cmd [string toupper [string trim [stdin gets]]]
  switch -exact -- $cmd {
    BYE {puts "Bye!"; break}
    RUN {int_RUN; continue}
    LIST {int_LIST; continue}
    NEW - CLEAR {int_CLEAR; continue}
    LOAD {int_LOAD {}; continue}
    SAVE {int_SAVE; continue}
    default {lttb_proginput $cmd}
  }
}