X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fforth.jl;h=e571758f6d76254f7c5f70f023cbe6afa95fc7c2;hb=7cc4407fe0b3da1af97f444bb03d874e868a7152;hp=b1a78f32b90a9197a3ac2465665157bb2b987076;hpb=6e2ccc15f2ba17285a61b33ad8d2f23da6c66be7;p=forth.jl.git diff --git a/src/forth.jl b/src/forth.jl index b1a78f3..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: # @@ -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() 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 @@ -207,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 @@ -243,9 +268,9 @@ ROT = defPrimWord("ROT", () -> begin a = popPS() b = popPS() c = popPS() + pushPS(b) pushPS(a) pushPS(c) - pushPS(b) return NEXT end) @@ -253,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() @@ -281,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) @@ -349,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() @@ -485,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 @@ -515,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 @@ -556,6 +588,9 @@ 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) @@ -565,8 +600,8 @@ KEY = defPrimWord("KEY", () -> begin if mem[TOIN] >= mem[NUMTIB] mem[TOIN] = 0 - if !eof(reg.source) - line = readline(reg.source) + if !eof(currentSource()) + line = readline(currentSource()) mem[NUMTIB] = length(line) putString(line, TIB) else @@ -650,6 +685,7 @@ WORD = defPrimWord("WORD", () -> begin return NEXT end) +BASE, BASE_CFA = defNewVar("BASE", 10) NUMBER = defPrimWord("NUMBER", () -> begin wordLen = popPS() @@ -713,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() @@ -757,7 +812,7 @@ HIDE = defWord("HIDE", COLON = defWord(":", [WORD, - CREATE, + HEADER, LIT, DOCOL, COMMA, LATEST_CFA, FETCH, HIDDEN, RBRAC, @@ -775,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 @@ -821,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(replace(wordName, "\004", "EOF"), "\n", "\\n"), " ...") + if mem[DEBUG] != 0 + println("... ", replace(replace(wordName, "\004", "EOF"), "\n", "\\n"), " ...") + end callPrim(mem[TWODUP]) callPrim(mem[FIND]) @@ -839,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 @@ -859,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 @@ -885,21 +957,24 @@ BYE = defPrimWord("BYE", () -> begin return 0 end) +PROMPT = defPrimWord("PROMPT", () -> begin + println(" ok") +end) + NL = defPrimWord("\n", () -> begin - if mem[STATE] == 0 && reg.source == STDIN - 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) - reg.source = open(word, "r") + push!(sources, open(word, "r")) # Clear input buffer mem[NUMTIB] = 0 @@ -908,12 +983,20 @@ INCLUDE = defPrimWord("INCLUDE", () -> begin end) EOF_WORD = defPrimWord("\x04", () -> begin - if reg.source == STDIN - return 0 - else - close(reg.source) - reg.source = STDIN + 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) @@ -929,8 +1012,31 @@ CHAR = defPrimWord("CHAR", () -> begin return NEXT 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 run() +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 @@ -939,17 +1045,26 @@ function run() jmp = NEXT while jmp != 0 try - #println("Evaluating prim $jmp $(primNames[-jmp])") + if mem[DEBUG] != 0 + println("Evaluating prim ", jmp," ", primNames[-jmp]) + end + jmp = callPrim(jmp) catch ex - if isa(ex, StackUnderflow) - println("Stack underflow!") + showerror(STDOUT, ex) + println() - mem[NUMTIB] = 0 - reg.IP = QUIT + 1 - jmp = NEXT + 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 @@ -1017,4 +1132,13 @@ function printRS() end end +DUMP = defPrimWord("DUMP", () -> begin + count = popPS() + addr = popPS() + + dump(addr, count=count) + + return NEXT +end) + end