X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fforth.jl;h=766bd4e1cdf2f3ff24685ab186a75188103f8202;hb=4b2f52917ce00e4af92d2a3a86e199d21748da5b;hp=a3c55f04309c2b07b4d622b2638c78747a1d8c25;hpb=892ce90d5c9975c154800002ddfcb6d7c82910a0;p=forth.jl.git diff --git a/src/forth.jl b/src/forth.jl index a3c55f0..766bd4e 100644 --- a/src/forth.jl +++ b/src/forth.jl @@ -1,12 +1,12 @@ module forth # VM mem size -size_mem = 640*1024 +size_mem = 1000000 # 1 mega-int # Buffer sizes -size_RS = 1024 # Return stack size -size_PS = 1024 # Parameter stack size -size_TIB = 1096 # Terminal input buffer size +size_RS = 1000 # Return stack size +size_PS = 1000 # Parameter stack size +size_TIB = 1000 # Terminal input buffer size # The mem array constitutes the memory of the VM. It has the following geography: # @@ -55,27 +55,29 @@ type Reg PSP::Int64 # Parameter/data stack pointer IP::Int64 # Instruction pointer W::Int64 # Working register - - source::Any # Input stream in use end -reg = Reg(mem[RSP0], mem[PSP0], 0, 0, STDIN) +reg = Reg(mem[RSP0], mem[PSP0], 0, 0) # Stack manipulation functions -type StackUnderflow <: Exception end +type ParamStackUnderflow <: Exception end +type ReturnStackUnderflow <: Exception end + +Base.showerror(io::IO, ex::ParamStackUnderflow) = print(io, "Parameter stack underflow.") +Base.showerror(io::IO, ex::ReturnStackUnderflow) = print(io, "Return stack underflow.") getRSDepth() = reg.RSP - mem[RSP0] getPSDepth() = reg.PSP - mem[PSP0] function ensurePSDepth(depth::Int64) if getPSDepth()=0 || -addr>length(primitives) + error("Attempted to execute non-existent primitive at address $addr.") + else + primitives[-addr]() + end +end +getPrimName(addr::Int64) = primNames[-addr] -# Word creation +# Word creation functions + +F_IMMED = 128 +F_HIDDEN = 256 +F_LENMASK = 127 function createHeader(name::AbstractString, flags::Int64) mem[mem[HERE]] = mem[LATEST] @@ -157,7 +170,7 @@ function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0 return addr end -# Variable creation +# Variable creation functions function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0) @@ -173,24 +186,21 @@ function defNewVar(name::AbstractString, initial::Int64; flags::Int64=0) codeWordAddr = mem[HERE] varAddr = mem[HERE] + 1 - f = eval(:(() -> begin - pushPS($(varAddr)) - return NEXT - end)) - - mem[mem[HERE]] = defPrim(f, name=name); mem[HERE] += 1 + mem[mem[HERE]] = DOVAR; mem[HERE] += 1 mem[mem[HERE]] = initial; mem[HERE] += 1 return varAddr, codeWordAddr end function defConst(name::AbstractString, val::Int64; flags::Int64=0) - defPrimWord(name, eval(:(() -> begin - pushPS($(val)) - return NEXT - end))) + createHeader(name, flags) - return val + codeWordAddr = mem[HERE] + + mem[mem[HERE]] = DOCON; mem[HERE] += 1 + mem[mem[HERE]] = val; mem[HERE] += 1 + + return codeWordAddr end # Threading Primitives (inner interpreter) @@ -207,11 +217,39 @@ DOCOL = defPrim(() -> begin return NEXT end, name="DOCOL") +DOVAR = defPrim(() -> begin + pushPS(reg.W + 1) + return NEXT +end, name="DOVAR") + +DOCON = defPrim(() -> begin + pushPS(mem[reg.W + 1]) + return NEXT +end, name="DOVAR") + EXIT = defPrimWord("EXIT", () -> begin reg.IP = popRS() return NEXT end) +# Dictionary entries for core built-in variables, constants + +HERE_CFA = defExistingVar("HERE", HERE) +LATEST_CFA = defExistingVar("LATEST", LATEST) +PSP0_CFA = defExistingVar("PSP0", PSP0) +RSP0_CFA = defExistingVar("RSP0", RSP0) + +defConst("DOCOL", DOCOL) +defConst("DOCON", DOCON) +defConst("DOVAR", DOVAR) + +defConst("DICT", DICT) +defConst("MEMSIZE", size_mem) + +F_IMMED_CFA = defConst("F_IMMED", F_IMMED) +F_HIDDEN_CFA = defConst("F_HIDDEN", F_HIDDEN) +F_LENMASK_CFA = defConst("F_LENMASK", F_LENMASK) + # Basic forth primitives DROP = defPrimWord("DROP", () -> begin @@ -228,6 +266,7 @@ SWAP = defPrimWord("SWAP", () -> begin end) DUP = defPrimWord("DUP", () -> begin + ensurePSDepth(1) pushPS(mem[reg.PSP]) return NEXT end) @@ -242,9 +281,9 @@ ROT = defPrimWord("ROT", () -> begin a = popPS() b = popPS() c = popPS() + pushPS(b) pushPS(a) pushPS(c) - pushPS(b) return NEXT end) @@ -252,12 +291,13 @@ NROT = defPrimWord("-ROT", () -> begin a = popPS() b = popPS() c = popPS() - pushPS(b) pushPS(a) pushPS(c) + pushPS(b) return NEXT end) + TWODROP = defPrimWord("2DROP", () -> begin popPS() popPS() @@ -280,8 +320,17 @@ TWOSWAP = defPrimWord("2SWAP", () -> begin d = popPS() pushPS(b) pushPS(a) - pushPS(c) pushPS(d) + pushPS(c) + return NEXT +end) + +TWOOVER = defPrimWord("2OVER", () -> begin + ensurePSDepth(4) + a = mem[reg.PSP-3] + b = mem[reg.PSP-2] + pushPS(a) + pushPS(b) return NEXT end) @@ -348,14 +397,24 @@ DIVMOD = defPrimWord("/MOD", () -> begin return NEXT end) -EQU = defPrimWord("=", () -> begin +TWOMUL = defPrimWord("2*", () -> begin + pushPS(popPS() << 1) + return NEXT +end) + +TWODIV = defPrimWord("2/", () -> begin + pushPS(popPS() >> 1) + return NEXT +end) + +EQ = defPrimWord("=", () -> begin b = popPS() a = popPS() pushPS(a==b ? -1 : 0) return NEXT end) -NEQU = defPrimWord("<>", () -> begin +NE = defPrimWord("<>", () -> begin b = popPS() a = popPS() pushPS(a!=b ? -1 : 0) @@ -390,12 +449,12 @@ GE = defPrimWord(">=", () -> begin return NEXT end) -ZEQU = defPrimWord("0=", () -> begin +ZE = defPrimWord("0=", () -> begin pushPS(popPS() == 0 ? -1 : 0) return NEXT end) -ZNEQU = defPrimWord("0<>", () -> begin +ZNE = defPrimWord("0<>", () -> begin pushPS(popPS() != 0 ? -1 : 0) return NEXT end) @@ -484,24 +543,6 @@ SUBSTORE = defPrimWord("-!", () -> begin end) -# Built-in variables - -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 - -defConst("VERSION", 1) -defConst("DOCOL", DOCOL) -defConst("DICT", DICT) -F_IMMED = defConst("F_IMMED", 128) -F_HIDDEN = defConst("F_HIDDEN", 256) -F_LENMASK = defConst("F_LENMASK", 127) - # Return Stack TOR = defPrimWord(">R", () -> begin @@ -514,6 +555,11 @@ FROMR = defPrimWord("R>", () -> begin return NEXT end) +RFETCH = defPrimWord("R@", () -> begin + pushPS(mem[reg.RSP]) + return NEXT +end) + RSPFETCH = defPrimWord("RSP@", () -> begin pushPS(reg.RSP) return NEXT @@ -555,110 +601,41 @@ end) # I/O -defConst("TIB", TIB) -NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0) -TOIN, TOIN_CFA = defNewVar(">IN", 0) - -KEY = defPrimWord("KEY", () -> begin - if mem[TOIN] >= mem[NUMTIB] - mem[TOIN] = 0 - - if reg.source != STDIN && eof(reg.source) - reg.source = STDIN - end - - line = readline(reg.source) - mem[NUMTIB] = length(line) - putString(line, TIB) - end +sources = Array{Any,1}() +currentSource() = sources[length(sources)] - pushPS(mem[TIB + mem[TOIN]]) - mem[TOIN] += 1 - - return NEXT -end) +EOF_CFA = defConst("EOF", 4) EMIT = defPrimWord("EMIT", () -> begin print(Char(popPS())) return NEXT end) -WORD = defPrimWord("WORD", () -> begin - - c = -1 - - skip_to_end = false - while true - - callPrim(mem[KEY]) - c = Char(popPS()) - - if c == '\\' - skip_to_end = true - continue - end - - if skip_to_end - if c == '\n' - skip_to_end = false - end - continue - end - - if c == ' ' || c == '\t' - continue - end - - break - end - - wordAddr = mem[HERE] - offset = 0 - - if c == '\n' - # Treat newline as a special word - - mem[wordAddr + offset] = Int64(c) - pushPS(wordAddr) - pushPS(1) - return NEXT - end - - while true - mem[wordAddr + offset] = Int64(c) - offset += 1 - - callPrim(mem[KEY]) - c = Char(popPS()) +SPAN, SPAN_CFA = defNewVar("SPAN", 0) +EXPECT = defPrimWord("EXPECT", () -> begin + maxLen = popPS() + addr = popPS() - if c == ' ' || c == '\t' || c == '\n' - # Rewind KEY - mem[TOIN] -= 1 - break - end + if !eof(currentSource()) + line = chomp(readline(currentSource())) + mem[SPAN] = min(length(line), maxLen) + putString(line[1:mem[SPAN]], addr) + else + mem[SPAN] = 1 + mem[addr] = EOF end - wordLen = offset - - pushPS(wordAddr) - pushPS(wordLen) - return NEXT end) +BASE, BASE_CFA = defNewVar("BASE", 10) NUMBER = defPrimWord("NUMBER", () -> begin - - wordLen = popPS() - wordAddr = popPS() + wordAddr = popPS()+1 + wordLen = mem[wordAddr-1] s = getString(wordAddr, wordLen) - try - pushPS(parse(Int64, s, mem[BASE])) - pushPS(0) - catch - pushPS(1) # Error indication - end + pushPS(parse(Int64, s, mem[BASE])) return NEXT end) @@ -667,8 +644,9 @@ end) FIND = defPrimWord("FIND", () -> begin - wordLen = popPS() - wordAddr = popPS() + countedAddr = popPS() + wordAddr = countedAddr + 1 + wordLen = mem[countedAddr] word = lowercase(getString(wordAddr, wordLen)) latest = LATEST @@ -707,71 +685,7 @@ TOCFA = defPrimWord(">CFA", () -> begin return NEXT end) -TODFA = defWord(">DFA", [TOCFA, INCR, EXIT]) - -# Compilation - -CREATE = defPrimWord("CREATE", () -> begin - - wordLen = popPS() - wordAddr = popPS() - word = getString(wordAddr, wordLen) - - createHeader(word, 0) - - return NEXT -end) - -COMMA = defPrimWord(",", () -> begin - mem[mem[HERE]] = popPS() - mem[HERE] += 1 - - return NEXT -end) - -LBRAC = defPrimWord("[", () -> begin - mem[STATE] = 0 - return NEXT -end, flags=F_IMMED) - -RBRAC = defPrimWord("]", () -> begin - mem[STATE] = 1 - return NEXT -end, flags=F_IMMED) - -HIDDEN = defPrimWord("HIDDEN", () -> begin - addr = popPS() + 1 - mem[addr] = mem[addr] $ F_HIDDEN - return NEXT -end) - -HIDE = defWord("HIDE", - [WORD, - FIND, - HIDDEN, - EXIT]) - -COLON = defWord(":", - [WORD, - CREATE, - LIT, DOCOL, COMMA, - LATEST_CFA, FETCH, HIDDEN, - RBRAC, - EXIT]) - -SEMICOLON = defWord(";", - [LIT, EXIT, COMMA, - LATEST_CFA, FETCH, HIDDEN, - LBRAC, - EXIT], flags=F_IMMED) - -IMMEDIATE = defPrimWord("IMMEDIATE", () -> begin - lenAndFlagsAddr = mem[LATEST] + 1 - mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED - return NEXT -end, flags=F_IMMED) - -TICK = defWord("'", [WORD, FIND, TOCFA, EXIT]) +TOPFA = defWord(">PFA", [TOCFA, INCR, EXIT]) # Branching @@ -802,7 +716,7 @@ LITSTRING = defPrimWord("LITSTRING", () -> begin return NEXT end) -TELL = defPrimWord("TELL", () -> begin +TYPE = defPrimWord("TYPE", () -> begin len = popPS() addr = popPS() str = getString(addr, len) @@ -812,121 +726,279 @@ end) # Outer interpreter +TRACE = defPrimWord("TRACE", () -> begin + println("reg.W: $(reg.W) reg.IP: $(reg.IP)") + print("PS: "); printPS() + print("RS: "); printRS() + print("[paused]") + readline() + + return NEXT +end) + +COMMA = defPrimWord(",", () -> begin + mem[mem[HERE]] = popPS() + mem[HERE] += 1 + + return NEXT +end) + +BTICK = defWord("[']", + [FROMR, DUP, INCR, TOR, FETCH, EXIT]) + EXECUTE = defPrimWord("EXECUTE", () -> begin reg.W = popPS() return mem[reg.W] end) -INTERPRET = defPrimWord("INTERPRET", () -> begin +TIB_CFA = defConst("TIB", TIB) +NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0) +TOIN, TOIN_CFA = defNewVar(">IN", 0) + +QUERY = defWord("QUERY", + [TIB_CFA, LIT, 80, EXPECT, + SPAN_CFA, FETCH, NUMTIB_CFA, STORE, + LIT, 0, TOIN_CFA, STORE, + EXIT]) - callPrim(mem[WORD]) +WORD = defPrimWord("WORD", () -> begin + delim = popPS() - wordName = getString(mem[reg.PSP-1], mem[reg.PSP]) - #println("... ", replace(wordName, "\n", "\\n"), " ...") + # Chew up initial occurrences of delim + while (mem[TOIN]0 - # Word in dictionary + if (mem[addr] == delim) + break + end - isImmediate = (mem[wordAddr+1] & F_IMMED) != 0 - callPrim(mem[TOCFA]) + count += 1 + addr += 1 + end - callPrim(mem[ROT]) # get rid of extra copy of word string details - popPS() - popPS() + # Record count + mem[countAddr] = count + pushPS(countAddr) - if mem[STATE] == 0 || isImmediate - # Execute! - #println("Executing CFA at $(mem[reg.PSP])") - return callPrim(mem[EXECUTE]) - else - # Append CFA to dictionary - callPrim(mem[COMMA]) - end - else - # Not in dictionary, assume number + return NEXT +end) - popPS() +PARSE = defPrimWord("PARSE", () -> begin + delim = popPS() - callPrim(mem[NUMBER]) + # Chew up initial occurrences of delim + addr = mem[HERE] - if popPS() != 0 - println("Parse error at word: '$wordName'") - return NEXT - end + # Start reading input stream + count = 0 + while (mem[TOIN] begin + println("Bye!") return 0 end) -NL = defPrimWord("\n", () -> begin - if mem[STATE] == 0 +STATE, STATE_CFA = defNewVar("STATE", 0) + +INTERPRET = defWord("INTERPRET", + [LIT, 32, WORD, # Read next space-delimited word + + DUP, FETCH, ZE, ZBRANCH, 3, + DROP, EXIT, # Exit if TIB is exhausted + + STATE_CFA, FETCH, ZBRANCH, 31, + # Compiling + DUP, FIND, QDUP, ZBRANCH, 19, + + # Found word. + SWAP, DROP, + DUP, TOCFA, SWAP, INCR, FETCH, LIT, F_IMMED, AND, ZBRANCH, 4, + # Immediate: Execute! + EXECUTE, BRANCH, -33, + + # Not immediate: Compile! + COMMA, BRANCH, -36, + + # No word found, parse number + NUMBER, BTICK, LIT, COMMA, COMMA, BRANCH, -43, + + # Interpreting + DUP, FIND, QDUP, ZBRANCH, 7, + + # Found word. Execute! + SWAP, DROP, TOCFA, EXECUTE, BRANCH, -54, + + # No word found, parse number and leave on stack + NUMBER, BRANCH, -57, + EXIT] +) + +PROMPT = defPrimWord("PROMPT", () -> begin + if (mem[STATE] == 0 && currentSource() == STDIN) println(" ok") end + return NEXT -end, flags=F_IMMED) +end) -# Odds and Ends +QUIT = defWord("QUIT", + [RSP0_CFA, RSPSTORE, + QUERY, + INTERPRET, PROMPT, + BRANCH,-4]) -CHAR = defPrimWord("CHAR", () -> begin +INCLUDE = defPrimWord("INCLUDE", () -> begin + pushPS(32) callPrim(mem[WORD]) - wordLen = popPS() - wordAddr = popPS() + wordAddr = popPS()+1 + wordLen = mem[wordAddr-1] word = getString(wordAddr, wordLen) - pushPS(Int64(word[1])) + + push!(sources, open(word, "r")) + + # Clear input buffer + mem[NUMTIB] = 0 return NEXT end) -INCLUDE = defPrimWord("INCLUDE", () -> begin +# Compilation - callPrim(mem[WORD]) - wordLen = popPS() - wordAddr = popPS() +HEADER = defPrimWord("HEADER", () -> begin + wordAddr = popPS()+1 + wordLen = mem[wordAddr-1] word = getString(wordAddr, wordLen) - println("Reading from $word...") + createHeader(word, 0) - reg.source = open(word, "r") + return NEXT +end) - # Clear input buffer - mem[NUMTIB] = 0 +LBRAC = defPrimWord("[", () -> begin + mem[STATE] = 0 + return NEXT +end, flags=F_IMMED) +RBRAC = defPrimWord("]", () -> begin + mem[STATE] = 1 + return NEXT +end, flags=F_IMMED) + +HIDDEN = defPrimWord("HIDDEN", () -> begin + addr = popPS() + 1 + mem[addr] = mem[addr] $ F_HIDDEN return NEXT end) +HIDE = defWord("HIDE", + [LIT, 32, WORD, + FIND, + HIDDEN, + EXIT]) + +COLON = defWord(":", + [LIT, 32, WORD, + HEADER, + LIT, DOCOL, COMMA, + LATEST_CFA, FETCH, HIDDEN, + RBRAC, + EXIT]) + +SEMICOLON = defWord(";", + [LIT, EXIT, COMMA, + LATEST_CFA, FETCH, HIDDEN, + LBRAC, + EXIT], flags=F_IMMED) + +IMMEDIATE = defPrimWord("IMMEDIATE", () -> begin + lenAndFlagsAddr = mem[LATEST] + 1 + mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED + return NEXT +end, flags=F_IMMED) + + #### VM loop #### -function run() + +initialized = false +initFileName = nothing +if isfile("lib.4th") + initFileName = "lib.4th" +elseif isfile(Pkg.dir("forth/src/lib.4th")) + initFileName = Pkg.dir("forth/src/lib.4th") +end + +function run(;initialize=true) + # Begin with STDIN as source + push!(sources, STDIN) + + global initialized, initFileName + if !initialized && initialize + if initFileName != nothing + print("Including definitions from $initFileName...") + push!(sources, open(initFileName, "r")) + initialized = true + else + println("No library file found. Only primitive words available.") + end + 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 = NEXT - while (jmp = callPrim(jmp)) != 0 - #println("Evaluating prim $jmp [$(primNames[-jmp])]") + while jmp != 0 + try + #println("Entering prim $(getPrimName(jmp))") + jmp = callPrim(jmp) + + catch ex + showerror(STDOUT, ex) + println() + + while !isempty(sources) && currentSource() != STDIN + close(pop!(sources)) + end + + # Want backtrace in here eventually + println("reg.W: $(reg.W) reg.IP: $(reg.IP)") + print("PS: "); printPS() + print("RS: "); printRS() + + mem[STATE] = 0 + mem[NUMTIB] = 0 + reg.PSP = mem[PSP0] + reg.RSP = mem[RSP0] + reg.IP = QUIT + 1 + jmp = NEXT + end end end @@ -993,4 +1065,13 @@ function printRS() end end +DUMP = defPrimWord("DUMP", () -> begin + count = popPS() + addr = popPS() + + dump(addr, count=count) + + return NEXT +end) + end