X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fforth.jl;h=e571758f6d76254f7c5f70f023cbe6afa95fc7c2;hb=7cc4407fe0b3da1af97f444bb03d874e868a7152;hp=e04e288b60be0e171749c291dcc49bc17da71a3b;hpb=5070d1857a0f408590f3f18c754552cea8b75d3c;p=forth.jl.git diff --git a/src/forth.jl b/src/forth.jl index e04e288..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: # @@ -60,20 +60,24 @@ 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 @@ -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 @@ -241,9 +268,9 @@ ROT = defPrimWord("ROT", () -> begin a = popPS() b = popPS() c = popPS() + pushPS(b) pushPS(a) pushPS(c) - pushPS(b) return NEXT end) @@ -251,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() @@ -279,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) @@ -347,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() @@ -483,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 @@ -513,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 @@ -651,6 +685,7 @@ WORD = defPrimWord("WORD", () -> begin return NEXT end) +BASE, BASE_CFA = defNewVar("BASE", 10) NUMBER = defPrimWord("NUMBER", () -> begin wordLen = popPS() @@ -733,7 +768,9 @@ end) # Compilation -CREATE = defPrimWord("CREATE", () -> begin +STATE, STATE_CFA = defNewVar("STATE", 0) + +HEADER = defPrimWord("HEADER", () -> begin wordLen = popPS() wordAddr = popPS() @@ -775,7 +812,7 @@ HIDE = defWord("HIDE", COLON = defWord(":", [WORD, - CREATE, + HEADER, LIT, DOCOL, COMMA, LATEST_CFA, FETCH, HIDDEN, RBRAC, @@ -794,9 +831,33 @@ IMMEDIATE = defPrimWord("IMMEDIATE", () -> begin end, flags=F_IMMED) TICK = defWord("'", - [STATE_CFA, FETCH, ZBRANCH, 7, - FROMR, DUP, INCR, TOR, FETCH, EXIT, - WORD, FIND, TOCFA, EXIT]) + [WORD, FIND, TOCFA, EXIT]) + +BTICK = defWord("[']", + [FROMR, DUP, INCR, TOR, FETCH, EXIT]) + +# CREATE and DOES> + +CREATE = defWord("CREATE", + [WORD, + HEADER, + LIT, DOVAR, COMMA, EXIT]); + +DODOES = defPrim(() -> begin + pushRS(reg.IP) + reg.IP = reg.W + 1 + return NEXT +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 @@ -825,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]) @@ -843,7 +913,7 @@ 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() @@ -862,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 @@ -888,9 +957,13 @@ BYE = defPrimWord("BYE", () -> begin return 0 end) +PROMPT = defPrimWord("PROMPT", () -> begin + println(" ok") +end) + NL = defPrimWord("\n", () -> begin if mem[STATE] == 0 && currentSource() == STDIN - println(" ok") + callPrim(mem[PROMPT]) end return NEXT end, flags=F_IMMED) @@ -917,6 +990,10 @@ EOF_WORD = defPrimWord("\x04", () -> begin pop!(sources) if length(sources)>0 + if currentSource() == STDIN + callPrim(mem[PROMPT]) + end + return NEXT else return 0 @@ -935,11 +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 @@ -948,19 +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 - else - rethrow(ex) + 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 @@ -1028,16 +1132,6 @@ function printRS() end end -DOT = defPrimWord(".", () -> begin - print(popPS()) - return NEXT -end) - -DOTS = defPrimWord(".s", () -> begin - printPS() - return NEXT -end) - DUMP = defPrimWord("DUMP", () -> begin count = popPS() addr = popPS()