X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fforth.jl;h=e571758f6d76254f7c5f70f023cbe6afa95fc7c2;hb=7cc4407fe0b3da1af97f444bb03d874e868a7152;hp=5ced825bc66efa788a37fa18c3203bcbd02c517e;hpb=17a6eb2756a624fc2274b601c20977f3bc014a6e;p=forth.jl.git diff --git a/src/forth.jl b/src/forth.jl index 5ced825..e571758 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: # @@ -26,8 +26,8 @@ size_TIB = 1096 # Terminal input buffer size # the dictionary. # # Simple linear addressing is used with one exception: references to primitive code -# blocks, which are represented as anonymous functions, appear the negative index -# into the primitives array which contains only these functions. +# blocks, which are represented as anonymous functions, appear as negative indicies +# into the primitives array which contains these functions. mem = Array{Int64,1}(size_mem) primitives = Array{Function,1}() @@ -58,22 +58,26 @@ type Reg end reg = Reg(mem[RSP0], mem[PSP0], 0, 0) -# Stack manipulation +# 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() 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) + + mem[mem[HERE]] = DOCON; mem[HERE] += 1 + mem[mem[HERE]] = val; mem[HERE] += 1 return val end @@ -205,11 +204,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 = defConst("F_IMMED", 128) +F_HIDDEN = defConst("F_HIDDEN", 256) +F_LENMASK = defConst("F_LENMASK", 127) + # Basic forth primitives DROP = defPrimWord("DROP", () -> begin @@ -226,6 +253,7 @@ SWAP = defPrimWord("SWAP", () -> begin end) DUP = defPrimWord("DUP", () -> begin + ensurePSDepth(1) pushPS(mem[reg.PSP]) return NEXT end) @@ -240,9 +268,9 @@ ROT = defPrimWord("ROT", () -> begin a = popPS() b = popPS() c = popPS() + pushPS(b) pushPS(a) pushPS(c) - pushPS(b) return NEXT end) @@ -250,12 +278,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() @@ -278,8 +307,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) @@ -346,6 +384,16 @@ DIVMOD = defPrimWord("/MOD", () -> begin return NEXT end) +TWOMUL = defPrimWord("2*", () -> begin + pushPS(popPS() << 1) + return NEXT +end) + +TWODIV = defPrimWord("2/", () -> begin + pushPS(popPS() >> 1) + return NEXT +end) + EQU = defPrimWord("=", () -> begin b = popPS() a = popPS() @@ -482,24 +530,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 @@ -512,6 +542,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 @@ -553,16 +588,26 @@ end) # I/O +sources = Array{Any,1}() +currentSource() = sources[length(sources)] + defConst("TIB", TIB) NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0) TOIN, TOIN_CFA = defNewVar(">IN", 0) +EOF = defConst("EOF", 4) KEY = defPrimWord("KEY", () -> begin if mem[TOIN] >= mem[NUMTIB] mem[TOIN] = 0 - line = readline() - mem[NUMTIB] = length(line) - putString(line, TIB) + + if !eof(currentSource()) + line = readline(currentSource()) + mem[NUMTIB] = length(line) + putString(line, TIB) + else + mem[NUMTIB] = 1 + mem[TIB] = EOF + end end pushPS(mem[TIB + mem[TOIN]]) @@ -577,8 +622,9 @@ EMIT = defPrimWord("EMIT", () -> begin end) WORD = defPrimWord("WORD", () -> begin - - c = -1 + + eof_char = Char(EOF) + c = eof_char skip_to_end = false while true @@ -592,7 +638,7 @@ WORD = defPrimWord("WORD", () -> begin end if skip_to_end - if c == '\n' + if c == '\n' || c == eof_char skip_to_end = false end continue @@ -608,7 +654,7 @@ WORD = defPrimWord("WORD", () -> begin wordAddr = mem[HERE] offset = 0 - if c == '\n' + if c == '\n' || c == eof_char # Treat newline as a special word mem[wordAddr + offset] = Int64(c) @@ -624,7 +670,7 @@ WORD = defPrimWord("WORD", () -> begin callPrim(mem[KEY]) c = Char(popPS()) - if c == ' ' || c == '\t' || c == '\n' + if c == ' ' || c == '\t' || c == '\n' || c == eof_char # Rewind KEY mem[TOIN] -= 1 break @@ -639,6 +685,7 @@ WORD = defPrimWord("WORD", () -> begin return NEXT end) +BASE, BASE_CFA = defNewVar("BASE", 10) NUMBER = defPrimWord("NUMBER", () -> begin wordLen = popPS() @@ -702,9 +749,28 @@ end) TODFA = defWord(">DFA", [TOCFA, INCR, EXIT]) +# Branching + +BRANCH = defPrimWord("BRANCH", () -> begin + reg.IP += mem[reg.IP] + return NEXT +end) + +ZBRANCH = defPrimWord("0BRANCH", () -> begin + if (popPS() == 0) + reg.IP += mem[reg.IP] + else + reg.IP += 1 + end + + return NEXT +end) + # Compilation -CREATE = defPrimWord("CREATE", () -> begin +STATE, STATE_CFA = defNewVar("STATE", 0) + +HEADER = defPrimWord("HEADER", () -> begin wordLen = popPS() wordAddr = popPS() @@ -746,7 +812,7 @@ HIDE = defWord("HIDE", COLON = defWord(":", [WORD, - CREATE, + HEADER, LIT, DOCOL, COMMA, LATEST_CFA, FETCH, HIDDEN, RBRAC, @@ -764,24 +830,34 @@ IMMEDIATE = defPrimWord("IMMEDIATE", () -> begin return NEXT end, flags=F_IMMED) -TICK = defWord("'", [WORD, FIND, TOCFA, EXIT]) +TICK = defWord("'", + [WORD, FIND, TOCFA, EXIT]) -# Branching +BTICK = defWord("[']", + [FROMR, DUP, INCR, TOR, FETCH, EXIT]) -BRANCH = defPrimWord("BRANCH", () -> begin - reg.IP += mem[reg.IP] - return NEXT -end) +# CREATE and DOES> -ZBRANCH = defPrimWord("0BRANCH", () -> begin - if (popPS() == 0) - reg.IP += mem[reg.IP] - else - reg.IP += 1 - end +CREATE = defWord("CREATE", + [WORD, + HEADER, + LIT, DOVAR, COMMA, EXIT]); +DODOES = defPrim(() -> begin + pushRS(reg.IP) + reg.IP = reg.W + 1 return NEXT -end) +end, name="DOCOL") + +defConst("DODOES", DODOES) + +FROMDOES_PAREN = defWord("(DOES>)", + [DODOES, LAST, FETCH, TOCFA, STORE, EXIT]) + +FROMDOES = defWord("DOES>", + [BTICK, FROMDOES_PAREN, COMMA, BTICK, EXIT, COMMA, + BTICK, LIT, COMMA, LATEST, FETCH, TODFA, COMMA], flags=F_IMMED) + # Strings @@ -810,12 +886,21 @@ EXECUTE = defPrimWord("EXECUTE", () -> begin return mem[reg.W] end) +type ParseError <: Exception + wordName::ASCIIString +end +Base.showerror(io::IO, ex::ParseError) = print(io, "Parse error at word: '$(ex.wordName)'.") + +DEBUG, DEBUG_CFA = defNewVar("DEBUG", 0) + INTERPRET = defPrimWord("INTERPRET", () -> begin callPrim(mem[WORD]) wordName = getString(mem[reg.PSP-1], mem[reg.PSP]) - #println("... ", replace(wordName, "\n", "\\n"), " ...") + if mem[DEBUG] != 0 + println("... ", replace(replace(wordName, "\004", "EOF"), "\n", "\\n"), " ...") + end callPrim(mem[TWODUP]) callPrim(mem[FIND]) @@ -828,13 +913,12 @@ INTERPRET = defPrimWord("INTERPRET", () -> begin isImmediate = (mem[wordAddr+1] & F_IMMED) != 0 callPrim(mem[TOCFA]) - callPrim(mem[ROT]) # get rid of extra copy of word string details + callPrim(mem[NROT]) # get rid of extra copy of word string details popPS() popPS() if mem[STATE] == 0 || isImmediate # Execute! - #println("Executing CFA at $(mem[reg.PSP])") return callPrim(mem[EXECUTE]) else # Append CFA to dictionary @@ -848,8 +932,7 @@ INTERPRET = defPrimWord("INTERPRET", () -> begin callPrim(mem[NUMBER]) if popPS() != 0 - println("Parse error at word: '$wordName'") - return NEXT + throw(ParseError(wordName)) end if mem[STATE] == 0 @@ -870,13 +953,53 @@ QUIT = defWord("QUIT", INTERPRET, BRANCH,-2]) +BYE = defPrimWord("BYE", () -> begin + return 0 +end) + +PROMPT = defPrimWord("PROMPT", () -> begin + println(" ok") +end) + NL = defPrimWord("\n", () -> begin - if mem[STATE] == 0 - println(" ok") + if mem[STATE] == 0 && currentSource() == STDIN + callPrim(mem[PROMPT]) end return NEXT end, flags=F_IMMED) +INCLUDE = defPrimWord("INCLUDE", () -> begin + callPrim(mem[WORD]) + wordLen = popPS() + wordAddr = popPS() + word = getString(wordAddr, wordLen) + + push!(sources, open(word, "r")) + + # Clear input buffer + mem[NUMTIB] = 0 + + return NEXT +end) + +EOF_WORD = defPrimWord("\x04", () -> begin + if currentSource() != STDIN + close(currentSource()) + end + + pop!(sources) + + if length(sources)>0 + if currentSource() == STDIN + callPrim(mem[PROMPT]) + end + + return NEXT + else + return 0 + end +end, flags=F_IMMED) + # Odds and Ends CHAR = defPrimWord("CHAR", () -> begin @@ -889,20 +1012,60 @@ CHAR = defPrimWord("CHAR", () -> begin return NEXT end) -BYE = defPrimWord("BYE", () -> begin - return 0 -end) +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 + #### VM loop #### -function runVM() +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 + if mem[DEBUG] != 0 + println("Evaluating prim ", jmp," ", primNames[-jmp]) + end + + jmp = callPrim(jmp) + + catch ex + showerror(STDOUT, ex) + println() + + while !isempty(sources) && currentSource() != STDIN + close(pop!(sources)) + end + + mem[STATE] = 0 + mem[NUMTIB] = 0 + reg.PSP = mem[PSP0] + reg.RSP = mem[RSP0] + reg.IP = QUIT + 1 + jmp = NEXT + end end end @@ -969,4 +1132,13 @@ function printRS() end end +DUMP = defPrimWord("DUMP", () -> begin + count = popPS() + addr = popPS() + + dump(addr, count=count) + + return NEXT +end) + end