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% = 10 ' 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 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(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