X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fforth.jl;h=4b625bc146eb19cbcc36a51f6ab414789726645d;hb=03de266dbc3975cfa2f3b07de2d58ff642f4bf76;hp=9da680c832abe82466e4c5bea4d0444a00c8904d;hpb=d9652f786f96bb109ea03582db138816db0f8fda;p=forth.jl.git diff --git a/src/forth.jl b/src/forth.jl index 9da680c..4b625bc 100644 --- a/src/forth.jl +++ b/src/forth.jl @@ -31,6 +31,7 @@ size_TIB = 1096 # Terminal input buffer size mem = Array{Int64,1}(size_mem) primitives = Array{Function,1}() +primNames = Array{ASCIIString,1}() # Built-in variables @@ -101,6 +102,13 @@ function popPS() return val end +# Handy functions for adding/retrieving strings to/from memory. + +getString(addr::Int64, len::Int64) = ASCIIString([Char(c) for c in mem[addr:(addr+len-1)]]) +function putString(str::ASCIIString, addr::Int64) + mem[addr:(addr+length(str)-1)] = [Int64(c) for c in str] +end + # Primitive creation and calling functions function createHeader(name::AbstractString, flags::Int64) @@ -109,17 +117,20 @@ function createHeader(name::AbstractString, flags::Int64) mem[HERE] += 1 mem[mem[HERE]] = length(name) | flags; mem[HERE] += 1 - mem[mem[HERE]:(mem[HERE]+length(name)-1)] = [Int(c) for c in name]; mem[HERE] += length(name) + putString(name, mem[HERE]); mem[HERE] += length(name) end function defPrim(name::AbstractString, f::Function; flags::Int64=0) createHeader(name, flags) + codeWordAddr = mem[HERE] push!(primitives, f) - mem[mem[HERE]] = -length(primitives) + mem[codeWordAddr] = -length(primitives) mem[HERE] += 1 - return -length(primitives) + push!(primNames, name) + + return codeWordAddr end callPrim(addr::Int64) = primitives[-addr]() @@ -127,29 +138,30 @@ callPrim(addr::Int64) = primitives[-addr]() function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0) defPrim(name, eval(:(() -> begin pushPS($(varAddr)) - return NEXT + return mem[NEXT] end))) end function defNewVar(name::AbstractString, initial::Int64; flags::Int64=0) createHeader(name, flags) + codeWordAddr = mem[HERE] varAddr = mem[HERE] + 1 push!(primitives, eval(:(() -> begin pushPS($(varAddr)) - return NEXT + return mem[NEXT] end))) mem[mem[HERE]] = -length(primitives); mem[HERE] += 1 mem[mem[HERE]] = initial; mem[HERE] += 1 - return varAddr + return varAddr, codeWordAddr end function defConst(name::AbstractString, val::Int64; flags::Int64=0) defPrim(name, eval(:(() -> begin pushPS($(val)) - return NEXT + return mem[NEXT] end))) return val @@ -159,7 +171,7 @@ function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0 createHeader(name, flags) addr = mem[HERE] - mem[mem[HERE]] = DOCOL + mem[mem[HERE]] = mem[DOCOL] mem[HERE] += 1 for wordAddr in wordAddrs @@ -170,32 +182,30 @@ function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0 return addr end -# Threading Primitives +# Threading Primitives (inner interpreter) NEXT = defPrim("NEXT", () -> begin reg.W = mem[reg.IP] reg.IP += 1 - X = mem[reg.W] - return X + return mem[reg.W] end) DOCOL = defPrim("DOCOL", () -> begin pushRS(reg.IP) reg.IP = reg.W + 1 - return NEXT + return mem[NEXT] end) EXIT = defPrim("EXIT", () -> begin reg.IP = popRS() - return NEXT + return mem[NEXT] end) - # Basic forth primitives DROP = defPrim("DROP", () -> begin popPS() - return NEXT + return mem[NEXT] end) SWAP = defPrim("SWAP", () -> begin @@ -203,18 +213,18 @@ SWAP = defPrim("SWAP", () -> begin b = popPS() pushPS(a) pushPS(b) - return NEXT + return mem[NEXT] end) DUP = defPrim("DUP", () -> begin pushPS(mem[reg.PSP]) - return NEXT + return mem[NEXT] end) OVER = defPrim("OVER", () -> begin ensurePSDepth(2) pushPS(mem[reg.PSP-1]) - return NEXT + return mem[NEXT] end) ROT = defPrim("ROT", () -> begin @@ -224,7 +234,7 @@ ROT = defPrim("ROT", () -> begin pushPS(a) pushPS(c) pushPS(b) - return NEXT + return mem[NEXT] end) NROT = defPrim("-ROT", () -> begin @@ -234,13 +244,13 @@ NROT = defPrim("-ROT", () -> begin pushPS(b) pushPS(a) pushPS(c) - return NEXT + return mem[NEXT] end) TWODROP = defPrim("2DROP", () -> begin popPS() popPS() - return NEXT + return mem[NEXT] end) TWODUP = defPrim("2DUP", () -> begin @@ -249,7 +259,7 @@ TWODUP = defPrim("2DUP", () -> begin b = mem[reg.PSP] pushPS(a) pushPS(b) - return NEXT + return mem[NEXT] end) TWOSWAP = defPrim("2SWAP", () -> begin @@ -261,7 +271,7 @@ TWOSWAP = defPrim("2SWAP", () -> begin pushPS(a) pushPS(c) pushPS(d) - return NEXT + return mem[NEXT] end) QDUP = defPrim("?DUP", () -> begin @@ -270,55 +280,167 @@ QDUP = defPrim("?DUP", () -> begin if val != 0 pushPS(val) end - return NEXT + return mem[NEXT] end) INCR = defPrim("1+", () -> begin ensurePSDepth(1) mem[reg.PSP] += 1 - return NEXT + return mem[NEXT] end) DECR = defPrim("1-", () -> begin ensurePSDepth(1) mem[reg.PSP] -= 1 - return NEXT + return mem[NEXT] +end) + +INCR2 = defPrim("2+", () -> begin + ensurePSDepth(1) + mem[reg.PSP] += 2 + return mem[NEXT] +end) + +DECR2 = defPrim("2-", () -> begin + ensurePSDepth(1) + mem[reg.PSP] -= 2 + return mem[NEXT] end) ADD = defPrim("+", () -> begin - a = popPS() b = popPS() + a = popPS() pushPS(a+b) - return NEXT + return mem[NEXT] end) SUB = defPrim("-", () -> begin - a = popPS() b = popPS() - pushPS(b-a) - return NEXT + a = popPS() + pushPS(a-b) + return mem[NEXT] end) MUL = defPrim("*", () -> begin - a = popPS() b = popPS() + a = popPS() pushPS(a*b) - return NEXT + return mem[NEXT] end) DIVMOD = defPrim("/MOD", () -> begin - a = popPS() b = popPS() - q,r = divrem(b,a) + a = popPS() + q,r = divrem(a,b) pushPS(r) pushPS(q) - return NEXT + return mem[NEXT] +end) + +EQU = defPrim("=", () -> begin + b = popPS() + a = popPS() + pushPS(a==b ? -1 : 0) + return mem[NEXT] +end) + +NEQU = defPrim("<>", () -> begin + b = popPS() + a = popPS() + pushPS(a!=b ? -1 : 0) + return mem[NEXT] end) +LT = defPrim("<", () -> begin + b = popPS() + a = popPS() + pushPS(a", () -> begin + b = popPS() + a = popPS() + pushPS(a>b ? -1 : 0) + return mem[NEXT] +end) + +LE = defPrim("<=", () -> begin + b = popPS() + a = popPS() + pushPS(a<=b ? -1 : 0) + return mem[NEXT] +end) + +GE = defPrim(">=", () -> begin + b = popPS() + a = popPS() + pushPS(a>=b ? -1 : 0) + return mem[NEXT] +end) + +ZEQU = defPrim("0=", () -> begin + pushPS(popPS() == 0 ? -1 : 0) + return mem[NEXT] +end) + +ZNEQU = defPrim("0<>", () -> begin + pushPS(popPS() != 0 ? -1 : 0) + return mem[NEXT] +end) + +ZLT = defPrim("0<", () -> begin + pushPS(popPS() < 0 ? -1 : 0) + return mem[NEXT] +end) + +ZGT = defPrim("0>", () -> begin + pushPS(popPS() > 0 ? -1 : 0) + return mem[NEXT] +end) + +ZLE = defPrim("0<=", () -> begin + pushPS(popPS() <= 0 ? -1 : 0) + return mem[NEXT] +end) + +ZGE = defPrim("0>=", () -> begin + pushPS(popPS() >= 0 ? -1 : 0) + return mem[NEXT] +end) + +AND = defPrim("AND", () -> begin + b = popPS() + a = popPS() + pushPS(a & b) + return mem[NEXT] +end) + +OR = defPrim("OR", () -> begin + b = popPS() + a = popPS() + pushPS(a | b) + return mem[NEXT] +end) + +XOR = defPrim("XOR", () -> begin + b = popPS() + a = popPS() + pushPS(a $ b) + return mem[NEXT] +end) + +INVERT = defPrim("INVERT", () -> begin + pushPS(~popPS()) + return mem[NEXT] +end) + +# Literals + LIT = defPrim("LIT", () -> begin pushPS(mem[reg.IP]) reg.IP += 1 - return NEXT + return mem[NEXT] end) # Memory primitives @@ -327,38 +449,38 @@ STORE = defPrim("!", () -> begin addr = popPS() dat = popPS() mem[addr] = dat - return NEXT + return mem[NEXT] end) FETCH = defPrim("@", () -> begin addr = popPS() pushPS(mem[addr]) - return NEXT + return mem[NEXT] end) ADDSTORE = defPrim("+!", () -> begin addr = popPS() toAdd = popPS() mem[addr] += toAdd - return NEXT + return mem[NEXT] end) SUBSTORE = defPrim("-!", () -> begin addr = popPS() toSub = popPS() mem[addr] -= toSub - return NEXT + return mem[NEXT] end) # Built-in variables -defExistingVar("HERE", HERE) -defExistingVar("LATEST", LATEST) -defExistingVar("PSP0", PSP0) -defExistingVar("RSP0", RSP0) -STATE = defNewVar("STATE", 0) -BASE = defNewVar("BASE", 10) +HERE_CFA = defExistingVar("HERE", HERE) +LATEST_CFA = defExistingVar("LATEST", LATEST) +PSP0_CFA = defExistingVar("PSP0", PSP0) +RSP0_CFA = defExistingVar("RSP0", RSP0) +STATE, STATE_CFA = defNewVar("STATE", 0) +BASE, BASE_CFA = defNewVar("BASE", 10) # Constants @@ -373,64 +495,64 @@ F_LENMASK = defConst("F_LENMASK", 127) TOR = defPrim(">R", () -> begin pushRS(popPS()) - return NEXT + return mem[NEXT] end) FROMR = defPrim("R>", () -> begin pushPS(popRS()) - return NEXT + return mem[NEXT] end) RSPFETCH = defPrim("RSP@", () -> begin pushPS(reg.RSP) - return NEXT + return mem[NEXT] end) RSPSTORE = defPrim("RSP!", () -> begin RSP = popPS() - return NEXT + return mem[NEXT] end) RDROP = defPrim("RDROP", () -> begin popRS() - return NEXT + return mem[NEXT] end) # Parameter Stack PSPFETCH = defPrim("PSP@", () -> begin pushPS(reg.PSP) - return NEXT + return mem[NEXT] end) PSPSTORE = defPrim("PSP!", () -> begin PSP = popPS() - return NEXT + return mem[NEXT] end) # I/O defConst("TIB", TIB) -NUMTIB = defNewVar("#TIB", 0) -TOIN = defNewVar(">IN", 0) +NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0) +TOIN, TOIN_CFA = defNewVar(">IN", 0) KEY = defPrim("KEY", () -> begin if mem[TOIN] >= mem[NUMTIB] mem[TOIN] = 0 line = readline() mem[NUMTIB] = length(line) - mem[TIB:(TIB+mem[NUMTIB]-1)] = [Int64(c) for c in collect(line)] + putString(line, TIB) end pushPS(mem[TIB + mem[TOIN]]) mem[TOIN] += 1 - return NEXT + return mem[NEXT] end) EMIT = defPrim("EMIT", () -> begin print(Char(popPS())) - return NEXT + return mem[NEXT] end) WORD = defPrim("WORD", () -> begin @@ -440,7 +562,7 @@ WORD = defPrim("WORD", () -> begin skip_to_end = false while true - callPrim(KEY) + callPrim(mem[KEY]) c = Char(popPS()) if c == '\\' @@ -465,14 +587,25 @@ WORD = defPrim("WORD", () -> begin wordAddr = mem[HERE] offset = 0 + if c == '\n' + # Treat newline as a special word + + mem[wordAddr + offset] = Int64(c) + pushPS(wordAddr) + pushPS(1) + return mem[NEXT] + end + while true mem[wordAddr + offset] = Int64(c) offset += 1 - callPrim(KEY) + callPrim(mem[KEY]) c = Char(popPS()) if c == ' ' || c == '\t' || c == '\n' + # Rewind KEY + mem[TOIN] -= 1 break end end @@ -482,7 +615,7 @@ WORD = defPrim("WORD", () -> begin pushPS(wordAddr) pushPS(wordLen) - return NEXT + return mem[NEXT] end) NUMBER = defPrim("NUMBER", () -> begin @@ -490,7 +623,7 @@ NUMBER = defPrim("NUMBER", () -> begin wordLen = popPS() wordAddr = popPS() - s = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]]) + s = getString(wordAddr, wordLen) try pushPS(parse(Int64, s, mem[BASE])) @@ -499,7 +632,7 @@ NUMBER = defPrim("NUMBER", () -> begin pushPS(1) # Error indication end - return NEXT + return mem[NEXT] end) # Dictionary searches @@ -508,31 +641,31 @@ FIND = defPrim("FIND", () -> begin wordLen = popPS() wordAddr = popPS() - word = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]]) + word = lowercase(getString(wordAddr, wordLen)) - latest = mem[LATEST] + latest = LATEST - while latest>0 + i = 0 + while (latest = mem[latest]) > 0 lenAndFlags = mem[latest+1] len = lenAndFlags & F_LENMASK hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN if hidden || len != wordLen - latest = mem[latest] continue end thisAddr = latest+2 - thisWord = ASCIIString([Char(c) for c in mem[thisAddr:(thisAddr+len-1)]]) + thisWord = lowercase(getString(thisAddr, len)) - if thisWord == word + if lowercase(thisWord) == lowercase(word) break end end pushPS(latest) - return NEXT + return mem[NEXT] end) TOCFA = defPrim(">CFA", () -> begin @@ -543,39 +676,247 @@ TOCFA = defPrim(">CFA", () -> begin pushPS(addr + 2 + len) - return NEXT + return mem[NEXT] end) TODFA = defWord(">DFA", [TOCFA, INCR, EXIT]) +# Compilation + +CREATE = defPrim("CREATE", () -> begin + + wordLen = popPS() + wordAddr = popPS() + word = getString(wordAddr, wordLen) + + createHeader(word, 0) + + return mem[NEXT] +end) + +COMMA = defPrim(",", () -> begin + mem[mem[HERE]] = popPS() + mem[HERE] += 1 + + return mem[NEXT] +end) + +LBRAC = defPrim("[", () -> begin + mem[STATE] = 0 + return mem[NEXT] +end, flags=F_IMMED) + +RBRAC = defPrim("]", () -> begin + mem[STATE] = 1 + return mem[NEXT] +end, flags=F_IMMED) + +HIDDEN = defPrim("HIDDEN", () -> begin + addr = popPS() + 1 + mem[addr] = mem[addr] $ F_HIDDEN + return mem[NEXT] +end) + +HIDE = defWord("HIDE", + [WORD, + FIND, + HIDDEN, + EXIT]) + +COLON = defWord(":", + [WORD, + CREATE, + LIT, DOCOL, COMMA, + LATEST, FETCH, HIDDEN, + RBRAC, + EXIT]) + +SEMICOLON = defWord(";", + [LIT, EXIT, COMMA, + LATEST, FETCH, HIDDEN, + LBRAC, + EXIT], flags=F_IMMED) + +IMMEDIATE = defPrim("IMMEDIATE", () -> begin + lenAndFlagsAddr = mem[LATEST] + 1 + mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED + return mem[NEXT] +end, flags=F_IMMED) + +TICK = defWord("'", [WORD, FIND, TOCFA, EXIT]) + +# Branching + +BRANCH = defPrim("BRANCH", () -> begin + reg.IP += mem[reg.IP] + return mem[NEXT] +end) + +ZBRANCH = defPrim("0BRANCH", () -> begin + if (popPS() == 0) + reg.IP += mem[reg.IP] + else + reg.IP += 1 + end + + return mem[NEXT] +end) + +# Strings + +LITSTRING = defPrim("LITSTRING", () -> begin + len = mem[reg.IP] + reg.IP += 1 + pushPS(reg.IP) + pushPS(len) + reg.IP += len + + return mem[NEXT] +end) + +TELL = defPrim("TELL", () -> begin + len = popPS() + addr = popPS() + str = getString(addr, len) + print(str) + return mem[NEXT] +end) + +# Outer interpreter + +INTERPRET = defPrim("INTERPRET", () -> begin + + callPrim(mem[WORD]) + + wordName = getString(mem[reg.PSP-1], mem[reg.PSP]) + println("... ", replace(wordName, "\n", "\\n"), " ...") + + callPrim(mem[TWODUP]) + callPrim(mem[FIND]) + + wordAddr = mem[reg.PSP] + + + if wordAddr>0 + # Word in dictionary + + isImmediate = (mem[wordAddr+1] & F_IMMED) != 0 + callPrim(mem[TOCFA]) + + callPrim(mem[ROT]) # get rid of extra copy of word string details + popPS() + popPS() + + if mem[STATE] == 0 || isImmediate + # Execute! + return mem[popPS()] + else + # Append CFA to dictionary + callPrim(mem[COMMA]) + end + else + # Not in dictionary, assume number + + popPS() + + callPrim(mem[NUMBER]) + + if popPS() != 0 + println("Parse error at word: '$wordName'") + return mem[NEXT] + else + end + + if mem[STATE] == 0 + # Number already on stack! + else + # Append literal to dictionary + pushPS(LIT) + callPrim(mem[COMMA]) + callPrim(mem[COMMA]) + end + end + + return mem[NEXT] +end) + +QUIT = defWord("QUIT", + [RSP0_CFA, RSPSTORE, + INTERPRET, + BRANCH,-2]) + +NL = defPrim("\n", () -> begin + if mem[STATE] == 0 + println(" ok") + end + return mem[NEXT] +end) + +# Odds and Ends + +CHAR = defPrim("CHAR", () -> begin + callPrim(mem[WORD]) + wordLen = popPS() + wordAddr = popPS() + word = getString(wordAddr, wordLen) + pushPS(Int64(word[1])) + + return mem[NEXT] +end) + +EXECUTE = defPrim("EXECUTE", () -> begin + return mem[popPS()] +end) + +BYE = defPrim("BYE", () -> begin + return 0 +end) + #### VM loop #### function runVM() - jmp = NEXT - while (jmp = callPrim(jmp)) != 0 end + # Start with IP pointing to first instruction of outer interpreter + reg.IP = QUIT + 1 + + # Primitive processing loop. + # Everyting else is simply a consequence of this loop! + jmp = mem[NEXT] + while (jmp = callPrim(jmp)) != 0 + println("Evaluating prim $jmp [$(primNames[-jmp])]") + end end # Debugging tools -function coredump(startAddr::Int64; count::Int64 = 16, cellsPerLine::Int64 = 8) +function dump(startAddr::Int64; count::Int64 = 100, cellsPerLine::Int64 = 10) chars = Array{Char,1}(cellsPerLine) - for i in 0:(count-1) - addr = startAddr + i - if i%cellsPerLine == 0 - print("$addr:") - end - - print("\t$(mem[addr]) ") + lineStartAddr = cellsPerLine*div((startAddr-1),cellsPerLine) + 1 + endAddr = startAddr + count - 1 + + q, r = divrem((endAddr-lineStartAddr+1), cellsPerLine) + numLines = q + (r > 0 ? 1 : 0) + + i = lineStartAddr + for l in 1:numLines + print(i,":") + + for c in 1:cellsPerLine + if i >= startAddr && i <= endAddr + print("\t",mem[i]) + if mem[i]>=32 && mem[i]<128 + chars[c] = Char(mem[i]) + else + chars[c] = '.' + end + else + print("\t") + chars[c] = ' ' + end - if (mem[addr]>=32 && mem[addr]<176) - chars[i%cellsPerLine + 1] = Char(mem[addr]) - else - chars[i%cellsPerLine + 1] = '.' + i += 1 end - if i%cellsPerLine == cellsPerLine-1 - println(string("\t", ASCIIString(chars))) - end + println("\t", ASCIIString(chars)) end end @@ -593,4 +934,18 @@ function printPS() end end +function printRS() + count = reg.RSP - mem[RSP0] + + if count > 0 + print("<$count>") + for i in (mem[RSP0]+1):reg.RSP + print(" $(mem[i])") + end + println() + else + println("Return stack empty") + end +end + end