first cut at working VM and forth assembler

This commit is contained in:
Jeremy Penner 2019-10-18 20:15:36 -04:00
commit f4e8467898

404
qf.bas Executable file
View file

@ -0,0 +1,404 @@
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
DIM SHARED words(256) AS word
DIM SHARED strings$(32)
DIM SHARED mem(10000) 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 in$
COMMON SHARED interpretcp AS INTEGER
COMMON SHARED trace%
interpretcp = -1
trace% = 0
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 P.HERE = 0
CONST P.LATEST = 1
CONST P.NEXTSTR = 2
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("out!", 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("jz_", O.JZ)
CALL opcode("jmp_", O.JMP)
CALL opcode(">r", O.RPUSH)
CALL opcode("r>", O.RPOP)
CALL opcode(",", O.COMMA)
CALL opcode("yelp", O.YELP)
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_ 3 lit_ 0 ret lit_ 1 ret")
CALL assemble("and", "jz_ 4 jz_ 3 jmp_ 4 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_ 2 execute ret , ret")
CALL assemble("donum", "state @ jz_ 4 lit_ lit_ , , ret")
CALL assemble("donext", "lookup jz_ 2 doword ret number jz_ 2 donum ret yelp ret")
CALL assemble("interpret", "word@ dup lit_ 0 >= jz_ 3 donext jmp_ -10 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 interpret("65 out! 66 out! 0 out! 67 out! 7 out! 254 out! 10 out! 13 out!")
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 execute (op%)
IF trace% > 0 THEN
tp$ = "NA"
IF sp > 0 THEN tp$ = STR$(top)
PRINT #trace%, "ip:"; ip; " op:"; op%; " sp:"; sp; " tp:"; tp$; " rsp:"; rsp
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.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
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(l / 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) + 1
ELSE
ip = ip + 1
END IF
CASE O.JMP
ip = ip + mem(ip) + 1
CASE O.RPUSH
CALL rpush(pop)
CASE O.RPOP
CALL push(rpop)
CASE O.COMMA
here = mem(P.HERE)
mem(here) = pop
mem(P.HERE) = here + 1
CASE O.YELP
PRINT strings$(pop); "?"
CASE ELSE
PRINT "Unknown op "; op%
ip = -1
END SELECT
END SUB
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
FUNCTION lookup (w$)
lookup = -1
FOR i = 0 TO mem(P.LATEST)
IF RTRIM$(words(i).nm) = w$ THEN
lookup = i
GOTO found
END IF
NEXT
found:
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)
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
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