558 lines
12 KiB
QBasic
Executable file
558 lines
12 KiB
QBasic
Executable file
DECLARE FUNCTION lookupop$ (op%)
|
|
DECLARE FUNCTION guessdef$ (ptr%)
|
|
DECLARE FUNCTION loadimg! (filename$)
|
|
DECLARE SUB bootstrap ()
|
|
DECLARE SUB saveimg (filename$)
|
|
DECLARE SUB loadfile (filename$)
|
|
DECLARE SUB vm ()
|
|
DECLARE SUB interpret (st$)
|
|
DECLARE SUB execute (op%)
|
|
DECLARE SUB assemble (name$, asm$)
|
|
DECLARE FUNCTION lookup! (w$)
|
|
DECLARE FUNCTION rpeek! ()
|
|
DECLARE FUNCTION nextword$ ()
|
|
DECLARE FUNCTION mkstr% (st$)
|
|
DECLARE SUB opcode (opname$, op%)
|
|
DECLARE SUB rpush (v%)
|
|
DECLARE FUNCTION rpop! ()
|
|
DECLARE SUB push (v%)
|
|
DECLARE FUNCTION pop! ()
|
|
DECLARE FUNCTION top! ()
|
|
TYPE word
|
|
nm AS STRING * 32
|
|
df AS INTEGER
|
|
i AS INTEGER
|
|
END TYPE
|
|
CONST WORDCOUNT = 256
|
|
CONST memcount = 10000
|
|
DIM SHARED words(WORDCOUNT) AS word
|
|
DIM SHARED strings$(32)
|
|
DIM SHARED messages$(32)
|
|
DIM SHARED mem(memcount) AS INTEGER
|
|
DIM SHARED stack(64) AS INTEGER
|
|
DIM SHARED rstack(64) AS INTEGER
|
|
COMMON SHARED sp AS INTEGER, rsp AS INTEGER, w AS INTEGER, ip AS INTEGER
|
|
COMMON SHARED tracevm
|
|
COMMON SHARED in$, inline%
|
|
COMMON SHARED interpretcp AS INTEGER
|
|
COMMON SHARED trace%
|
|
|
|
inline% = -1
|
|
interpretcp = -1
|
|
trace% = 0 ' 10
|
|
|
|
OPEN "messages.txt" FOR INPUT AS #1
|
|
FOR i = 0 TO 31
|
|
IF EOF(1) = 0 THEN LINE INPUT #1, messages$(i)
|
|
NEXT
|
|
CLOSE #1
|
|
|
|
OPEN "out.com" FOR OUTPUT AS #1
|
|
CLOSE #1
|
|
OPEN "out.com" FOR BINARY AS #1
|
|
|
|
IF trace% > 0 THEN
|
|
OPEN "TRACE.TXT" FOR OUTPUT AS #trace%
|
|
END IF
|
|
|
|
CONST O.RET = -1
|
|
CONST O.DUP = -2
|
|
CONST O.SWAP = -3
|
|
CONST O.DROP = -4
|
|
CONST O.GET = -5
|
|
CONST O.SET = -6
|
|
CONST O.CREATE = -7
|
|
CONST O.IN = -8
|
|
CONST O.OUT = -9
|
|
CONST O.EXEC = -10
|
|
CONST O.LOOKUP = -11
|
|
CONST O.WORD = -12
|
|
CONST O.NUMBER = -13
|
|
CONST O.LIT = -14
|
|
CONST O.ADD = -15
|
|
CONST O.SUB = -16
|
|
CONST O.MUL = -17
|
|
CONST O.DIV = -18
|
|
CONST O.JZ = -19
|
|
CONST O.RPUSH = -20
|
|
CONST O.RPOP = -21
|
|
CONST O.COMMA = -22
|
|
CONST O.ROT = -23
|
|
CONST O.LT = -24
|
|
CONST O.EQ = -25
|
|
CONST O.JMP = -26
|
|
CONST O.YELP = -27
|
|
CONST O.IMMEDIATE = -28
|
|
CONST O.RDROP = -29
|
|
CONST O.RTOP = -30
|
|
CONST O.RSWAP = -31
|
|
CONST O.BITAND = -32
|
|
CONST O.BITOR = -33
|
|
CONST O.MESSAGE = -34
|
|
CONST O.TRACE = -35
|
|
CONST O.TELL = -36
|
|
CONST O.SEEK = -37
|
|
|
|
CONST P.HERE = 0
|
|
CONST P.LATEST = 1
|
|
CONST P.NEXTSTR = 2
|
|
|
|
IF loadimg("asm.img") = 0 THEN
|
|
IF loadimg("boot.img") = 0 THEN
|
|
PRINT "Bootstrapping"
|
|
CALL bootstrap
|
|
CALL saveimg("boot.img")
|
|
END IF
|
|
CALL loadfile("asm.qf")
|
|
CALL saveimg("asm.img")
|
|
END IF
|
|
|
|
CALL loadfile("in.asm")
|
|
|
|
SUB assemble (name$, asm$)
|
|
in$ = asm$
|
|
done = 0
|
|
CALL push(mkstr(name$))
|
|
CALL execute(O.CREATE)
|
|
IF trace% > 0 THEN
|
|
PRINT #trace%, name$; " -> "; mem(P.LATEST)
|
|
END IF
|
|
WHILE done = 0
|
|
CALL execute(O.WORD)
|
|
IF top < 0 THEN
|
|
done = 1
|
|
x = pop
|
|
ELSE
|
|
word$ = strings$(top)
|
|
CALL execute(O.LOOKUP)
|
|
IF pop <> 0 THEN
|
|
x = pop ' immediate flag, ignore
|
|
IF trace% > 0 THEN PRINT #trace%, word$; " => "; STR$(top); " => "; mem(P.HERE)
|
|
CALL execute(O.COMMA)
|
|
ELSE
|
|
CALL execute(O.NUMBER)
|
|
IF pop <> 0 THEN
|
|
IF trace% > 0 THEN PRINT #trace%, word$; " => "; STR$(top); " => "; mem(P.HERE)
|
|
CALL execute(O.COMMA)
|
|
ELSE
|
|
CALL execute(O.YELP)
|
|
END IF
|
|
END IF
|
|
END IF
|
|
WEND
|
|
END SUB
|
|
|
|
SUB bootstrap
|
|
mem(P.LATEST) = -1
|
|
mem(P.HERE) = 3
|
|
|
|
CALL opcode("ret", O.RET)
|
|
CALL opcode("dup", O.DUP)
|
|
CALL opcode("swap", O.SWAP)
|
|
CALL opcode(">rot", O.ROT)
|
|
CALL opcode("@", O.GET)
|
|
CALL opcode("!", O.SET)
|
|
CALL opcode("create", O.CREATE)
|
|
CALL opcode("in@", O.IN)
|
|
CALL opcode("outb!", O.OUT)
|
|
CALL opcode("immediate", O.IMMEDIATE)
|
|
CALL opcode("drop", O.DROP)
|
|
CALL opcode("execute", O.EXEC)
|
|
CALL opcode("lookup", O.LOOKUP)
|
|
CALL opcode("word@", O.WORD)
|
|
CALL opcode("number", O.NUMBER)
|
|
CALL opcode("lit_", O.LIT)
|
|
CALL opcode("+", O.ADD)
|
|
CALL opcode("-", O.SUB)
|
|
CALL opcode("*", O.MUL)
|
|
CALL opcode("/", O.DIV)
|
|
CALL opcode("<", O.LT)
|
|
CALL opcode("=", O.EQ)
|
|
CALL opcode("&", O.BITAND)
|
|
CALL opcode("|", O.BITOR)
|
|
CALL opcode("jz_", O.JZ)
|
|
CALL opcode("jmp_", O.JMP)
|
|
CALL opcode(">r", O.RPUSH)
|
|
CALL opcode("r>", O.RPOP)
|
|
CALL opcode("r@", O.RTOP)
|
|
CALL opcode("rdrop", O.RDROP)
|
|
CALL opcode("rswap", O.RSWAP)
|
|
CALL opcode(",", O.COMMA)
|
|
CALL opcode("message", O.MESSAGE)
|
|
CALL opcode("yelp", O.YELP)
|
|
CALL opcode("trace", O.TRACE)
|
|
CALL opcode("seek", O.SEEK)
|
|
CALL opcode("tell", O.TELL)
|
|
|
|
CALL assemble("<rot", ">rot >rot ret")
|
|
CALL assemble("over", "swap dup >rot ret")
|
|
CALL assemble("2dup", "over over ret")
|
|
CALL assemble("$var", "r> ret")
|
|
CALL assemble("$const", "r> @ ret")
|
|
CALL assemble("not", "jz_ 4 lit_ 0 ret lit_ 1 ret")
|
|
CALL assemble("and", "jz_ 5 jz_ 4 jmp_ 5 drop lit_ 0 ret lit_ 1 ret")
|
|
CALL assemble("or", "not swap not and not ret")
|
|
CALL assemble(">=", "< not ret")
|
|
CALL assemble("<=", "2dup < >rot = or ret")
|
|
CALL assemble(">", "<= not ret")
|
|
CALL assemble("state", "$var 0")
|
|
|
|
CALL assemble("doword", "state @ not or jz_ 3 execute ret , ret")
|
|
CALL assemble("donum", "state @ jz_ 5 lit_ lit_ , , ret")
|
|
CALL assemble("donext", "lookup jz_ 3 doword ret number jz_ 3 donum ret yelp ret")
|
|
CALL assemble("interpret", "word@ dup lit_ 0 >= jz_ 4 donext jmp_ -9 drop ret")
|
|
CALL assemble("[", "lit_ 0 state ! ret"): CALL execute(O.IMMEDIATE)
|
|
CALL assemble("]", "lit_ 1 state ! ret")
|
|
CALL assemble(":", "word@ create ] ret")
|
|
CALL assemble(";", "lit_ ret , [ ret"): CALL execute(O.IMMEDIATE)
|
|
CALL assemble("lit", "lit_ lit_ , , ret")
|
|
CALL assemble("'", "word@ lookup drop drop state @ jz_ 2 lit ret"): CALL execute(O.IMMEDIATE)
|
|
|
|
CALL loadfile("boot.qf")
|
|
END SUB
|
|
|
|
SUB execute (op%)
|
|
IF trace% > 0 AND tracevm THEN
|
|
tp$ = "N/A"
|
|
IF sp > 0 THEN tp$ = STR$(top)
|
|
PRINT #trace%, "ip:"; ip; " sp:"; sp; " rp:"; rsp; " tp:"; tp$; " fn:"; guessdef$(ip); " op:"; lookupop$(op%)
|
|
END IF
|
|
SELECT CASE op%
|
|
CASE IS >= 0
|
|
CALL rpush(ip)
|
|
ip = op%
|
|
CASE O.RET
|
|
ip = rpop
|
|
CASE O.DUP
|
|
CALL push(top)
|
|
CASE O.SWAP
|
|
x = stack(sp - 1)
|
|
y = stack(sp - 2)
|
|
stack(sp - 1) = y
|
|
stack(sp - 2) = x
|
|
CASE O.ROT
|
|
s3% = pop
|
|
s2% = pop
|
|
s1% = pop
|
|
' >rot ( 1 2 3 -- 3 1 2 )
|
|
CALL push(s3%)
|
|
CALL push(s1%)
|
|
CALL push(s2%)
|
|
CASE O.DROP
|
|
x = pop
|
|
CASE O.GET
|
|
ptr = pop
|
|
CALL push(mem(ptr))
|
|
CASE O.SET
|
|
ptr = pop
|
|
value = pop
|
|
mem(ptr) = value
|
|
CASE O.CREATE
|
|
word = mem(P.LATEST) + 1
|
|
mem(P.LATEST) = word
|
|
sname = pop
|
|
words(word).nm = strings$(sname)
|
|
words(word).df = mem(P.HERE)
|
|
CASE O.IN
|
|
c$ = MID$(in$, 1, 1)
|
|
in$ = MID$(in$, 2)
|
|
IF c$ = "" THEN
|
|
CALL push(-1)
|
|
ELSE
|
|
CALL push(ASC(c$))
|
|
END IF
|
|
CASE O.OUT
|
|
byte$ = CHR$(pop)
|
|
PUT #1, , byte$
|
|
CASE O.TELL
|
|
CALL push(SEEK(1) - 1)
|
|
CASE O.SEEK
|
|
SEEK #1, pop + 1
|
|
|
|
CASE O.LOOKUP
|
|
istr% = pop
|
|
iword = lookup(strings$(istr%))
|
|
IF iword < 0 THEN
|
|
CALL push(istr%)
|
|
CALL push(0)
|
|
ELSE
|
|
CALL push(words(iword).df)
|
|
CALL push(words(iword).i)
|
|
CALL push(1)
|
|
END IF
|
|
CASE O.WORD
|
|
word$ = nextword$
|
|
IF word$ <> "" THEN
|
|
IF trace% > 0 THEN
|
|
PRINT #trace%, "read: "; word$
|
|
END IF
|
|
CALL push(mkstr(word$))
|
|
ELSE
|
|
CALL push(-1)
|
|
END IF
|
|
CASE O.NUMBER
|
|
istr% = pop
|
|
n$ = strings$(istr%)
|
|
IF VAL(n$ + "1") = 0 THEN
|
|
CALL push(istr%)
|
|
CALL push(0)
|
|
ELSE
|
|
CALL push(VAL(n$))
|
|
CALL push(1)
|
|
END IF
|
|
|
|
CASE O.IMMEDIATE
|
|
word = mem(P.LATEST)
|
|
words(word).i = 1
|
|
CASE O.EXEC
|
|
CALL execute(pop)
|
|
|
|
CASE O.LIT
|
|
CALL push(mem(ip))
|
|
ip = ip + 1
|
|
CASE O.ADD
|
|
r = pop
|
|
l = pop
|
|
CALL push(l + r)
|
|
CASE O.SUB
|
|
r = pop
|
|
l = pop
|
|
CALL push(l - r)
|
|
CASE O.MUL
|
|
r = pop
|
|
l = pop
|
|
CALL push(l * r)
|
|
CASE O.DIV
|
|
r = pop
|
|
l = pop
|
|
CALL push(INT(l / r))
|
|
|
|
CASE O.BITAND
|
|
r = pop
|
|
l = pop
|
|
CALL push(l AND r)
|
|
CASE O.BITOR
|
|
r = pop
|
|
l = pop
|
|
CALL push(l OR r)
|
|
|
|
CASE O.LT
|
|
r = pop
|
|
l = pop
|
|
CALL push(l < r)
|
|
CASE O.EQ
|
|
r = pop
|
|
l = pop
|
|
IF l = r THEN
|
|
CALL push(1)
|
|
ELSE
|
|
CALL push(0)
|
|
END IF
|
|
CASE O.JZ
|
|
IF pop = 0 THEN
|
|
ip = ip + mem(ip)
|
|
ELSE
|
|
ip = ip + 1
|
|
END IF
|
|
CASE O.JMP
|
|
ip = ip + mem(ip)
|
|
CASE O.RPUSH
|
|
CALL rpush(pop)
|
|
CASE O.RPOP
|
|
CALL push(rpop)
|
|
CASE O.RDROP
|
|
z = rpop
|
|
CASE O.RSWAP
|
|
x% = rpop
|
|
y% = rpop
|
|
CALL rpush(x%)
|
|
CALL rpush(y%)
|
|
CASE O.RTOP
|
|
CALL push(rpeek)
|
|
CASE O.COMMA
|
|
here = mem(P.HERE)
|
|
mem(here) = pop
|
|
mem(P.HERE) = here + 1
|
|
CASE O.YELP
|
|
PRINT strings$(pop); "? line "; inline%
|
|
CASE O.TRACE
|
|
tracevm = pop
|
|
CASE O.MESSAGE
|
|
CALL push(mkstr(messages$(pop)))
|
|
|
|
CASE ELSE
|
|
PRINT "Unknown op "; op%
|
|
ip = -1
|
|
END SELECT
|
|
END SUB
|
|
|
|
FUNCTION guessdef$ (ptr%)
|
|
guessdef$ = "???"
|
|
IF ptr% < 0 THEN
|
|
guessdef$ = "**INJECTED**"
|
|
ELSE
|
|
FOR i = mem(P.LATEST) - 1 TO 0 STEP -1
|
|
IF words(i).df < ptr% THEN
|
|
guessdef$ = RTRIM$(words(i).nm)
|
|
GOTO doneguessdef
|
|
END IF
|
|
NEXT
|
|
END IF
|
|
doneguessdef:
|
|
END FUNCTION
|
|
|
|
SUB interpret (st$)
|
|
IF interpretcp < 0 THEN
|
|
CALL push(mkstr("interpret"))
|
|
CALL execute(O.LOOKUP)
|
|
z = pop
|
|
z = pop
|
|
interpretcp = pop
|
|
END IF
|
|
in$ = st$
|
|
ip = -1
|
|
CALL execute(interpretcp)
|
|
CALL vm
|
|
END SUB
|
|
|
|
SUB loadfile (filename$)
|
|
PRINT "Building "; filename$
|
|
inline% = 0
|
|
OPEN filename$ FOR INPUT AS #2
|
|
WHILE EOF(2) = 0
|
|
LINE INPUT #2, line$
|
|
inline% = inline% + 1
|
|
CALL interpret(line$)
|
|
WEND
|
|
CLOSE #2
|
|
inline% = -1
|
|
END SUB
|
|
|
|
FUNCTION loadimg (filename$)
|
|
OPEN filename$ FOR BINARY AS #3
|
|
IF LOF(3) > 0 THEN
|
|
FOR i = 0 TO WORDCOUNT - 1
|
|
GET #3, , words(i)
|
|
NEXT
|
|
filememsize = LOF(3) - SEEK(3)
|
|
FOR i = 0 TO filememsize / 2
|
|
GET #3, , mem(i)
|
|
NEXT
|
|
loadimg = 1
|
|
ELSE
|
|
loadimg = 0
|
|
END IF
|
|
CLOSE #3
|
|
END FUNCTION
|
|
|
|
FUNCTION lookup (w$)
|
|
lookup = -1
|
|
FOR i = mem(P.LATEST) TO 0 STEP -1
|
|
IF RTRIM$(words(i).nm) = w$ THEN
|
|
lookup = i
|
|
GOTO found
|
|
END IF
|
|
NEXT
|
|
found:
|
|
END FUNCTION
|
|
|
|
FUNCTION lookupop$ (op%)
|
|
lookupop$ = STR$(op%)
|
|
FOR i = 0 TO mem(P.LATEST)
|
|
IF words(i).df = op% THEN
|
|
lookupop$ = RTRIM$(words(i).nm)
|
|
GOTO lookupopdone
|
|
ELSEIF op% < 0 AND words(i).df > 0 THEN
|
|
GOTO lookupopdone
|
|
ELSEIF op% > 0 AND words(i).df > op% THEN
|
|
GOTO lookupopdone
|
|
END IF
|
|
NEXT
|
|
lookupopdone:
|
|
END FUNCTION
|
|
|
|
FUNCTION mkstr% (st$)
|
|
istr = mem(P.NEXTSTR)
|
|
mem(P.NEXTSTR) = (istr + 1) MOD 32
|
|
strings$(istr) = st$
|
|
mkstr% = istr
|
|
END FUNCTION
|
|
|
|
FUNCTION nextword$
|
|
wordstart = 0
|
|
length = 0
|
|
FOR i = 1 TO LEN(in$)
|
|
c$ = MID$(in$, i, 1)
|
|
IF c$ = " " THEN
|
|
IF wordstart <> 0 THEN
|
|
GOTO foundword
|
|
END IF
|
|
ELSE
|
|
IF wordstart = 0 THEN
|
|
wordstart = i
|
|
END IF
|
|
length = length + 1
|
|
END IF
|
|
NEXT
|
|
foundword:
|
|
IF wordstart <> 0 THEN
|
|
nextword$ = MID$(in$, wordstart, length)
|
|
in$ = MID$(in$, wordstart + length + 1) ' consume the space
|
|
END IF
|
|
END FUNCTION
|
|
|
|
SUB opcode (opname$, op%)
|
|
word = mem(P.LATEST) + 1
|
|
mem(P.LATEST) = word
|
|
words(word).nm = opname$
|
|
words(word).df = op%
|
|
END SUB
|
|
|
|
FUNCTION pop
|
|
sp = sp - 1
|
|
pop = stack(sp)
|
|
END FUNCTION
|
|
|
|
SUB push (v%)
|
|
stack(sp) = v%
|
|
sp = sp + 1
|
|
END SUB
|
|
|
|
FUNCTION rpeek
|
|
rpeek = rstack(rsp - 1)
|
|
END FUNCTION
|
|
|
|
FUNCTION rpop
|
|
rsp = rsp - 1
|
|
rpop = rstack(rsp)
|
|
END FUNCTION
|
|
|
|
SUB rpush (v%)
|
|
rstack(rsp) = v%
|
|
rsp = rsp + 1
|
|
END SUB
|
|
|
|
SUB saveimg (filename$)
|
|
OPEN filename$ FOR BINARY AS #3
|
|
FOR i = 0 TO WORDCOUNT - 1
|
|
PUT #3, , words(i)
|
|
NEXT
|
|
FOR i = 0 TO mem(P.HERE)
|
|
PUT #3, , mem(i)
|
|
NEXT
|
|
CLOSE #3
|
|
END SUB
|
|
|
|
FUNCTION top
|
|
top = stack(sp - 1)
|
|
END FUNCTION
|
|
|
|
SUB vm
|
|
WHILE ip >= 0
|
|
op% = mem(ip)
|
|
ip = ip + 1
|
|
CALL execute(op%)
|
|
WEND
|
|
END SUB
|
|
|