\ mowareBASIC
\ written by Heinrich Moser
\ http://www.heinzi.at
\
\ Some code parts are taken from comp.lang.forth

\ --------------
\ ALGEBRAIC MODE 
\ --------------
\
\ Usage: A[ 2 * ( 3 + 4 ) ]A

10 constant MAXLEVELS
create op MAXLEVELS 1+ 2 cells * allot

: ?INTERP ( ? xt -- ? )	state @ if compile, else execute then ;

\ OPERATION STACK
: ?OPMAX ( -- ) \ break if no more space on the operation stack
    op @ [ maxlevels 2 cells * ] literal >
    abort" expression too complex" ;

: OPP@ ( -- addr ) op dup @ + ;
: >OP ( xt lev -- ) 2 cells op +! ?opmax opp@ 2! ;
: OP> ( -- ) opp@ 2@ -2 cells op +! drop ?interp ;
: LEV? ( -- lev ) opp@ @ ;

: ]A ( -- ) begin lev? while op> repeat	previous ; immediate

: INFIX ( xt lev "infix op" -- )
    create , , immediate
  does> 2@ ( xt lev )
    begin dup lev? > 0= while ( xt lev )
            2>r ( ) op> 2r> ( xt lev ) repeat  >op ;

: NO-OP ;

vocabulary algebraic 
algebraic definitions

' * 7 infix *    ' / 7 infix /
' + 6 infix +    ' - 6 infix -
' > 5 infix >    ' < 5 infix <    ' = 5 infix =  ' <> 5 infix |

\ Other possible operators (more complex parser needed):
\ 8 infix negate negate
\ 5 infix <> <>
\ 4 infix 0= not
\ 3 infix and and
\ 2 infix or  or

\ Parenthesis: Level 1
\ Arrays: Level 9

forth

: ( ( -- ) ['] no-op 1 >op ; immediate

: ) ( -- )
    begin  1 lev? < while op> repeat
    1 lev? = if
        -2 cells op +!
    else
        1 abort" missing ("
    then ; immediate

definitions

: A[ ( -- ) 0 op ! also [compile] algebraic ; immediate


\ ------------
\ INFIX-PARSER 
\ ------------
\
\ Usage: s" (2+5)*98/2  +7" infix-eval

: ISENDCHAR ( c -- f )
    >r 0
    r@ [Char] + = or r@ [Char] - = or
    r@ [Char] * = or r@ [Char] / = or
    r@ [Char] < = or r@ [Char] > = or
    r@ [Char] ( = or r@ [Char] ) = or
    r@ [Char] = = or r@ 32 = or
    r@ [Char] | = or
    rdrop ;

defer FINDWORDEND

\ if first character is endchar, close word directly behind it
\ else continue until endchar found
: GETNEXTWORD ( addr maxlen -- len )
    over c@ isendchar if 2drop 1
    else swap char+ swap 1- findwordend 1+ then ;

:noname ( addr maxlen -- len )
    ?dup-0=-if drop 0 \ end reached
    else
        over c@ ( addr maxlen value )
        isendchar if 2drop 0 \ end character found
        else
            getnextword 
        then
    then ;
is FINDWORDEND

: INFIX-EVAL-REC ( addr maxlen -- )
    ?dup-0=-if drop ( ) else
        2dup swap 2swap getnextword ( maxlen addr wordlen )
        rot >r 2dup 2>r evaluate
        2r> r> swap ( addr maxlen wordlen )
        dup -rot - -rot + swap ( addr+wordlen max-wordlen )
        recurse
    then ;

: INFIX-EVAL ( addr maxlen -- )
    POSTPONE A[ infix-eval-rec POSTPONE ]A ;

\ ------------
\ RETURN STACK 
\ ------------

100 constant RETMAX
create RET RETMAX 1+ cells allot

: RET-RESET ( -- ) 0 RET ! ;

: ?RETMAX ( -- ) RET @ [ RETMAX cells ] literal >
    abort" Too much GOSUB nesting" ;

: ?RETMIN ( -- ) RET @ 1 cells <
    abort" RETURN without GOSUB or NEXT without FOR" ;

: RETP@ ( -- addr ) RET dup @ + ;
: >RET ( value -- , RET: -- value ) 1 cells RET +! ?RETMAX RETP@ ! ;
: RET@ ( -- value , RET: value -- value ) ?RETMIN RETP@ @ ;
: RET> ( -- value , RET: value -- ) RET@ -1 cells RET +! ;

\ ---------------
\ CODE REPOSITORY 
\ ---------------

\ linked list for code lines
struct
    cell% field list-next
end-struct LIST%

LIST%
    cell% field codeline-num
    cell% 2* field codeline-str
end-struct CODELINE%

CODELINE% %allot constant CODEHEAD

0 CODEHEAD list-next !
0 CODEHEAD codeline-num !
0 0 CODEHEAD codeline-str 2!

CODEHEAD constant NEXTLINE

\ add codeline after cur-line and return it
: ADDLINE { new-linenum start -- codeline }
    \ at the end of each line: ( codeline )
    CODELINE% %allot
    dup codeline-num new-linenum swap !
    dup codeline-str 0 0 rot 2!
    dup list-next start list-next @ swap !
    dup start list-next ! ;

\ flag: create if non-existant
\ if flag is false, return 0 as codeline if not found
: CODE@-rec { req-linenum flag start prev -- codeline }
    start 0= if ( )
        flag if req-linenum prev ADDLINE else 0 then \ end reached
    else
        start codeline-num @
        dup req-linenum = if ( codeline-num )
            drop start \ found
        else
            req-linenum < if ( )
                req-linenum flag start list-next @ start recurse \ contine searching
            else
                flag if req-linenum prev ADDLINE else 0 then \ insert here
            then
        then
    then ;

\ get CODELINE with line number linenum
: CODE@ ( linenum create-flag -- codeline )
    CODEHEAD list-next @ CODEHEAD CODE@-rec ;

\ get CODELINE or throw error
: CODE@ERR ( linenum -- codeline )
    0 CODE@ ?dup 0=
    abort" line not found" ;

\ -----
\ TOOLS 
\ -----

0 constant DEBUG

: STR-TOUPPER ( addr u -- )
    0 ?do ( addr )
        dup dup c@ toupper swap c! char+
    loop drop ;

: STRCPY-TO-NEW { addr1 u -- addr2 u }
    here { addr2 } u chars allot
    addr1 addr2 u chars move 
    addr2 u ;

: STRCAT { addr1 u1 addr2 u2 -- addr3 u3 }
    here { addr3 } u1 u2 + { u3 } u3 chars allot
    addr1 addr3 u1 chars move
    addr2 addr3 u1 + u2 chars move
    addr3 u3 ;

\ to be used after SEARCH
: STR-SPLIT ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1-u2 c-addr2 u2 )
    rot over - -rot ;

: ENDSWITH? ( c_addr u1 c -- c_addr u1 false | c_addr u1-1 true )
    >r 2dup + 1- c@ r> = if 1- true else false then ;

\ is string enclosed in quotes?
\ if yes, skip leading spaces and return true
: STRING? ( c_addr1 u1 -- c_addr2 u2 flag )
    ?dup-0=-if drop 0 0 false else
        over c@ ( addr1 u1 c )
        dup 32 = if ( addr1 u1 c )
            drop swap 1+ swap 1- recurse
        else
            [Char] " = if ( addr1 u1 )
                swap 1+ swap 2 - true ( addr1+1 u1-2 true )
            else
                2drop 0 0 false
            then
        then
    then ;             

: COUNT-" ( c-addr u1 -- u2 )
    0 -rot bounds ?do i c@ [Char] " = if 1+ then loop ;

\ find first : that separates two statements
: FIND-: ( c-addr1 u1 -- c-addr2 u2 )
    2dup s" :" search if
        { a u a: u: }
        a u u: - COUNT-" 2 mod 0= if
            a: u:
        else
            a: 1+ u: 1- recurse
        then
    else
        2drop 2drop 0 0
    then ;

\ -------------------
\ VARIABLES AND INPUT 
\ -------------------

: WORD-EXISTS ( c-addr u -- f )
    -trailing context @ search-wordlist 0= ;

: LET-INTEGER ( val c-addr u -- )
    2dup WORD-EXISTS if
        ['] constant execute-parsing
    else
        drop ['] is execute-parsing
    then ;

: LET-STRING ( c-addr-name u-name c-addr-val u-val )
    here -rot here 2 cells allot 2! -rot LET-INTEGER ;

: READ-INTEGER ( c-addr u -- )
    here 20 chars allot dup 20 accept evaluate ( c-addr u val )
    -rot LET-INTEGER ;

: READ-STRING ( c-addr1 u1 -- )
    here 100 chars allot dup 100 accept ( c-addr1 u1 c-addr2 u2 )
    LET-STRING ;

\ ------
\ ARRAYS 
\ ------

: CREATE-ARRAY ( max c-addr u -- )
    ['] create execute-parsing 1+ cells allot ( )
  does> swap cells + @ ;

\ ------------------------------
\ WRITING AND EXECUTING PROGRAMS 
\ ------------------------------

: DEF ( "linenum" "code" -- )
    parse-word evaluate 10 parse STRCPY-TO-NEW rot 1 CODE@ codeline-str 2! ;

\ if there's something on the stack, a line number has been entered
\ before the command
: STATE-EXEC ( linenum? addr-xt -- )
    depth 2 = if ( linenum addr-xt )
        0 >in ! DEF 2drop
    else
        depth 1 <> abort" Garbage on the stack. Try again"
        ( addr-xt ) @ execute
    then ;

\ create new version of word that recognizes line-numbers
: STATE-AWARE ( "old cmd" "new cmd" -- )
    ' create ,
  does> STATE-EXEC ;

\ check for multiple statments separated by ":"
: EXECUTE-CODE ( c-addr u -- )
    2dup FIND-: ?dup-if
        { a u a: u: }
        a u u: - evaluate
        a: 1+ u: 1- recurse
    else
        drop evaluate
    then ;

\ --------------
\ FOR-NEXT LOOPS 
\ --------------

\ store 5 cells in memory and store address on return stack
: FOR-STORE { c-addr-var u-var c-addr-to u-to -- , RET: -- mem }
    align here >RET NEXTLINE , c-addr-var , u-var , c-addr-to , u-to , ;

: FOR-PARSE ( "var=init TO final" -- str..var str..init str..to )
    [Char] = parse ( str..var )
    10 parse STRCPY-TO-NEW 2dup STR-TOUPPER ( str..var str..rest ) 
    2dup s"  TO " search 0= abort" FOR without TO" \ ( str..var str..rest str..to(inc) )
    STR-SPLIT swap 4 + swap 4 - ;

: NEXT-GET ( -- codeline c-addr-var u-var c-addr-to u-to , RET: mem -- )
    RET@ ( mem )
    dup @ swap cell+ dup @ swap cell+
    dup @ swap cell+ dup @ swap cell+ @ ;

\ --------------
\ BASIC KEYWORDS 
\ --------------

vocabulary basic
basic definitions
also forth

: _REM ( "anything" -- )
    10 parse 2drop ;

\ ----------
\ IN-/OUTPUT 
\ ----------

: _CLS ( -- )
    PAGE ;

: _PRINT ( "infix string" -- )
    10 parse -trailing ?dup-0=-if 
        cr drop                      \ PRINT
    else
        [Char] ; ENDSWITH? >r
        [Char] $ ENDSWITH? if
            1+ evaluate 2@ type      \ PRINT A$
        else
            2dup STRING? if
                type 2drop           \ PRINT "xyz"
            else
                2drop infix-eval .   \ PRINT B*(3+4)
            then
        then
    then
    r> 0= if cr then ;

: _LOCATE ( "row,column" -- )
          [Char] , parse infix-eval 1- 10 parse infix-eval 1- swap at-xy ;

: _INPUT ( "var$"|"var" -- )
         10 parse STRCPY-TO-NEW 2dup + 1- c@ 36 <> if 
           READ-INTEGER
         else
           READ-STRING
         then cr ;

: INKEY ( -- c )
        key? if key else 0 then ;

: READUPPERCHAR ( -- c )
    key TOUPPER ;

\ -----------------------------------
\ VARIABLE DECLARATION AND ASSIGNMENT 
\ -----------------------------------

\ Array declaration
: _DIM \ ( "var(max)" -- )
    [Char] ( parse ( c-addr u )
    2dup [Char] ) parse evaluate >r ( c-addr u c-addr u )
    s" _" 2swap STRCAT ( c-addr u c-addr' u' )
    2dup r> -rot CREATE-ARRAY ( c-addr u c-addr' u' )
    find-name name?int 9 2swap ( xt lev c-addr u )
    ['] infix execute-parsing ;

: _LET \ ( "var=expr"|"var(expr)=expr" -- )
    [Char] = parse 10 parse infix-eval -rot ( value c-addr u )
    2dup s" (" search if   \ array assignment
        { value c-addr u c-addr-( u-( }
        c-addr u u-( - s" _" 2swap STRCAT find-name name?int >body ( array-start )
        c-addr-( u-( infix-eval ( array-start index )
        cells + value swap !
    else
        2drop LET-INTEGER
    then ;

\ ---------------------
\ CONDITIONAL EXECUTION 
\ ---------------------

: _IF ( "condition THEN command" -- )
    10 parse STRCPY-TO-NEW 2dup STR-TOUPPER ( addr u )
    2dup s"  THEN " search 0= abort" IF without THEN"
    { addr u addr-t u-t }
    addr addr-t addr - infix-eval if ( )
        >in @ u-t - >in ! \ execute part after THEN
    then ;

: _THEN no-op ;

\ -----
\ JUMPS 
\ -----

: _GOTO ( "linenum" -- )
    parse-word evaluate CODE@ERR is NEXTLINE ;

: _END ( -- )
    0 is NEXTLINE ;

: _GOSUB ( "linenum" -- , RET: -- nextline )
    NEXTLINE >RET _GOTO ;

: _RETURN ( -- , RET: nextline -- )
    RET> is NEXTLINE ;

\ -----
\ LOOPS 
\ -----

: _FOR ( "var=init TO final" -- )
    FOR-PARSE { c-var u-var c-init u-init c-to u-to }
    c-init u-init infix-eval c-var u-var LET-INTEGER 
    c-var u-var c-to u-to FOR-STORE
    ;

: _NEXT ( "var" -- )
    10 parse 2drop \ might add check if varname = varname
    NEXT-GET ( codeline c-var u-var c-to u-to ) 
    infix-eval -rot 2>r 2r@ infix-eval >r r@ ( codeline val-to val-cur )
    > if ( codeline )
        is NEXTLINE
        r> 2r> rot 1+ -rot ( val-cur+1 c-to u-to )
        LET-INTEGER
    else
        drop RET> drop r> drop 2r> 2drop
    then ;

\ ---------------
\ STATE-AWARENESS 
\ ---------------

STATE-AWARE _PRINT PRINT
STATE-AWARE _IF IF
STATE-AWARE _THEN THEN
STATE-AWARE _LET LET
STATE-AWARE _REM REM
STATE-AWARE _INPUT INPUT
STATE-AWARE _LOCATE LOCATE
STATE-AWARE _DIM DIM
STATE-AWARE _CLS CLS

STATE-AWARE _END END
STATE-AWARE _GOTO GOTO
STATE-AWARE _GOSUB GOSUB
STATE-AWARE _RETURN RETURN
STATE-AWARE _FOR FOR
STATE-AWARE _NEXT NEXT

\ -----------
\ PROGRAMMING 
\ -----------

: RUN ( -- )
    cr RET-RESET
    CODEHEAD list-next @ begin
        ?dup while
            { codeline }
            codeline list-next @ is NEXTLINE
            codeline codeline-str 2@ EXECUTE-CODE
            NEXTLINE
    repeat ;

: LIST ( -- )
    cr
    CODEHEAD list-next @ begin
        ?dup while
            { codeline }
            codeline codeline-num @ .
            codeline codeline-str 2@ type cr
            codeline list-next @
    repeat ;

: FANCY-RUN ( -- )
    cr
    RET-RESET
    s" CLEAR-VARS" ['] marker execute-parsing
    CODEHEAD list-next @ begin
        ?dup while
            { codeline }
            DEBUG if ." Executing: " codeline codeline-num @ . codeline codeline-str 2@ type cr then
            codeline list-next @ is NEXTLINE
            codeline codeline-str 2@ EXECUTE-CODE
            NEXTLINE
    repeat
    s" CLEAR-VARS" evaluate ;


previous