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
>
Really informative blog and helpful as well, I dont think so anyone go to search in google because all the information are in your blog.
ReplyDeleteTranslation Services in Delhi | Translation Services in India | Translation Services in Gurgaon | Translation Companies in India | Translation Services in Bangalore | Translation Services in Mumbai | Translation Services in Chennai | Translation Services in Mumbai | Translation Companies in Delhi | Translation Companies in India