\ Small Basic by Herbert Schildt, 1988
\ debugged, optimized, enhanced and converted to 4tH by J.L. Bezemer, 2009-2012

include lib/istype.4th                 \ for IS-ALPHA
include lib/row.4th                    \ for ROW
include lib/enter.4th                  \ for ENTER
include lib/choose.4th                 \ for CHOOSE

\ For typical Minimal Basic programs 
\ You need about 32 labels per 1K sourcecode

   16 constant #for                    \ maximum nesting of FORs
   32 constant #gosub                  \ maximum nesting of GOSUBs
  512 constant #label                  \ maximum number of labels
  256 constant #element                \ maximum number of array elements
16384 constant /program                \ maximum size of a uBASIC program
                                       \ character constants
  8 constant /tab                      \ size of a tab
 10 constant lf                        \ ASCII of lf
  9 constant tab                       \ ASCII of tab
 13 constant <cr>                      \ ASCII of cr
  0 constant <null>                    \ ASCII of \0
                                       \ token types
  0 enum {NONE}                        \ undetermined
    enum {DELIMITER}                   \ is a delimiter
    enum {VARIABLE}                    \ is a variable
    enum {NUMBER}                      \ is a number
    enum {KEYWORD}                     \ is a keyword
constant {QUOTE}                       \ is a quoted string
                                       \ error constants
  1 enum E.FINISHED                    \ program finished
    enum E.SYNTAX                      \ syntax error
    enum E.MISSING                     \ unbalanced parenthesis
    enum E.NOEXPR                      \ no expression
    enum E.EQUEXP                      \ = expected
    enum E.NOTVAR                      \ not a variable
    enum E.LBLFULL                     \ label table full
    enum E.DUPLBL                      \ duplicate label
    enum E.UDEFLBL                     \ undefined lavel
    enum E.TOEXP                       \ TO expected
    enum E.NESTFOR                     \ FOR nesting too deep
    enum E.NOFOR                       \ previous FOR expected
    enum E.NESTSUB                     \ GOSUB nesting too deep
constant E.NOGOSUB                     \ previous GOSUB expected
                                       \ constants for commands
  0 enum 'PRINT'                       \ PRINT
    enum 'INPUT'                       \ INPUT
    enum 'IF'                          \ IF
    enum 'THEN'                        \ THEN
    enum 'FOR'                         \ FOR
    enum 'NEXT'                        \ NEXT
    enum 'TO'                          \ TO
    enum 'CHOOSE'                      \ CHOOSE
    enum 'GOTO'                        \ GOTO
    enum 'EOL'                         \ EOL
    enum 'FINISHED'                    \ "FINISHED"
    enum 'GOSUB'                       \ GOSUB
    enum 'RETURN'                      \ RETURN
    enum 'REM'                         \ REM
    enum 'LET'                         \ LET
    enum 'NOOP'                        \ NOOP
constant 'END'                         \ END
                                       \ mapping tokens to keywords
create look_up
  ," print"  'PRINT' ,
  ," input"  'INPUT' ,
  ," if"     'IF' ,
  ," then"   'THEN' ,
  ," goto"   'GOTO' ,
  ," for"    'FOR' ,
  ," next"   'NEXT' ,
  ," to"     'TO' ,
  ," choose" 'CHOOSE' ,
  ," gosub"  'GOSUB' ,
  ," return" 'RETURN' ,
  ," rem"    'REM' ,
  ," let"    'LET' ,
  ," stop"   'END' ,
  ," end"    'END' ,
  NULL ,
does> 2 string-key row 2swap 2drop if cell+ @c else drop null then ;
                                       \ error messages
create .error
  ," System failure"
  ," Ok"
  ," Syntax error"
  ," Missing bracket or quote"
  ," No expression present"
  ," Equals sign expected"
  ," Not a variable"
  ," Label table full"
  ," Duplicate label"
  ," Undefined label"
  ," TO expected"
  ," Too many nested FOR loops"
  ," NEXT without FOR"
  ," Too many nested GOSUBs"
  ," RETURN without GOSUB"
does> swap 0 max cells + @c cr count type cr ;

variable prog                          \ pointer to current execution

0 value ftos                           \ top of FOR stack
0 value gtos                           \ top of GOSUB stack

      96 string  token                 \ holding current token
       1 string  token_type            \ holding current token type
       1 string  tok                   \ holding current token representation
/program buffer: program

#gosub array gstack                    \ GOSUB stack
    26 array variables                 \ internal variables
                                       \ label structure
struct
  field: name                          \ name of label
  field: location                      \ location of label
end-struct /label
                                       \ label table
#label /label * array label_table does> swap /label * + ;
                                       \ index the label table
struct                                 \ FOR stack structure
  field: var                           \ FOR variable name
  field: target                        \ FOR variable target
  field: loc                           \ FOR variable location
end-struct /for
                                       \ FOR stack
#for /for * array fstack does> swap /for * + ;
                                       \ index FOR stack
#element array element                 \ single array of uBasic

defer level2
                                       \ define level2
: a< < ;                               \ less-than operands
: a> > ;                               \ greater-than operands
: a= = ;                               \ compare operands
: a# <> ;                              \ not equal operands
: a- - ;                               \ substract operands
: a+ + ;                               \ add operands
: a* * ;                               \ multiply operands
: a/ / ;                               \ divide operands
: a% mod ;                             \ modula operands
: a^ 0 max dup if over swap 1- 0 ?do over * loop nip else drop drop 1 then ;
                                       \ exponent operands
create arith                           \ map operators to words
  char < , ' a< ,
  char > , ' a> ,
  char = , ' a= ,
  char # , ' a# ,
  char - , ' a- ,
  char + , ' a+ ,
  char * , ' a* ,
  char / , ' a/ ,
  char % , ' a% ,
  char ^ , ' a^ ,                      \ automate operand execution
  NULL ,                               ( n1 n2 c -- n3)
does> 2 num-key row rot drop if cell+ @c execute else drop drop then ;

offset delims                          \ all delimiters
  bl c, char ; c, char , c, char + c, char - c, char < c, char > c, char / c,
  char * c, char % c, char ^ c, char = c, char ( c, char ) c, tab c, <cr>  c,
  <null> c, lf c, char # c, char : c,  \ there are 20 delimiters
                                       ( c -- f)
: isdelim 20 begin dup while over over 1- delims <> while 1- repeat nip 0<> ;
: iswhite dup dup bl = swap tab = rot <cr> = or or ;
: skipwhite prog @ begin dup c@ iswhite while char+ repeat prog ! ;
: token_type= token_type c@ = ;        ( -- f)
: tok@ tok c@ ;                        ( -- n)
: stoken token count ;                 ( -- a n)
: ctoken token c@ ;                    ( -- c)
: putback stoken negate prog +! drop ; ( --)
: EOL|FINISHED? tok@ dup 'EOL' = swap 'FINISHED' = or ;
: .number dup abs <# #s sign #> ;      ( n -- a n)

: find_eol                             ( --)
  prog @ begin dup c@ while dup c@ lf <> while char+ repeat
  dup c@ if char+ then prog !
;
                                       \ using the FOR and GOSUB stacks
: fpush                                ( var tar loc --)
  ftos >r r@ #for <                    \ stack within range?
  if
    r@ fstack -> loc !                 \ save location
    r@ fstack -> target !              \ save target
    r@ fstack -> var !                 \ save variable
    r> 1+ to ftos                      \ increment stack pointer
  else
    E.NESTFOR throw                    \ nesting too deep
  then
;

: fpop                                 ( -- tar loc var)
  ftos 1- dup dup to ftos 0<           \ stack within range?
  if
    E.NOFOR throw                      \ if not, issue error message
  else
    >r r@ fstack -> target @           \ restore target
       r@ fstack -> loc @              \ restore location
       r> fstack -> var @              \ restore variable
  then
;

: gpush                                ( n --)
  gtos >r r@ #gosub <                  \ stack within range
  if
    gstack r@ th !                     \ save pointer
    r> 1+ to gtos                      \ increment stack pointer
  else
    E.NESTSUB throw                    \ nesting too deep
  then
;

: gpop gstack gtos 1- dup dup to gtos 0< if E.NOGOSUB throw then th @ ;
                                       \ main parser routines
: copy>delimiter                       ( --)
  0 token prog @                       \ setup pointers and terminator
  begin                                \ start scanning
    dup c@ isdelim 0=                  \ stop when a delimiter is found
  while                                \ if not, copy and increment pointers
    over over c@ swap c! char+ swap char+ swap
  repeat prog ! c!                     \ save values, terminate token
;

: ="                                   \ quoted string routine
  0 token prog 1 over +! @             \ setup pointers and terminator
  begin                                \ skip the first quote
    dup c@ dup [char] " <>             \ stop when a quote is found
  while
    lf = if E.MISSING throw then       \ error when EOL is found
    over over c@ swap c!               \ if not, copy character
    char+ swap char+ swap              \ and increment pointers
  repeat                               \ get next character
  drop char+ prog ! c! {QUOTE}         \ skip final quote, terminate token
;                                      \ and signal the type of token found
                                       ( -- n)
: =null 0 token c! 'FINISHED' tok c! {DELIMITER} ;
: =lf 1 prog +! 0 token lf over c! cell+ c! 'EOL' tok c! {DELIMITER} ;
: =delim 0 token prog @ c@ over c! cell+ c! 1 prog +! {DELIMITER} ;
: =digit copy>delimiter {NUMBER} ;     ( -- n)
: =array copy>delimiter {VARIABLE} ;   ( -- n) 

create bnf                             \ translate chars to parser actions
  0 , ' =null , lf , ' =lf , char : , ' =lf , char + , ' =delim ,
  char - , ' =delim ,   char * , ' =delim ,   char ^ , ' =delim ,
  char / , ' =delim ,   char % , ' =delim ,   char = , ' =delim ,
  char ; , ' =delim ,   char ( , ' =delim ,   char ) , ' =delim ,
  char , , ' =delim ,   char > , ' =delim ,   char < , ' =delim ,
  char # , ' =delim ,   char " , ' ="     ,   char 0 , ' =digit ,
  char 1 , ' =digit ,   char 2 , ' =digit ,   char 3 , ' =digit ,
  char 4 , ' =digit ,   char 5 , ' =digit ,   char 6 , ' =digit ,
  char 7 , ' =digit ,   char 8 , ' =digit ,   char 9 , ' =digit ,
  char @ , ' =array ,   NULL ,
does> 2 num-key row if cell+ @c execute else drop {NONE} then ;

: get_token                            ( --)
  'NOOP' tok c! skipwhite              \ skip all leading white space
  prog @ c@ bnf dup {NONE} =           \ not found in the table above?
  if                                   \ if so,
    swap is-alpha                      \ is it an alpha character?
    if                                 \ if so,
      drop copy>delimiter              \ copy all upto the delimiter
      stoken look_up dup null =        \ see if it is a keyword or var
      if drop {VARIABLE} else tok c! {KEYWORD} then
    else                               \ is it a variable or command
      0 token c!                       \ terminate whatever is in the token
    then
  else                                 \ if found in the table
    nip                                \ drop the character
  then token_type c!                   \ update the token_type
;

: ctoken> get_token ctoken ;           ( -- c)
: get_exp 0 ctoken> if level2 putback else E.NOEXPR throw then ;
                                       ( -- n)
: get_element                          ( c -- v)
  [char] @ =                           \ is it an array?
  if                                   \ is there a parenthesis?
    ctoken> [char] ( = {DELIMITER} token_type= and
    if                                 \ if so, get the expression
      get_exp dup -1 > over #element < and
      if                               \ check if within bounds
        cells element +                \ calculate address
        ctoken> [char] ) = {DELIMITER} token_type= and 0=
        if E.MISSING throw then        \ missing parenthesis detected
      else E.NOTVAR throw              \ index out of bounds
      then
    else E.MISSING throw               \ missing parenthesis detected
    then
  else E.NOTVAR throw                  \ not an array
  then
;

: get_var                              ( c -- v)
  dup is-alpha if bl or [char] a - cells variables + else get_element then
;

: find_var get_var @ ;                 ( c -- n)
: skip_var get_token {VARIABLE} token_type= 0= if putback then ;
: var= ctoken> get_var ctoken> [char] = = ;
: assignment var= if get_exp swap ! else E.EQUEXP throw then ;
: label_init #label 0 ?do 0 i label_table -> name ! loop ;

: get_next_label                       ( n1 -- n2)
  >r 0                                 \ setup counter, save string
  begin
     dup dup #label <                  \ table full?
  while                                \ entry empty?
     drop dup label_table -> name @ dup 
  while                                \ label already defined?
     r@ = if E.DUPLBL throw then 1+
  repeat
  drop r> drop                         \ cleanup
  dup #label = if E.LBLFULL throw then 
;                                      \ table full, exit

: scan_labels                          ( --)
  label_init prog @                    \ save prog and init labels
  begin                                \ see if the next token is a number
    get_token {NUMBER} token_type=
    if                                 \ if so, add it to the label table
      stoken number dup get_next_label dup >r
      label_table -> name ! prog @ r>
      label_table -> location !
    then                               \ we don't need the rest of the line
    tok@ dup 'EOL' <> if find_eol then
    'FINISHED' =                       \ are we finished yet?
  until prog !                         \ if so, restore prog
;

: find_label                           ( n -- a)
  >r 0 begin                           \ setup counter, save string
    dup #label <                       \ within range?
  while                                \ compare labels
    dup label_table -> name @ r@ <>    \ get the name of the label
  while                                \ if found, exit loop
    1+                                 \ next entry
  repeat r> drop                       \ discard the string
  dup #label < if label_table -> location @ else E.UDEFLBL throw then
;                                      \ beyond range: signal label not found

: print                                ( --)
  0 true begin                         \ setup len and delimiter flag
    get_token EOL|FINISHED? 0=         \ if we're not finished
  while                                \ single PRINT always prints CR
    drop {QUOTE} token_type=           \ it is a quoted string?
    if stoken else putback get_exp .number then tuck type +
    ctoken> >r r@ [char] , = 
    if                                 \ are we dealing with a comma?
      /tab over over mod - dup spaces +
    else                               \ calculate and issue the spaces
      r@ [char] ; = EOL|FINISHED? or 0= if E.SYNTAX throw then
    then                               \ trailing chars means syntax error
    r@ [char] , <> r> [char] ; <> and dup 
  until                                \ no ; or , there is more coming
                                       \ issue a linefeed if needed
  EOL|FINISHED? if if cr then else E.SYNTAX throw then drop
;                                      \ trailing chars means syntax error

: exec_if                              ( --)
  get_exp if get_token tok@ 'THEN' <> if putback then else find_eol then
;                                      \ check for THEN

: exec_for                             ( --)
  var= if                              ( v n -- v)
    get_exp over ! get_token           \ get value and save in variable
    tok@ 'TO' =                        \ get the TO keyword
    if                                 \ when found, check for iterations
      get_exp over @ over >            \ if none, skip the entire loop
      if drop drop begin tok@ 'NEXT' <> while get_token repeat skip_var
      else prog @ fpush                \ if one or more, push the FOR frame
      then                             ( v t l --)
    else
      E.TOEXP throw                    \ TO wasn't found
    then
  else
    E.EQUEXP throw                     \ '=' wasn't found
  then
;

: next                                 ( --)
  fpop >r 1 r@ +! over r@ @ <          \ increment, target reached?
  if                                   \ if so, drop frame
    r> drop drop drop skip_var         \ and ignore any variable
  else                                 \ if not, jump back
    dup prog ! r> -rot fpush           \ and push frame again
  then
;

: exec_input                           ( --)
  get_token {QUOTE} token_type=        \ keyword followed by string?
  if                                   \ if so, type it and get variable
    stoken type ctoken> dup [char] , = swap [char] ; = or
    if get_token else E.SYNTAX throw then
  else                                 \ no separator, then syntax error
    ." ? "                             \ print only a question mark
  then enter ctoken get_var !          \ get value, store it in the variable
;
                                       ( --)
: exec_choose var= if get_exp choose swap ! else E.EQUEXP throw then ;
: exec_goto get_exp find_label prog ! ;
: gosub get_exp find_label prog dup @ gpush ! ;
: greturn gpop prog ! ;                \ return from GOSUB
: bye E.FINISHED throw ;               ( --)
: unary [char] - = if negate then ;    ( n1 c -- n2)

: primitive                            ( -- n)
  token_type c@ dup                    \ get token type, VAR or NUMBER
  {VARIABLE} = if drop ctoken find_var else
  {NUMBER}   = if stoken number else
               E.SYNTAX throw then     \ return VAR, NUMBER or throw error
  then get_token                       \ get next token
;
                                       ( n1 -- n2)
: level7                               \ parenthesis found?
  {DELIMITER} token_type= ctoken [char] ( = and
  if                                   \ evaluate and get next parenthesis
    get_token level2 ctoken [char] ) =
    if get_token else E.MISSING throw then
  else                                 \ error if no parenthesis found
    drop primitive                     \ must be a primitive
  then
;
                                       \ resolve unary -
: level6                               ( n1 -- n2)
  {DELIMITER} token_type= ctoken dup [char] + = swap [char] - = or and
  if ctoken get_token else 0 then >r level7 r> dup if unary else drop then
;                                      \ resolve power
                                       ( n1 -- n2)
: level5 level6 ctoken [char] ^ = if get_token 0 level5 [char] ^ arith then ;
                                       \ resolve div, mul and mod
: level4                               ( n1 -- n2)
  level5 0 begin                       \ setup loop
    ctoken dup [char] * = over [char] / = or over [char] % = or
  while                                \ repeat until all word done
    >r get_token level5 tuck r> arith swap
  repeat drop drop                     \ drop operator and 'hold' value
;
                                       \ resolve addition and substraction
: level3                               ( n1 -- n2)
  level4 0 begin                       \ setup loop
    ctoken dup [char] + = over [char] - = or
  while                                \ repeat until all word done
    >r get_token level4 tuck r> arith swap
  repeat drop drop                     \ drop operator and 'hold' value
;
                                       \ resolve logical operators
:noname                                ( n1 -- n2)
  level3 0 begin                       \ setup loop
    ctoken dup [char] # = over [char] = = or
    over [char] < = or over [char] > = or
  while                                \ repeat until all word done
    >r get_token level3 tuck r> arith swap
  repeat drop drop                     \ drop operator and 'hold' value
; is level2                            \ we've finally defined it!
                                       \ map tokens to words
: load_program                         ( a1 n1 a2 n2 --)
  input open error? abort" File loading error"
  >r r@ use 2dup accept r> close       \ signal loading error
  tuck = abort" Memory full" >string   \ signal memory full
;

create keyword
  'PRINT'    , ' print ,
  'GOTO'     , ' exec_goto ,
  'IF'       , ' exec_if ,
  'FOR'      , ' exec_for ,
  'NEXT'     , ' next ,
  'INPUT'    , ' exec_input ,
  'CHOOSE'   , ' exec_choose ,
  'GOSUB'    , ' gosub ,
  'RETURN'   , ' greturn ,
  'REM'      , ' find_eol ,
  'LET'      , ' assignment ,
  'END'      , ' bye ,
  'FINISHED' , ' bye ,
  NULL ,                               \ match keyword with word
does> 2 num-key row if nip cell+ @c execute else drop drop then ;
                                       \ if not listed, ignore
: interpret                            ( --)
  get_token {VARIABLE} token_type=     \ if it's a variable, assign it
  if putback assignment else tok@ keyword then
;                                      \ else assume it is a keyword

: ubasic                               ( --)
  argn 2 < abort" Usage: ubasic source-file" randomize
  program /program 1 args load_program
  program prog ! ['] scan_labels catch dup 0=
  if begin drop ['] interpret catch dup until then .error
;                                      \ enter interpretation loop

ubasic
