qf/qf.bas

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