Thursday, 9 February 2012

BASIC intepreter

Here a Rebol-Basic intepreter:
REBOL [
    Title:       "BBC BASIC"
    Date:       29-Jul-2007
    Version:     0.4.1
    Author:     "John Niclasen"
    Purpose:     {
        A BBC BASIC language intepreter.
    }
    History: [
        0.4.1   [29-07-2007 JN {Added repeat-, proc-, gosub- and for-stack}]
        0.4.0   [27-07-2007 JN {Added DEF PROC, ENDPROC and LOCAL}]
        0.3.1   [25-07-2007 JN {Added TIME, RND and EVAL
                                Added errors}]
        0.3.0   [24-07-2007 JN {Added DIM}]
        0.2.1   [23-07-2007 JN {Added LEFT$, MID$, RIGHT$, STRING$ and INSTR
                                Added ON}]
        0.2.0   [22-07-2007 JN {Added hex
                                Added GOSUB and RETURN}]
        0.1.2   [21-07-2007 JN {Added basic-statements
                                Added DATA, READ and RESTORE
                                Changed AUTO, DELETE and LIST to use ","
                                Fixed basic-condition}]
        0.1.1   [20-07-2007 JN {Added many keywords, mostly functions}]
        0.1.0   [19-07-2007 JN {Added FOR...NEXT loop
                                Added support for UPPER/lower case variables
                                Added REPEAT...UNTIL loop
                                Changed basic-condition}]
        0.0.2   [18-07-2007 JN {Implemented basic-expr and basic-condition
                                Added IF...THEN...ELSE and INPUT}]
        0.0.1   [28-06-2007 JN {Created from basic.r as string parsing}]
    ]
]
context [
; Constants
MAX-LIN: 32767
MAX-INT: to integer! 2 ** 31 - 1
; Work variables
ln: none
arg1: arg2: none
num: 0.0
number: 0
str: ""
string: ""
string2: ""
sign: 1
word: none
type: 'none
; Work parameters
auto: off
listoption: 7
indent: 1
mode: 'command       ; 'command | 'running
tab: 10
; The Program
program: []
old-program: []
mark1: mark2: none
PC: newPC: program   ; Program Counter
CODE: none           ; Code pointer
data: none           ; Data pointer
dataline: none
line: ""
; Parse charsets
var-char: charset [#"A" - #"Z" #"a" - #"z" #"_"]
var-name: [var-char any [var-char | integer!]]
hex-char: charset [#"0" - #"9" #"A" - #"F" #"a" - #"f"]
space: charset { ^-}
sp: [any space]
; User variables
residents: []
integers: []
reals: []
strings: []
integer-arrays: []
real-arrays: []
string-arrays: []
stored-integers: []
stored-reals: []
stored-strings: []
subscript: none
time: none
clear-vars: does [
    clear integers
    clear reals
    append reals reduce ['PI pi]
    clear strings
    clear integer-arrays
    clear real-arrays
    clear string-arrays
]
; Error handling
error: none
error-statement: none
error-PC: none
err: 0
erl: 0
report: "By John Niclasen, NicomSoft^/"
make-error: func [n] [
    err: n
    make error! select errors to string! n
]
errors: [
"1"     "Out of range"
"2"     "Byte"
"3"     "Index"
"4"     "Mistake"
"5"     "Missing ,"
"6"     "Type mismatch"
"7"     "No FN"
"8"     "$ range"
"9"     "Missing ^""
"10"     "Bad DIM"
"11"     "Dim space"
"12"     "Not LOCAL"
"13"     "No PROC"
"14"     "Array"
"15"     "Subscript"
"16"     "Syntax error"
"17"     "Escape"
"18"     "Division by zero"
"19"     "String too long"
"20"     "Too big"
"21"     "-ve root"
"22"     "Log range"
"23"     "Accuracy lost"
"24"     "Exp range"
"25"     "Bad MODE"
"26"     "No such variable"
"27"     "Missing )"
"28"     "Bad HEX"
"29"     "No such FN/PROC"
"30"     "Bad call"
"31"     "Arguments"
"32"     "No FOR"
"33"     "Can't match FOR"
"34"     "FOR variable"
"35"     "Too many FORs"
"36"     "No TO"
"37"     "Too many GOSUBs"
"38"     "No GOSUB"
"39"     "ON syntax"
"40"     "ON range"
"41"     "No such line"
"42"     "Out of DATA"
"43"     "No REPEAT"
"44"     "Too many REPEATs"
"216"   "Data?"
"217"   "Header?"
"218"   "Block?"
"219"   "File?"
"220"   "Syntax"
"222"   "Channel"
"223"   "Eof"
"250"   "Key in use"
"251"   "Bad key"
"253"   "Bad string"
"254"   "Bad command"
]
; Stacks
stack: []
push: func [value] [insert/only stack value]
pop: func [/local r] [
    r: first stack
    remove stack
    r
]
for-stack: []
push-for: func [value] [insert/only for-stack value]
pop-for: func [/local r] [
    r: first for-stack
    remove for-stack
    r
]
gosub-stack: []
push-gosub: func [value] [insert/only gosub-stack value]
pop-gosub: func [/local r] [
    r: first gosub-stack
    remove gosub-stack
    r
]
proc-stack: []
push-proc: func [value] [insert/only proc-stack value]
pop-proc: func [/local r] [
    r: first proc-stack
    remove proc-stack
    r
]
repeat-stack: []
push-repeat: func [value] [insert/only repeat-stack value]
pop-repeat: func [/local r] [
    r: first repeat-stack
    remove repeat-stack
    r
]
; Random generator
last-rnd: 0.0
rnd: func [/one /local r] [
    r: (to integer! random 2 ** 31 - 1)
    - (to integer! random 2 ** 31 - 1)
    + ((random 4) - 3)
    either one [
        last-rnd: r + (2 ** 31) / (2 ** 32)
    ][r ]
]
; Data handling
restore-data: does [
    data: none
    dataline: none
    foreach [lin content] program [
        if find/part content "data" 4 [
            dataline: find program lin
            parse content ["data" sp data:]
            break
        ]
    ]
]
parse-data: has [newdata] [
    parse/all data [
        [
            end (make-error 26)
            | {"} copy str to {"} {"} (if none? str [str: copy ""])
            | {"} (make-error 9)
            | copy str [to "," | to end]
        ]
        "," sp newdata: break
        | end (
            while [not tail? dataline: skip dataline 2] [
                if find/part dataline/2 "data" 4 [
                    parse dataline/2 ["data" sp newdata:]
                    break
                ]
            ]
            if tail? dataline [newdata: dataline: none]
        )
    ]
    data: newdata
]
; BASIC Commands
basic-command: [
    "auto" (arg1: 10 arg2: none)
        opt [sp copy arg1 integer! (arg1: to integer! arg1)]
        opt [sp "," opt [sp copy arg2 integer! (arg2: to integer! arg2)]]
        end (auto: on)
    | "delete" sp copy arg1 integer! sp "," sp copy arg2 integer! end (
        arg1: to integer! arg1
        arg2: to integer! arg2
        either arg1 = arg2 [remove/part find program arg1 2 ][
            mark1: mark2: none
            foreach [lin content] program [
                if lin >= arg1 [mark1: find program lin break]
            ]
            foreach [lin content] program [
                if lin >= arg2 [mark2: find program lin break]
            ]
            if mark1 [
                either mark2 [
                    if arg2 = mark2/1 [mark2: skip mark2 2]
                ][mark2: tail program ]
                remove/part mark1 mark2
            ]
        ]
    )
    | "list" (arg1: 0 arg2: MAX-LIN)
        opt [sp copy arg1 integer! (arg1: arg2: to integer! arg1)]
        opt [sp "," (arg2: MAX-LIN) opt [sp copy arg2 integer!] (arg2: to integer! arg2)]
    end (
        foreach [lin content] program [
            if all [lin >= arg1 lin <= arg2] [
                clear str
                insert str lin
                insert/dup str " " 5 - length? str
                either listoption = 7 [
                    if find/part content "next" 4 [indent: indent - 2]
                    if find/part content "until" 5 [indent: indent - 2]
                    if indent < 1 [indent: 1]
                    loop indent [append str " "]
                    if find/part content "for" 3 [indent: indent + 2]
                    if find/part content "repeat" 6 [indent: indent + 2]
                ][
                ]
                append str content
                print str
            ]
        ]
        indent: 1
    )
    | "new" end (
        if not empty? program [
            old-program: copy/deep program
            clear program
        ]
    )
    | "old" end (program: old-program)
]
; BASIC Condition
basic-condition: [
    basic-and sp any [
        "or" (
            if type = 'string [make-error 6]
            type: 'none
            push num
        ) sp basic-and (
            if type = 'string [make-error 6]
            num: pop or num
        )
        | "eor" (
            if type = 'string [make-error 6]
            type: 'none
            push num
        ) sp basic-and (
            if type = 'string [make-error 6]
            num: pop xor num
        )
    ]
]
basic-and: [
    basic-relation sp any [
        "and" (
            if type = 'string [make-error 6]
            type: 'none
            push num
        ) sp basic-relation (
            if type = 'string [make-error 6]
            num: pop and num
        )
    ]
]
basic-relation: [
    basic-expr sp opt [
        "=" (push either type = 'number [num] [str]) sp basic-expr (
            num: negate to integer! either type = 'number
                [pop = num] [type: 'number pop == str]
        )
        | "<>" (push either type = 'number [num] [str]) sp basic-expr (
            num: negate to integer! either type = 'number
                [pop <> num] [type: 'number pop <> str]
        )
        | "<=" (push either type = 'number [num] [str]) sp basic-expr (
            num: negate to integer! either type = 'number
                [pop <= num] [type: 'number pop <= str]
        )
        | ">=" (push either type = 'number [num] [str]) sp basic-expr (
            num: negate to integer! either type = 'number
                [pop >= num] [type: 'number pop >= str]
        )
        | "<" (push either type = 'number [num] [str]) sp basic-expr (
            num: negate to integer! either type = 'number
                [pop < num] [type: 'number pop < str]
        )
        | ">" (push either type = 'number [num] [str]) sp basic-expr (
            num: negate to integer! either type = 'number
                [pop > num] [type: 'number pop > str]
        )
    ]
]
; BASIC Expression
basic-expr: [
    basic-term sp any [
        "+" (push either type = 'number [num] [str]) sp basic-term (
            either type = 'number [num: pop + num ][insert str pop ]
        )
        | "-" (push num) sp basic-term (num: pop - num)
    ]
]
basic-term: [
    basic-factor sp any [
        "*" (push num) sp basic-factor (num: pop * num)
        | "/" (push num) sp basic-factor (
            if num = 0 [make-error 18]
            num: pop / num
        )
        | "div" (push num) sp basic-factor (
            if num = 0 [make-error 18]
            num: to integer! pop / num
        )
        | "MOD" (push num) sp basic-factor (
            if num = 0 [make-error 18]
            num: pop // num
        )
    ]
]
basic-factor: [
    basic-primary sp any ["^^" (push num) sp basic-primary (num: pop ** num)]
]
basic-primary: [
    "abs" basic-numeric-arg (num: abs num)
    | "acs" basic-numeric-arg (num: arccosine/radians num)
    | "asc" (
        if type = 'string [make-error 6]
        type: 'string
    ) basic-string-arg (num: to integer! to char! first str type: 'number)
    | "asn" basic-numeric-arg (num: arcsine/radians num)
    | "atn" basic-numeric-arg (num: arctangent/radians num)
    | "chr$" (
        if type = 'number [make-error 6]
        type: 'number
    ) basic-numeric-arg (str: to string! to char! num and 255 type: 'string)
    | "cos" basic-numeric-arg (num: cosine/radians num)
    | "deg" basic-numeric-arg (num: num / pi * 180.0)
    | "erl" (
        if type = 'string [make-error 6]
        num: erl
        type: 'number
    )
    | "err" (
        if type = 'string [make-error 6]
        num: err
        type: 'number
    )
    | "eval" (
        if type = 'string [make-error 6]
        type: 'string
    ) sp [
        "(" basic-string-arg sp ")"
        | basic-string-arg
    ] (
        type: 'none
        if not parse/all trim str [basic-condition end] [make-error 16]
        ;str: copy ""
        type: 'number
    )
    | "exp" basic-numeric-arg (if error? try [num: exp num] [make-error 24])
    | "false" (
        if type = 'string [make-error 6]
        num: 0
        type: 'number
    )
    | "instr(" (
        if type = 'string [make-error 6]
        type: 'string
    ) basic-string-arg (string: copy str)
    sp "," basic-string-arg (string2: copy str num: 1) opt [sp "," (type: 'number) basic-numeric-arg (num: to integer! num) ] sp ")" (
        if string2 <> "" [
            num: either string: find skip string num - 1 string2 [index? string] [0]
        ]
        type: 'number
    )
    | "int" basic-numeric-arg (
        if error? try [num: round num - 0.5] [make-error 20]
    )
    | "left$" (
        if type = 'number [make-error 6]
        type: 'string
    ) sp "(" basic-string-arg sp "," (string: copy str type: 'number)
    basic-numeric-arg sp ")" (
        str: copy/part string to integer! num
        type: 'string
    )
    | "len" (
        if type = 'string [make-error 6]
        type: 'string
    ) basic-string-arg (num: length? str type: 'number)
    | "ln" basic-numeric-arg (if num <= 0 [make-error 22] num: log-e num)
    | "log" basic-numeric-arg (if num <= 0 [make-error 22] num: log-10 num)
    | "mid$" (
        if type = 'number [make-error 6]
        type: 'string
    ) sp "(" basic-string-arg sp "," (string: copy str type: 'number)
        basic-numeric-arg (string: skip string (to integer! num) - 1) opt [sp "," basic-numeric-arg (clear skip string to integer! num) ] sp ")" (
        str: copy string
        type: 'string
    )
    | "not" basic-numeric-arg (num: complement num)
    | "rad" basic-numeric-arg (num: num / 180.0 * pi)
    | "right$" (
        if type = 'number [make-error 6]
        type: 'string
    ) sp "(" basic-string-arg sp "," (string: copy str type: 'number)
    basic-numeric-arg sp ")" (
        str: copy skip tail string negate to integer! num
        type: 'string
    )
    | "rnd(" (if type = 'string [make-error 6]) sp [
        "0" sp ")" (
            num: last-rnd
            type: 'number
        )
        | "1" sp ")" (
            num: rnd/one
            type: 'number
        )
        | basic-numeric-arg sp ")" (
            if error? try [num: to integer! num] [make-error 20]
            either negative? num [random/seed num ][num: 1 + to integer! rnd/one * num ]
            type: 'number
        )
    ]
    | "sgn" basic-numeric-arg (num: either negative? num [-1] [either zero? num [0] [1]])
    | "sin" basic-numeric-arg (num: sine/radians num)
    | "sqr" basic-numeric-arg (
        if num < 0 [make-error 21]
        num: square-root num
    )
    | "str$" (
        if type = 'number [make-error 6]
        type: 'number
    ) basic-numeric-arg (str: to string! num type: 'string)
    | "string$" (
        if type = 'number [make-error 6]
        type: 'number
    ) sp "(" basic-numeric-arg sp "," (number: to integer! num type: 'string)
    basic-string-arg sp ")" (
        clear string
        insert/dup string str number
        str: copy string
    )
    | "tan" basic-numeric-arg (num: tangent/radians num)
    | "true" (
        if type = 'string [make-error 6]
        num: -1
        type: 'number
    )
    | "val" (
        if type = 'string [make-error 6]
        type: 'string
    ) basic-string-arg (
        if error? try [num: to decimal! str] [num: 0]
        type: 'number
    )
    | "(" sp basic-condition ")"
    | basic-string sp (
        switch type [
            none     [type: 'string]
            number   [make-error 6]
        ]
    )
    | basic-numeric sp (
        switch type [
            none     [type: 'number]
            string   [make-error 6]
        ]
    )
]
basic-string-arg: [
    sp basic-primary (if type = 'number [make-error 6])
]
basic-numeric-arg: [
    sp basic-primary (if type = 'string [make-error 6])
]
basic-string: [
    {"} copy str to {"} {"} (if none? str [str: copy ""])
    | {"} (make-error 9)
    | basic-string-array (str: copy string-arrays/:word/(number + 1))
    | copy str var-name "$" (
        word: to word! str
        if error? try [str: copy select/case strings word] [make-error 26]
    )
]
basic-numeric: [(sign: 1) opt ["-" (sign: -1) | "+"] sp [
    copy str [integer! "." integer!] (num: sign * to decimal! str)
    | copy str integer! (num: sign * to integer! str)
    | "&" copy str some hex-char (
        if decimal? (length? str) / 2 [insert str "0"]
        num: sign * to integer! debase/base str 16
    )
    | "&" (make-error 28)
    | basic-integer-array (num: sign * integer-arrays/:word/(number + 1))
    | copy str [var-name | "@"] "%" (
        word: to word! str
        if error? try [num: sign * select/case residents word] [
            if error? try [num: sign * select/case integers word] [make-error 26 ]
        ]
    )
    | basic-real-array (num: sign * real-arrays/:word/(number + 1))
    | copy str var-name (
        word: to word! str
        switch/default word [
            rnd [num: sign * rnd]
            time [
                num: now/precise
                num: sign * ((num - time * 8640000) + to integer! num/time
                    - time/time * 100)
            ]
        ][
            if error? try [num: sign * select/case reals word] [make-error 26 ]
        ]
    )
]]
product: func [b /local p] [p: 1 foreach v b [p: p * v] p]
basic-integer-array: [
    copy str var-name "%(" (
        word: to word! str
        if error? try [subscript: integer-arrays/:word/1] [make-error 14]
        push word
        push subscript
    ) basic-array
]
basic-string-array: [
    copy str var-name "$(" (
        word: to word! str
        if error? try [subscript: string-arrays/:word/1] [make-error 14]
        push word
        push subscript
    ) basic-array
]
basic-real-array: [
    copy str var-name "(" (
        word: to word! str
        if error? try [subscript: real-arrays/:word/1] [make-error 14]
        push word
        push subscript
    ) basic-array
]
basic-array: [
    sp basic-numeric (
        subscript: pop
        if any [(num: to integer! num) < 0 num >= subscript/1] [make-error 15]
        push num * product next subscript
        push next subscript
    ) any [
        sp "," sp basic-numeric (
            subscript: pop
            if any [(num: to integer! num) < 0 num >= subscript/1] [make-error 15]
            push num * (product next subscript) + pop
            push next subscript
        )
    ] sp ")" (
        if not tail? pop [make-error 14]
        number: pop + 1
        word: pop
    )
]
; BASIC Statements
basic-statements: [
    basic-statement
    any [sp ":" sp basic-statement]
]
basic-statement: [
    "clear" (clear-vars)
    | "data" to end
    | "def" to end
    | "dim" sp [
        copy arg1 var-name "%(" sp (type: 'number) basic-primary (
            arg1: to word! arg1
            if find integer-arrays arg1 [make-error 10]
            if (arg2: 1 + to integer! num) < 1 [make-error 10]
            insert integer-arrays reduce [arg1 copy [[]]]
            insert integer-arrays/:arg1/1 arg2
        ) any [sp "," sp basic-primary (
            if (arg2: 1 + to integer! num) < 1 [make-error 10]
            append integer-arrays/:arg1/1 arg2
        )]
        sp ")" (
            arg2: 1
            foreach v integer-arrays/:arg1/1 [arg2: arg2 * v]
            insert/dup tail integer-arrays/:arg1 0 arg2
        )
        | copy arg1 var-name "$(" sp (type: 'number) basic-primary (
            arg1: to word! arg1
            if find string-arrays arg1 [make-error 10]
            if (arg2: 1 + to integer! num) < 1 [make-error 10]
            insert string-arrays reduce [arg1 copy [[]]]
            insert string-arrays/:arg1/1 arg2
        ) any [sp "," sp basic-primary (
            if (arg2: 1 + to integer! num) < 1 [make-error 10]
            append string-arrays/:arg1/1 arg2
        )]
        sp ")" (
            arg2: 1
            foreach v string-arrays/:arg1/1 [arg2: arg2 * v]
            insert/dup tail string-arrays/:arg1 "" arg2
        )
        | copy arg1 var-name "(" sp (type: 'number) basic-primary (
            arg1: to word! arg1
            if find real-arrays arg1 [make-error 10]
            if (arg2: 1 + to integer! num) < 1 [make-error 10]
            insert real-arrays reduce [arg1 copy [[]]]
            insert real-arrays/:arg1/1 arg2
        ) any [sp "," sp basic-primary (
            if (arg2: 1 + to integer! num) < 1 [make-error 10]
            append real-arrays/:arg1/1 arg2
        )]
        sp ")" (
            arg2: 1
            foreach v real-arrays/:arg1/1 [arg2: arg2 * v]
            insert/dup tail real-arrays/:arg1 0 arg2
        )
        ;| copy arg1 var-name "%" some space (type: 'number) basic-primary (
            ;arg1: to word! arg1
        ;)
        ;| copy arg1 var-name some space (type: 'number) basic-primary (
            ;arg1: to word! arg1
        ;)
    ]
    | "endproc" end (
        either empty? proc-stack [make-error 13 ][
            foreach [var value] stored-integers/1 [change next find/case integers var value]
            foreach [var value] stored-reals/1 [change next find/case reals var value]
            foreach [var value] stored-strings/1 [change next find/case strings var value]
            remove stored-integers
            remove stored-reals
            remove stored-strings
            newPC: either none? proc-stack/1 [pop-proc tail program] [find program pop-proc]
        ]
    )
    | "end" to end (newPC: tail program)
    | "for" (push-for copy []) sp [
        copy arg1 [var-name | "@"] "%" sp "=" sp (type: 'number) basic-primary (
            arg1: to word! arg1
            num: to integer! num
            either find/case residents arg1 [change next find/case residents arg1 num ][
                either find/case integers arg1 [
                    change next find/case integers arg1 num
                ][
                    insert integers reduce [arg1 num]
                ]
            ]
            insert for-stack/1 compose [integers (arg1)]
        ) sp "to" sp (type: 'number) basic-primary (arg1: num arg2: 1) opt [sp "step" sp (type: 'number) basic-primary (arg2: num) ] (append for-stack/1 reduce [arg2 arg1 PC/1])
        | copy arg1 var-name sp "=" sp (type: 'number) basic-primary (
            arg1: to word! arg1
            either find/case reals arg1 [change next find/case reals arg1 num ][
                insert reals reduce [arg1 num]
            ]
            insert for-stack/1 compose [reals (arg1)]
        ) sp "to" sp (type: 'number) basic-primary (arg1: num arg2: 1) opt [sp "step" sp (type: 'number) basic-primary (arg2: num) ] (append for-stack/1 reduce [arg2 arg1 PC/1])
    ]
    | "gosub" sp (type: 'number) basic-primary end (
        arg1: to integer! num
        push-gosub PC/3
        either newPC: find program arg1 [
            if mode = 'command [run-program]
        ][make-error 41 ]
    )
    | "goto" sp (type: 'number) basic-primary end (
        arg1: to integer! num
        either newPC: find program arg1 [
            if mode = 'command [run-program]
        ][make-error 41 ]
    )
    | "if" sp (type: 'none) basic-condition sp opt "then" sp mark1: [
        to "else" mark2: (arg1: copy/part mark1 mark2)
        "else" sp mark1: to end mark2: (arg2: copy/part mark1 mark2)
        | to end mark2: (arg1: copy/part mark1 mark2 arg2: none)
    ] (
        either num <> 0 [
            if not parse/all trim arg1 [
                basic-statements end
                | basic-numeric end (
                    arg1: to integer! num
                    either newPC: find program arg1 [
                        if mode = 'command [run-program]
                    ][make-error 41 ]
                )
            ] [make-error 16 ]
        ][
            if arg2 [
                if not parse/all trim arg2 [
                    basic-statements end
                    | basic-numeric end (
                        arg1: to integer! num
                        either newPC: find program arg1 [
                            if mode = 'command [run-program]
                        ][make-error 41 ]
                    )
                ] [make-error 16 ]
            ]
        ]
    )
    | "input" (arg2: copy "?") sp
    opt [{"} copy arg2 to {"} {"} (if none? arg2 [arg2: copy ""])] some [
        sp opt ["," (append arg2 "?")] sp [
            copy arg1 [var-name | "@"] "%" (
                arg1: to word! arg1
                num: to integer! ask arg2
                either find/case residents arg1 [change next find/case residents arg1 num ][
                    either find/case integers arg1 [
                        change next find/case integers arg1 num
                    ][
                        insert integers reduce [arg1 num]
                    ]
                ]
            )
            | copy arg1 var-name "$" (
                arg1: to word! arg1
                str: ask arg2
                either find/case strings arg1 [change next find/case strings arg1 str ][
                    insert strings reduce [arg1 str]
                ]
            )
            | copy arg1 var-name (
                arg1: to word! arg1
                num: to decimal! ask arg2
                either find/case reals arg1 [change next find/case reals arg1 num ][
                    insert reals reduce [arg1 num]
                ]
            )
        ]
        (clear arg2)
    ]
    | "local" (if empty? stored-integers [make-error 12]) [
        local-arg any [sp "," local-arg]
    ]
    | "next" sp (arg1: none) opt [
        copy arg1 [var-name | "@"] "%" (
            arg1: to word! arg1
            while [all [not empty? for-stack any [for-stack/1/1 <> 'integers for-stack/1/2 <> arg1]]] [pop-for ]
        )
        | copy arg1 var-name (
            arg1: to word! arg1
            while [all [not empty? for-stack any [for-stack/1/1 <> 'reals for-stack/1/2 <> arg1]]] [pop-for ]
        )
    ] end (
        either empty? for-stack [make-error 32 ][
            either for-stack/1/1 = 'integers [
                either find/case residents for-stack/1/2 [
                    change next find/case residents for-stack/1/2
                        (select/case residents for-stack/1/2) + for-stack/1/3
                    either negative? for-stack/1/3 [
                        either (select/case residents for-stack/1/2) < for-stack/1/4 [
                            pop-for
                        ][
                            either none? for-stack/1/5 [
                                newPC: tail program
                                pop-for
                            ][newPC: skip find program for-stack/1/5 2 ]
                        ]
                    ][
                        either (select/case residents for-stack/1/2) > for-stack/1/4 [
                            pop-for
                        ][
                            either none? for-stack/1/5 [
                                newPC: tail program
                                pop-for
                            ][newPC: skip find program for-stack/1/5 2 ]
                        ]
                    ]
                ][
                    change next find/case integers for-stack/1/2
                        (select/case integers for-stack/1/2) + for-stack/1/3
                    either negative? for-stack/1/3 [
                        either (select/case integers for-stack/1/2) < for-stack/1/4 [
                            pop-for
                        ][
                            either none? for-stack/1/5 [
                                newPC: tail program
                                pop-for
                            ][newPC: skip find program for-stack/1/5 2 ]
                        ]
                    ][
                        either (select/case integers for-stack/1/2) > for-stack/1/4 [
                            pop-for
                        ][
                            either none? for-stack/1/5 [
                                newPC: tail program
                                pop-for
                            ][newPC: skip find program for-stack/1/5 2 ]
                        ]
                    ]
                ]
            ][
                change next find/case reals for-stack/1/2
                    (select/case reals for-stack/1/2) + for-stack/1/3
                either negative? for-stack/1/3 [
                    either (select/case reals for-stack/1/2) < for-stack/1/4 [
                        pop-for
                    ][
                        either none? for-stack/1/5 [
                            newPC: tail program
                            pop-for
                        ][newPC: skip find program for-stack/1/5 2 ]
                    ]
                ][
                    either (select/case reals for-stack/1/2) > for-stack/1/4 [
                        pop-for
                    ][
                        either none? for-stack/1/5 [
                            newPC: tail program
                            pop-for
                        ][newPC: skip find program for-stack/1/5 2 ]
                    ]
                ]
            ]
        ]
    )
    | "on" sp [
        "error" sp [
            "off" (error-statement: none)
            | error-statement: to end (
                either mode = 'running [
                    error-PC: PC
                ][error-statement: none ]
            )
        ]
        | basic-numeric (if negative? num: (to integer! num) - 1 [num: MAX-INT]) sp [
            "gosub" sp [
                num [basic-numeric sp "," sp] basic-numeric to end
                | any   [basic-numeric sp "," sp] basic-numeric
                sp "else" sp basic-numeric end
                | (make-error 40)
            ] (
                arg1: to integer! num
                push-gosub PC/3
                either newPC: find program arg1 [
                    if mode = 'command [run-program]
                ][make-error 41 ]
            )
            | "goto" sp [
                num [basic-numeric sp "," sp] basic-numeric to end
                | any   [basic-numeric sp "," sp] basic-numeric
                sp "else" sp basic-numeric end
                | (make-error 40)
            ] (
                arg1: to integer! num
                either newPC: find program arg1 [
                    if mode = 'command [run-program]
                ][make-error 41 ]
            )
        ]
    ]
    | "print" (arg1: copy "" arg2: none) sp any [
        "'" sp (append arg1 newline)
        | opt ["," | ";"] sp opt ["~" (arg2: 'hex)] sp (type: 'none) basic-condition (
            switch type [
                number [
                    ;clear str   ; check if str is none!!!
                    str: copy ""
                    either arg2 = 'hex [
                        insert str to-hex to integer! num
                        insert/dup tail arg1 " " tab - length? str
                        append arg1 to-hex to integer! num
                    ][
                        insert str num
                        insert/dup tail arg1 " " tab - length? str
                        append arg1 num
                    ]
                    ;prin str
                ]
                string [
                    ;prin str
                    append arg1 str
                ]
            ]
        )
        | "," sp
        | ";" (str: copy ";") sp
    ] (prin arg1 if str <> ";" [prin newline])
    | "proc" copy arg1 var-name (
        arguments: head arguments
        clear arguments
        newPC: tail program
        foreach [lin content] program [
            if parse/all content [
                "def" sp "proc" arg1 [
                    sp "(" def-arg any [sp "," def-arg] sp ")" end
                    | end
                ]
            ] [
                push-proc PC/3
                newPC: find program lin
                break
            ]
        ]
        either tail? newPC [make-error 29 ][newPC: skip newPC 2 ]
        insert/only stored-integers copy []
        insert/only stored-reals copy []
        insert/only stored-strings copy []
    ) [
        sp "(" proc-arg any [sp "," proc-arg] sp ")" end
        | end
    ] (
        if not tail? arguments [make-error 31]
        if all [not tail? newPC mode = 'command] [run-program]
    )
    | "read" read-arg any [sp "," read-arg]
    | "rem" to end
    | "repeat" (push-repeat PC/1) opt [sp basic-statements]
    | "report" (prin [newline report])
    | "restore" [
        sp copy arg1 integer! (
            arg1: to integer! arg1
            either dataline: find program arg1 [
                until [
                    if find/part dataline/2 "data" 4 [
                        parse dataline/2 ["data" sp data:]
                        break
                    ]
                    tail? dataline: skip dataline 2] [
                ]
                if tail? dataline [data: dataline: none]
            ][make-error 41 ]
        )
        | (restore-data)
    ]
    | "return" end (
        either empty? gosub-stack [make-error 38 ][
            newPC: either none? gosub-stack/1 [
                pop-gosub tail program
            ][find program pop-gosub ]
        ]
    )
    | "run" end (
        newPC: program
        if all [not tail? newPC mode = 'command] [run-program]
    )
    | "stop" (error-statement: none make error! "STOP")
    | "until" sp (type: 'none) basic-condition end (
        if empty? repeat-stack [make-error 43]
        either num <> 0 [pop-repeat] [newPC: find program pop-repeat]
    )
    | opt "let" sp [
        basic-integer-array (arg1: skip integer-arrays/:word number)
        sp "=" sp (type: 'number) basic-condition (
            change arg1 to integer! num
        )
        | copy arg1 [var-name | "@"] "%" sp "=" sp (type: 'number) basic-condition (
            arg1: to word! arg1
            num: to integer! num
            either find/case residents arg1 [change next find/case residents arg1 num ][
                either find/case integers arg1 [
                    change next find/case integers arg1 num
                ][
                    insert integers reduce [arg1 num]
                ]
            ]
        )
        | basic-string-array (arg1: skip string-arrays/:word number)
        sp "=" sp (type: 'string) basic-condition (
            change arg1 str
        )
        | copy arg1 var-name "$" sp "=" sp (type: 'string) basic-condition (
            arg1: to word! arg1
            either find/case strings arg1 [change next find/case strings arg1 str ][
                insert strings reduce [arg1 str]
            ]
        )
        | basic-real-array (arg1: skip real-arrays/:word number)
        sp "=" sp (type: 'number) basic-condition (
            change arg1 num
        )
        | copy arg1 var-name sp "=" sp (type: 'number) basic-condition (
            arg1: to word! arg1
            either find/case reals arg1 [change next find/case reals arg1 num ][
                either arg1 = 'time [
                    time: now/precise
                    time/time: time/time - (num / 100)
                ][
                    insert reals reduce [arg1 num]
                ]
            ]
        )
    ]
]
; Arguments
arguments: []
def-arg: [
    sp [
        copy arg2 var-name "%" (
            arg2: to word! arg2
            append arguments reduce ['integer arg2]
        )
        | copy arg2 var-name "$" (
            arg2: to word! arg2
            append arguments reduce ['string arg2]
        )
        | copy arg2 var-name (
            arg2: to word! arg2
            append arguments reduce ['real arg2]
        )
    ]
]
local-arg: [
    sp [
        copy arg1 var-name "%" (
            arg1: to word! arg1
            if not find/case stored-integers/1 arg1 [
                either find/case integers arg1 [
                    insert stored-integers/1 reduce [arg1 integers/:arg1]
                    change next find/case integers arg1 0
                ][
                    insert stored-integers/1 reduce [arg1 0]
                    insert integers reduce [arg1 0]
                ]
            ]
        )
        | copy arg1 var-name "$" (
            arg1: to word! arg1
            if not find/case stored-strings/1 arg1 [
                either find/case strings arg1 [
                    insert stored-strings/1 reduce [arg1 strings/:arg1]
                    change next find/case strings arg1 copy ""
                ][
                    insert stored-strings/1 reduce [arg1 copy ""]
                    insert strings reduce [arg1 copy ""]
                ]
            ]
        )
        | copy arg1 var-name (
            arg1: to word! arg1
            if not find/case stored-reals/1 arg1 [
                either find/case reals arg1 [
                    insert stored-reals/1 reduce [arg1 reals/:arg1]
                    change next find/case reals arg1 0
                ][
                    insert stored-reals/1 reduce [arg1 0]
                    insert reals reduce [arg1 0]
                ]
            ]
        )
    ]
]
proc-arg: [
    (type: 'none) basic-condition (
        if tail? arguments [make-error 31]
        switch arguments/1 [
            integer [if type = 'string [make-error 31]]
            string [if type <> 'string [make-error 31]]
            real [if type = 'string [make-error 31]]
        ]
        switch arguments/1 [
            integer [
                either find/case integers arguments/2 [
                    insert stored-integers/1 reduce [arguments/2 integers/(arguments/2)]
                    change next find/case integers arguments/2 to integer! num
                ][
                    insert stored-integers/1 reduce [arguments/2 0]
                    insert integers reduce [arguments/2 to integer! num]
                ]
            ]
            real [
                either find/case reals arguments/2 [
                    insert stored-reals/1 reduce [arguments/2 reals/(arguments/2)]
                    change next find/case reals arguments/2 num
                ][
                    insert stored-reals/1 reduce [arguments/2 0]
                    insert reals reduce [arguments/2 num]
                ]
            ]
            string [
                either find/case strings arguments/2 [
                    insert stored-strings/1 reduce [arguments/2 strings/(arguments/2)]
                    change next find/case strings arguments/2 str
                ][
                    insert stored-strings/1 reduce [arguments/2 copy ""]
                    insert strings reduce [arguments/2 str]
                ]
            ]
        ]
        arguments: skip arguments 2
    )
]
read-arg: [
    (if none? data [make-error 42]) sp [
        copy arg1 [var-name | "@"] "%" (
            arg1: to word! arg1
            parse-data
            if error? try [num: to integer! str] [num: 0]
            either find/case residents arg1 [change next find/case residents arg1 num ][
                either find/case integers arg1 [
                    change next find/case integers arg1 num
                ][
                    insert integers reduce [arg1 num]
                ]
            ]
        )
        | copy arg1 var-name "$" (
            arg1: to word! arg1
            parse-data
            either find/case strings arg1 [change next find/case strings arg1 str ][
                insert strings reduce [arg1 str]
            ]
        )
        | copy arg1 var-name (
            arg1: to word! arg1
            parse-data
            if error? try [num: to decimal! str] [num: 0.0]
            either find/case reals arg1 [change next find/case reals arg1 num ][
                insert reals reduce [arg1 num]
            ]
        )
    ]
]
; Run Program
run-program: does [
    mode: 'running
    PC: newPC
    until [
        either mode = 'error [
            PC: error-PC
            CODE: error-statement
            mode: 'running
        ][CODE: PC/2 ]
        either error? error: try [
            newPC: skip PC 2
            if not parse/all trim CODE [basic-statements end] [make-error 16]
            PC: newPC
        ] [; error? try
            erl: PC/1
            error: disarm error
            report: either string? error/arg1 [copy error/arg1] ["Unknown"]
            either error-statement [
                mode: 'error
                false
            ][
                print [newline error/arg1 "at line" PC/1]
                true
            ]
        ] [tail? PC ]
    ]
    mode: 'command
]
; Main Function
set 'basic does [
    clear program
    clear residents
    append residents reduce [to word! "@" to integer! #{0000090A}]
    for c #"A" #"Z" 1 [append residents reduce [to word! to string! c 0]]
    clear-vars
    rnd/one
    print ["BASIC v." system/script/header/Version newline]
    time: now/precise
    forever [
        clear line
        clear stack
        clear for-stack
        clear gosub-stack
        clear proc-stack
        clear repeat-stack
        restore-data
        if error? error: try [
            either auto [
                ln: arg1
                arg1: arg1 + any [arg2 10]
                clear str
                insert str ln
                insert/dup str " " 5 - length? str
                append str " "
                prin str
                insert line input
            ][
                str: ask ">"
                either parse str [copy ln integer! mark1: to end] [
                    ln: to integer! ln
                    insert line copy mark1
                ][
                    insert line copy str
                    ln: none
                ]
            ]
            either ln [
                either any [ln < 0 ln > MAX-LIN] [make-error 16 ][
                    either empty? line [
                        if find program ln [
                            remove/part find program ln 2
                        ]
                    ][
                        either all [auto line = "0"] [auto: off ][
                            either find program ln [
                                change next find program ln trim copy line
                            ][
                                insert program reduce [ln trim copy line]
                                sort/skip program 2
                            ]
                        ]
                    ]
                ]
            ][
                PC: tail program
                if not parse/all trim line [
                    basic-command end | basic-statements end | end
                ] [make-error 16 ]
            ]
        ] [; error? try
            erl: 0
            error: disarm error
            report: either string? error/arg1 [copy error/arg1] ["Unknown"]
            print [newline error/arg1]
        ]
    ]   ; forever
]
basic
]   ; context


Usage:

>> do %basic.r
BASIC v. 0.4.1

>

No comments:

Post a Comment