From f4e846789883b21594e451e3d4e6a3e098763017 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Fri, 18 Oct 2019 20:15:36 -0400 Subject: [PATCH] first cut at working VM and forth assembler --- qf.bas | 404 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 404 insertions(+) create mode 100755 qf.bas diff --git a/qf.bas b/qf.bas new file mode 100755 index 0000000..66ca35a --- /dev/null +++ b/qf.bas @@ -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 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 +