Added FIND, TOCFA
[forth.jl.git] / src / forth.jl
1 module forth
2
3 # VM mem size
4 size_mem = 640*1024
5
6 # Buffer sizes
7 size_RS = 1024   # Return stack size
8 size_PS = 1024   # Parameter stack size
9 size_TIB = 1096  # Terminal input buffer size
10
11 # The mem array constitutes the memory of the VM. It has the following geography:
12 #
13 # mem = +-----------------------+
14 #       | Built-in Variables    |
15 #       +-----------------------+
16 #       | Return Stack          |
17 #       +-----------------------+
18 #       | Parameter Stack       |
19 #       +-----------------------+
20 #       | Terminal Input Buffer |
21 #       +-----------------------+
22 #       | Dictionary            |
23 #       +-----------------------+
24 #
25 # Note that all words (user-defined, primitive, variables, etc) are included in
26 # the dictionary.
27 #
28 # Simple linear addressing is used with one exception: references to primitive code
29 # blocks, which are represented as anonymous functions, appear the negative index
30 # into the primitives array which contains only these functions.
31
32 mem = Array{Int64,1}(size_mem)
33 primitives = Array{Function,1}()
34
35 # Built-in variables
36
37 nextVarAddr = 1
38 RSP0 = nextVarAddr; nextVarAddr += 1
39 PSP0 = nextVarAddr; nextVarAddr += 1
40 HERE = nextVarAddr; nextVarAddr += 1
41 LATEST = nextVarAddr; nextVarAddr += 1
42
43 mem[RSP0] = nextVarAddr              # bottom of RS
44 mem[PSP0] = mem[RSP0] + size_RS      # bottom of PS
45 TIB = mem[PSP0] + size_PS            # address of terminal input buffer
46 mem[HERE] = TIB + size_TIB           # location of bottom of dictionary
47 mem[LATEST] = 0                      # no previous definition
48
49 DICT = mem[HERE] # Save bottom of dictionary as constant
50
51 # VM registers
52 type Reg
53     RSP::Int64  # Return stack pointer
54     PSP::Int64  # Parameter/data stack pointer
55     IP::Int64   # Instruction pointer
56     W::Int64    # Working register
57     X::Int64    # Extra register
58 end
59 reg = Reg(mem[RSP0], mem[PSP0], 0, 0, 0)
60
61 # Stack manipulation
62
63 type StackUnderflow <: Exception end
64
65 getRSDepth() = reg.RSP - mem[RSP0]
66 getPSDepth() = reg.PSP - mem[PSP0]
67
68 function ensurePSDepth(depth::Int64)
69     if getPSDepth()<depth
70         throw(StackUnderflow())
71     end
72 end
73
74 function ensureRSDepth(depth::Int64)
75     if getRSDepth()<depth
76         throw(StackUnderflow())
77     end
78 end
79
80 function pushRS(val::Int64)
81     mem[reg.RSP+=1] = val
82 end
83
84 function popRS()
85     ensureRSDepth(1)
86
87     val = mem[reg.RSP]
88     reg.RSP -= 1
89     return val
90 end
91
92 function pushPS(val::Int64)
93     mem[reg.PSP += 1] = val
94 end
95
96 function popPS()
97     ensurePSDepth(1)
98
99     val = mem[reg.PSP]
100     reg.PSP -= 1
101     return val
102 end
103
104 # Primitive creation and calling functions
105
106 function createHeader(name::AbstractString, flags::Int64)
107     mem[mem[HERE]] = mem[LATEST]
108     mem[LATEST] = mem[HERE]
109     mem[HERE] += 1
110
111     mem[mem[HERE]] = length(name) | flags; mem[HERE] += 1
112     mem[mem[HERE]:(mem[HERE]+length(name)-1)] = [Int(c) for c in name]; mem[HERE] += length(name)
113 end
114
115 function defPrim(name::AbstractString, f::Function; flags::Int64=0)
116     createHeader(name, flags)
117
118     push!(primitives, f)
119     mem[mem[HERE]] = -length(primitives)
120     mem[HERE] += 1
121
122     return -length(primitives)
123 end
124
125 callPrim(addr::Int64) = primitives[-addr]()
126
127 function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0)
128     defPrim(name, eval(:(() -> begin
129         pushPS($(varAddr))
130         return NEXT
131     end)))
132 end
133
134 function defNewVar(name::AbstractString, initial::Int64; flags::Int64=0)
135     createHeader(name, flags)
136     
137     varAddr = mem[HERE] + 1
138     push!(primitives, eval(:(() -> begin
139         pushPS($(varAddr))
140         return NEXT
141     end)))
142     mem[mem[HERE]] = -length(primitives); mem[HERE] += 1
143
144     mem[mem[HERE]] = initial; mem[HERE] += 1
145
146     return varAddr
147 end
148
149 function defConst(name::AbstractString, val::Int64; flags::Int64=0)
150     defPrim(name, eval(:(() -> begin
151         pushPS($(val))
152         return NEXT
153     end)))
154
155     return val
156 end
157
158 # Threading Primitives
159
160 NEXT = defPrim("NEXT", () -> begin
161     reg.W = mem[reg.IP]
162     reg.IP += 1
163     X = mem[reg.W]
164     return X
165 end)
166
167 DOCOL = defPrim("DOCOL", () -> begin
168     pushRS(reg.IP)
169     reg.IP = reg.W + 1
170     return NEXT
171 end)
172
173 EXIT = defPrim("EXIT", () -> begin
174     reg.IP = popRS()
175     return NEXT
176 end)
177
178
179 # Basic forth primitives
180
181 DROP = defPrim("DROP", () -> begin
182     popPS()
183     return NEXT
184 end)
185
186 SWAP = defPrim("SWAP", () -> begin
187     a = popPS()
188     b = popPS()
189     pushPS(a)
190     pushPS(b)
191     return NEXT
192 end)
193
194 DUP = defPrim("DUP", () -> begin
195     pushPS(mem[reg.PSP])
196     return NEXT
197 end)
198
199 OVER = defPrim("OVER", () -> begin
200     ensurePSDepth(2)
201     pushPS(mem[reg.PSP-1])
202     return NEXT
203 end)
204
205 ROT = defPrim("ROT", () -> begin
206     a = popPS()
207     b = popPS()
208     c = popPS()
209     pushPS(a)
210     pushPS(c)
211     pushPS(b)
212     return NEXT
213 end)
214
215 NROT = defPrim("-ROT", () -> begin
216     a = popPS()
217     b = popPS()
218     c = popPS()
219     pushPS(b)
220     pushPS(a)
221     pushPS(c)
222     return NEXT
223 end)
224
225 TWODROP = defPrim("2DROP", () -> begin
226     popPS()
227     popPS()
228     return NEXT
229 end)
230
231 TWODUP = defPrim("2DUP", () -> begin
232     ensurePSDepth(2)
233     a = mem[reg.PSP-1]
234     b = mem[reg.PSP]
235     pushPS(a)
236     pushPS(b)
237     return NEXT
238 end)
239
240 TWOSWAP = defPrim("2SWAP", () -> begin
241     a = popPS()
242     b = popPS()
243     c = popPS()
244     d = popPS()
245     pushPS(b)
246     pushPS(a)
247     pushPS(c)
248     pushPS(d)
249     return NEXT
250 end)
251
252 QDUP = defPrim("?DUP", () -> begin
253     ensurePSDepth(1)
254     val = mem[reg.PSP]
255     if val != 0
256         pushPS(val)
257     end
258     return NEXT
259 end)
260
261 LIT = defPrim("LIT", () -> begin
262     pushPS(mem[reg.IP])
263     reg.IP += 1
264     return NEXT
265 end)
266
267 # Memory primitives
268
269 STORE = defPrim("!", () -> begin
270     addr = popPS()
271     dat = popPS()
272     mem[addr] = dat
273     return NEXT
274 end)
275
276 FETCH = defPrim("@", () -> begin
277     addr = popPS()
278     pushPS(mem[addr])
279     return NEXT
280 end)
281
282 ADDSTORE = defPrim("+!", () -> begin
283     addr = popPS()
284     toAdd = popPS()
285     mem[addr] += toAdd
286     return NEXT
287 end)
288
289 SUBSTORE = defPrim("-!", () -> begin
290     addr = popPS()
291     toSub = popPS()
292     mem[addr] -= toSub
293     return NEXT
294 end)
295
296
297 # Built-in variables
298
299 defExistingVar("HERE", HERE)
300 defExistingVar("LATEST", LATEST)
301 defExistingVar("PSP0", PSP0)
302 defExistingVar("RSP0", RSP0)
303 STATE = defNewVar("STATE", 0)
304 BASE = defNewVar("BASE", 10)
305
306 # Constants
307
308 defConst("VERSION", 1)
309 defConst("DOCOL", DOCOL)
310 defConst("DICT", DICT)
311 F_IMMED = defConst("F_IMMED", 128)
312 F_HIDDEN = defConst("F_HIDDEN", 256)
313 F_LENMASK = defConst("F_LENMASK", 127)
314
315 # Return Stack
316
317 TOR = defPrim(">R", () -> begin
318     pushRS(popPS())
319     return NEXT
320 end)
321
322 FROMR = defPrim("R>", () -> begin
323     pushPS(popRS())
324     return NEXT
325 end)
326
327 RSPFETCH = defPrim("RSP@", () -> begin
328     pushPS(reg.RSP)
329     return NEXT
330 end)
331
332 RSPSTORE = defPrim("RSP!", () -> begin
333     RSP = popPS()
334     return NEXT
335 end)
336
337 RDROP = defPrim("RDROP", () -> begin
338     popRS()
339     return NEXT
340 end)
341
342 # Parameter Stack
343
344 PSPFETCH = defPrim("PSP@", () -> begin
345     pushPS(reg.PSP)
346     return NEXT
347 end)
348
349 PSPSTORE = defPrim("PSP!", () -> begin
350     PSP = popPS()
351     return NEXT
352 end)
353
354 # I/O
355
356 defConst("TIB", TIB)
357 NUMTIB = defNewVar("#TIB", 0)
358 TOIN = defNewVar(">IN", 0)
359
360 KEY = defPrim("KEY", () -> begin
361     if mem[TOIN] >= mem[NUMTIB]
362         mem[TOIN] = 0
363         line = readline()
364         mem[NUMTIB] = length(line)
365         mem[TIB:(TIB+mem[NUMTIB]-1)] = [Int64(c) for c in collect(line)]
366     end
367
368     pushPS(mem[TIB + mem[TOIN]])
369     mem[TOIN] += 1
370
371     return NEXT
372 end)
373
374 EMIT = defPrim("EMIT", () -> begin
375     print(Char(popPS()))
376     return NEXT
377 end)
378
379 WORD = defPrim("WORD", () -> begin
380     
381     c = -1
382
383     skip_to_end = false
384     while true
385
386         callPrim(KEY)
387         c = Char(popPS())
388
389         if c == '\\'
390             skip_to_end = true
391             continue
392         end
393
394         if skip_to_end
395             if c == '\n'
396                 skip_to_end = false
397             end
398             continue
399         end
400
401         if c == ' ' || c == '\t'
402             continue
403         end
404
405         break
406     end
407
408     wordAddr = mem[HERE]
409     offset = 0
410
411     while true
412         mem[wordAddr + offset] = Int64(c)
413         offset += 1
414
415         callPrim(KEY)
416         c = Char(popPS())
417
418         if c == ' ' || c == '\t' || c == '\n'
419             break
420         end
421     end
422
423     wordLen = offset
424
425     pushPS(wordAddr)
426     pushPS(wordLen)
427
428     return NEXT
429 end)
430
431 NUMBER = defPrim("NUMBER", () -> begin
432
433     wordLen = popPS()
434     wordAddr = popPS()
435
436     s = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]])
437
438     try
439         pushPS(parse(Int64, s, mem[BASE]))
440         pushPS(0)
441     catch
442         pushPS(1) # Error indication
443     end
444
445     return NEXT
446 end)
447
448 # Dictionary searches
449
450 FIND = defPrim("FIND", () -> begin
451
452     wordLen = popPS()
453     wordAddr = popPS()
454     word = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]])
455
456     latest = mem[LATEST]
457     
458     while latest>0
459         lenAndFlags = mem[latest+1]
460         len = lenAndFlags & F_LENMASK
461         hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN
462
463         if hidden || len != wordLen
464             latest = mem[latest]
465             continue
466         end
467         
468         thisAddr = latest+2
469         thisWord = ASCIIString([Char(c) for c in mem[thisAddr:(thisAddr+len-1)]])
470
471         if thisWord == word
472             break
473         end
474     end
475
476     pushPS(latest)
477
478     return NEXT
479 end)
480
481 TOCFA = defPrim(">CFA", () -> begin
482
483     addr = popPS()
484     lenAndFlags = mem[addr+1]
485     len = lenAndFlags & F_LENMASK
486
487     pushPS(addr + 1 + len)
488
489     return NEXT
490 end)
491
492 #### VM loop ####
493 #function runVM(reg::Reg)
494 #    jmp = NEXT
495 #    while (jmp = callPrim(reg, jmp)) != 0 end
496 #end
497
498 # Debugging tools
499
500 function coredump(startAddr::Int64; count::Int64 = 16, cellsPerLine::Int64 = 8)
501     chars = Array{Char,1}(cellsPerLine)
502
503     for i in 0:(count-1)
504         addr = startAddr + i
505         if i%cellsPerLine == 0
506             print("$addr:")
507         end
508
509         print("\t$(mem[addr]) ")
510
511         if (mem[addr]>=32 && mem[addr]<176)
512             chars[i%cellsPerLine + 1] = Char(mem[addr])
513         else
514             chars[i%cellsPerLine + 1] = '.'
515         end
516
517         if i%cellsPerLine == cellsPerLine-1
518             println(string("\t", ASCIIString(chars)))
519         end
520     end
521 end
522
523 function printPS()
524     count = reg.PSP - mem[PSP0]
525
526     if count > 0
527         print("<$count>")
528         for i in (mem[PSP0]+1):reg.PSP
529             print(" $(mem[i])")
530         end
531         println()
532     else
533         println("Parameter stack empty")
534     end
535 end
536
537 end