From f4e846789883b21594e451e3d4e6a3e098763017 Mon Sep 17 00:00:00 2001
From: Jeremy Penner <jeremy@sporktania.com>
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 >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
+