Working on getting initialization working again.
[forth.jl.git] / src / forth.jl
1 module forth
2
3 import Base.REPLCompletions
4
5 # VM mem size
6 size_mem = 1000000 # 1 mega-int
7
8 # Buffer sizes
9 size_RS = 1000   # Return stack size
10 size_PS = 1000   # Parameter stack size
11 size_TIB = 1000  # Terminal input buffer size
12 size_FIB = 1000  # File input buffer size
13
14 # Memory arrays
15 mem = Array{Int64,1}(size_mem)
16 primitives = Array{Function,1}()
17 primNames = Array{AbstractString,1}()
18
19 # Memory geography and built-in variables
20
21 nextVarAddr = 1
22 H = nextVarAddr; nextVarAddr += 1              # Next free memory address
23 FORTH_LATEST = nextVarAddr; nextVarAddr += 1   # FORTH dict latest
24 CURRENT = nextVarAddr; nextVarAddr += 1        # Current compilation dict
25
26 RSP0 = nextVarAddr                  # bottom of RS
27 PSP0 = RSP0 + size_RS               # bottom of PS
28 TIB = PSP0 + size_PS                # address of terminal input buffer
29 FIB = TIB + size_TIB                # address of terminal input buffer
30 mem[H] = FIB + size_FIB             # location of bottom of dictionary
31 mem[FORTH_LATEST] = 0               # zero FORTH dict latest (no previous def)
32 mem[CURRENT] = FORTH_LATEST-1       # Compile words to system dict initially
33
34 DICT = mem[H] # Save bottom of dictionary as constant
35
36 # VM registers
37 type Reg
38     RSP::Int64  # Return stack pointer
39     PSP::Int64  # Parameter/data stack pointer
40     IP::Int64   # Instruction pointer
41     W::Int64    # Working register
42 end
43 reg = Reg(RSP0, PSP0, 0, 0)
44
45 # Stack manipulation functions
46
47 function ensurePSDepth(depth::Int64)
48     if reg.PSP - PSP0 < depth
49         error("Parameter stack underflow.")
50     end
51 end
52
53 function ensurePSCapacity(toAdd::Int64)
54     if reg.PSP + toAdd >= PSP0 + size_PS
55         error("Parameter stack overflow.")
56     end
57 end
58
59 function ensureRSDepth(depth::Int64)
60     if reg.RSP - RSP0 < depth
61         error("Return stack underflow.")
62     end
63 end
64
65 function ensureRSCapacity(toAdd::Int64)
66     if reg.RSP + toAdd >= RSP0 + size_RS
67         error("Return stack overflow.")
68     end
69 end
70
71 function pushRS(val::Int64)
72     ensureRSCapacity(1)
73     mem[reg.RSP+=1] = val
74 end
75
76 function popRS()
77     ensureRSDepth(1)
78
79     val = mem[reg.RSP]
80     reg.RSP -= 1
81     return val
82 end
83
84 function pushPS(val::Int64)
85     ensurePSCapacity(1)
86
87     mem[reg.PSP += 1] = val
88 end
89
90 function popPS()
91     ensurePSDepth(1)
92
93     val = mem[reg.PSP]
94     reg.PSP -= 1
95     return val
96 end
97
98 # Handy functions for adding/retrieving strings to/from memory.
99
100 getString(addr::Int64, len::Int64) = AbstractString([Char(c) for c in mem[addr:(addr+len-1)]])
101
102 function putString(str::AbstractString, addr::Int64, maxLen::Int64)
103     len = min(length(str), maxLen)
104     mem[addr:(addr+len-1)] = [Int64(c) for c in str]
105 end
106
107 stringAsInts(str::AbstractString) = [Int(c) for c in collect(str)]
108
109 # Primitive creation and calling functions
110
111 function defPrim(f::Function; name="nameless")
112     push!(primitives, f)
113     push!(primNames, replace(name, "\004", "EOF"))
114
115     return -length(primitives)
116 end
117
118 function callPrim(addr::Int64)
119     if addr >=0 || -addr>length(primitives)
120         error("Attempted to execute non-existent primitive at address $addr.")
121     else
122         primitives[-addr]()
123     end
124 end
125 getPrimName(addr::Int64) = primNames[-addr]
126
127 # Word creation functions
128
129 F_LENMASK = 31
130 F_IMMED = 32
131 F_HIDDEN = 64
132 NFA_MARK = 128
133
134 function dictWrite(ints::Array{Int64,1})
135     mem[mem[H]:(mem[H]+length(ints)-1)] = ints
136     mem[H] += length(ints)
137 end
138 dictWrite(int::Int64) = dictWrite([int])
139 dictWriteString(string::AbstractString) = dictWrite([Int64(c) for c in string])
140
141 function createHeader(name::AbstractString, flags::Int64)
142     mem[mem[H]] = mem[mem[CURRENT]+1]
143     mem[mem[CURRENT]+1] = mem[H]
144     mem[H] += 1
145
146     dictWrite(length(name) | flags | NFA_MARK)
147     dictWriteString(name)
148 end
149
150 function defPrimWord(name::AbstractString, f::Function; flags::Int64=0)
151     createHeader(name, flags)
152
153     codeWordAddr = mem[H]
154     dictWrite(defPrim(f, name=name))
155
156     return codeWordAddr
157 end
158
159 function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0)
160     createHeader(name, flags)
161
162     addr = mem[H]
163     dictWrite(DOCOL)
164
165     dictWrite(wordAddrs)
166
167     return addr
168 end
169
170 # Variable creation functions
171
172 function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0)
173
174     defPrimWord(name, eval(:(() -> begin
175         pushPS($(varAddr))
176         return NEXT
177     end)))
178 end
179
180 function defNewVar(name::AbstractString, initial::Array{Int64,1}; flags::Int64=0)
181     createHeader(name, flags)
182     
183     codeWordAddr = mem[H]
184     varAddr = mem[H] + 1
185
186     dictWrite(DOVAR)
187     dictWrite(initial)
188
189     return varAddr, codeWordAddr
190 end
191
192 defNewVar(name::AbstractString, initial::Int64; flags::Int64=0) =
193     defNewVar(name, [initial]; flags=flags)
194
195 function defConst(name::AbstractString, val::Int64; flags::Int64=0)
196     createHeader(name, flags)
197
198     codeWordAddr = mem[H]
199
200     dictWrite(DOCON)
201     dictWrite(val)
202
203     return codeWordAddr
204 end
205
206 # Threading Primitives (inner interpreter)
207
208 NEXT = defPrim(() -> begin
209     reg.W = mem[reg.IP]
210     reg.IP += 1
211     return mem[reg.W]
212 end, name="NEXT")
213
214 DOCOL = defPrim(() -> begin
215     pushRS(reg.IP)
216     reg.IP = reg.W + 1
217     return NEXT
218 end, name="DOCOL")
219
220 DOVAR = defPrim(() -> begin
221     pushPS(reg.W + 1)
222     return NEXT
223 end, name="DOVAR")
224
225 DOCON = defPrim(() -> begin
226     pushPS(mem[reg.W + 1])
227     return NEXT
228 end, name="DOVAR")
229
230 EXIT_CFA = defPrimWord("EXIT", () -> begin
231     reg.IP = popRS()
232     return NEXT
233 end)
234
235 # Dictionary entries for core built-in variables, constants
236
237 H_CFA = defExistingVar("H", H)
238
239 PSP0_CFA = defConst("PSP0", PSP0)
240 RSP0_CFA = defConst("RSP0", RSP0)
241
242 defConst("DOCOL", DOCOL)
243 defConst("DOCON", DOCON)
244 defConst("DOVAR", DOVAR)
245
246 defConst("DICT", DICT)
247 defConst("MEMSIZE", size_mem)
248
249 F_IMMED_CFA = defConst("F_IMMED", F_IMMED)
250 F_HIDDEN_CFA = defConst("F_HIDDEN", F_HIDDEN)
251 F_LENMASK_CFA = defConst("F_LENMASK", F_LENMASK)
252 NFA_MARK_CFA = defConst("NFA_MARK", NFA_MARK)
253
254 # Basic forth primitives
255
256 DROP_CFA = defPrimWord("DROP", () -> begin
257     popPS()
258     return NEXT
259 end)
260
261 SWAP_CFA = defPrimWord("SWAP", () -> begin
262     a = popPS()
263     b = popPS()
264     pushPS(a)
265     pushPS(b)
266     return NEXT
267 end)
268
269 DUP_CFA = defPrimWord("DUP", () -> begin
270     ensurePSDepth(1)
271     pushPS(mem[reg.PSP])
272     return NEXT
273 end)
274
275 OVER_CFA = defPrimWord("OVER", () -> begin
276     ensurePSDepth(2)
277     pushPS(mem[reg.PSP-1])
278     return NEXT
279 end)
280
281 ROT_CFA = defPrimWord("ROT", () -> begin
282     a = popPS()
283     b = popPS()
284     c = popPS()
285     pushPS(b)
286     pushPS(a)
287     pushPS(c)
288     return NEXT
289 end)
290
291 NROT_CFA = defPrimWord("-ROT", () -> begin
292     a = popPS()
293     b = popPS()
294     c = popPS()
295     pushPS(a)
296     pushPS(c)
297     pushPS(b)
298     return NEXT
299 end)
300
301
302 TWODROP_CFA = defPrimWord("2DROP", () -> begin
303     popPS()
304     popPS()
305     return NEXT
306 end)
307
308 TWODUP_CFA = defPrimWord("2DUP", () -> begin
309     ensurePSDepth(2)
310     a = mem[reg.PSP-1]
311     b = mem[reg.PSP]
312     pushPS(a)
313     pushPS(b)
314     return NEXT
315 end)
316
317 TWOSWAP_CFA = defPrimWord("2SWAP", () -> begin
318     a = popPS()
319     b = popPS()
320     c = popPS()
321     d = popPS()
322     pushPS(b)
323     pushPS(a)
324     pushPS(d)
325     pushPS(c)
326     return NEXT
327 end)
328
329 TWOOVER_CFA = defPrimWord("2OVER", () -> begin
330     ensurePSDepth(4)
331     a = mem[reg.PSP-3]
332     b = mem[reg.PSP-2]
333     pushPS(a)
334     pushPS(b)
335     return NEXT
336 end)
337
338 QDUP_CFA = defPrimWord("?DUP", () -> begin
339     ensurePSDepth(1)
340     val = mem[reg.PSP]
341     if val != 0
342         pushPS(val)
343     end
344     return NEXT
345 end)
346
347 INCR_CFA = defPrimWord("1+", () -> begin
348     ensurePSDepth(1)
349     mem[reg.PSP] += 1
350     return NEXT
351 end)
352
353 DECR_CFA = defPrimWord("1-", () -> begin
354     ensurePSDepth(1)
355     mem[reg.PSP] -= 1
356     return NEXT
357 end)
358
359 INCR2_CFA = defPrimWord("2+", () -> begin
360     ensurePSDepth(1)
361     mem[reg.PSP] += 2
362     return NEXT
363 end)
364
365 DECR2_CFA = defPrimWord("2-", () -> begin
366     ensurePSDepth(1)
367     mem[reg.PSP] -= 2
368     return NEXT
369 end)
370
371 ADD_CFA = defPrimWord("+", () -> begin
372     b = popPS()
373     a = popPS()
374     pushPS(a+b)
375     return NEXT
376 end)
377
378 SUB_CFA = defPrimWord("-", () -> begin
379     b = popPS()
380     a = popPS()
381     pushPS(a-b)
382     return NEXT
383 end)
384
385 MUL_CFA = defPrimWord("*", () -> begin
386     b = popPS()
387     a = popPS()
388     pushPS(a*b)
389     return NEXT
390 end)
391
392 DIVMOD_CFA = defPrimWord("/MOD", () -> begin
393     b = popPS()
394     a = popPS()
395     q,r = divrem(a,b)
396     pushPS(r)
397     pushPS(q)
398     return NEXT
399 end)
400
401 TWOMUL_CFA = defPrimWord("2*", () -> begin
402     pushPS(popPS() << 1)
403     return NEXT
404 end)
405
406 TWODIV_CFA = defPrimWord("2/", () -> begin
407     pushPS(popPS() >> 1)
408     return NEXT
409 end)
410
411 EQ_CFA = defPrimWord("=", () -> begin
412     b = popPS()
413     a = popPS()
414     pushPS(a==b ? -1 : 0)
415     return NEXT
416 end)
417
418 NE_CFA = defPrimWord("<>", () -> begin
419     b = popPS()
420     a = popPS()
421     pushPS(a!=b ? -1 : 0)
422     return NEXT
423 end)
424
425 LT_CFA = defPrimWord("<", () -> begin
426     b = popPS()
427     a = popPS()
428     pushPS(a<b ? -1 : 0)
429     return NEXT
430 end)
431
432 GT_CFA = defPrimWord(">", () -> begin
433     b = popPS()
434     a = popPS()
435     pushPS(a>b ? -1 : 0)
436     return NEXT
437 end)
438
439 LE_CFA = defPrimWord("<=", () -> begin
440     b = popPS()
441     a = popPS()
442     pushPS(a<=b ? -1 : 0)
443     return NEXT
444 end)
445
446 GE_CFA = defPrimWord(">=", () -> begin
447     b = popPS()
448     a = popPS()
449     pushPS(a>=b ? -1 : 0)
450     return NEXT
451 end)
452
453 ZE_CFA = defPrimWord("0=", () -> begin
454     pushPS(popPS() == 0 ? -1 : 0)
455     return NEXT
456 end)
457
458 ZNE_CFA = defPrimWord("0<>", () -> begin
459     pushPS(popPS() != 0 ? -1 : 0)
460     return NEXT
461 end)
462
463 ZLT_CFA = defPrimWord("0<", () -> begin
464     pushPS(popPS() < 0 ? -1 : 0)
465     return NEXT
466 end)
467
468 ZGT_CFA = defPrimWord("0>", () -> begin
469     pushPS(popPS() > 0 ? -1 : 0)
470     return NEXT
471 end)
472
473 ZLE_CFA = defPrimWord("0<=", () -> begin
474     pushPS(popPS() <= 0 ? -1 : 0)
475     return NEXT
476 end)
477
478 ZGE_CFA = defPrimWord("0>=", () -> begin
479     pushPS(popPS() >= 0 ? -1 : 0)
480     return NEXT
481 end)
482
483 AND_CFA = defPrimWord("AND", () -> begin
484     b = popPS()
485     a = popPS()
486     pushPS(a & b)
487     return NEXT
488 end)
489
490 OR_CFA = defPrimWord("OR", () -> begin
491     b = popPS()
492     a = popPS()
493     pushPS(a | b)
494     return NEXT
495 end)
496
497 XOR_CFA = defPrimWord("XOR", () -> begin
498     b = popPS()
499     a = popPS()
500     pushPS(a $ b)
501     return NEXT
502 end)
503
504 INVERT_CFA = defPrimWord("INVERT", () -> begin
505     pushPS(~popPS())
506     return NEXT
507 end)
508
509 # Literals
510
511 LIT_CFA = defPrimWord("LIT", () -> begin
512     pushPS(mem[reg.IP])
513     reg.IP += 1
514     return NEXT
515 end)
516
517 # Memory primitives
518
519 STORE_CFA = defPrimWord("!", () -> begin
520     addr = popPS()
521     dat = popPS()
522     mem[addr] = dat
523     return NEXT
524 end)
525
526 FETCH_CFA = defPrimWord("@", () -> begin
527     addr = popPS()
528     pushPS(mem[addr])
529     return NEXT
530 end)
531
532 ADDSTORE_CFA = defPrimWord("+!", () -> begin
533     addr = popPS()
534     toAdd = popPS()
535     mem[addr] += toAdd
536     return NEXT
537 end)
538
539 SUBSTORE_CFA = defPrimWord("-!", () -> begin
540     addr = popPS()
541     toSub = popPS()
542     mem[addr] -= toSub
543     return NEXT
544 end)
545
546
547 # Return Stack
548
549 TOR_CFA = defPrimWord(">R", () -> begin
550     pushRS(popPS())
551     return NEXT
552 end)
553
554 FROMR_CFA = defPrimWord("R>", () -> begin
555     pushPS(popRS())
556     return NEXT
557 end)
558
559 RFETCH_CFA = defPrimWord("R@", () -> begin
560     pushPS(mem[reg.RSP])
561     return NEXT
562 end)
563
564 RSPFETCH_CFA = defPrimWord("RSP@", () -> begin
565     pushPS(reg.RSP)
566     return NEXT
567 end)
568
569 RSPSTORE_CFA = defPrimWord("RSP!", () -> begin
570     reg.RSP = popPS()
571     return NEXT
572 end)
573
574 RDROP_CFA = defPrimWord("RDROP", () -> begin
575     popRS()
576     return NEXT
577 end)
578
579 # Parameter Stack
580
581 PSPFETCH_CFA = defPrimWord("PSP@", () -> begin
582     pushPS(reg.PSP)
583     return NEXT
584 end)
585
586 PSPSTORE_CFA = defPrimWord("PSP!", () -> begin
587     reg.PSP = popPS()
588     return NEXT
589 end)
590
591 # Working Register
592
593 WFETCH_CFA = defPrimWord("W@", () -> begin
594     pushPS(reg.W)
595     return NEXT
596 end)
597
598 WSTORE_CFA = defPrimWord("W!", () -> begin
599     reg.W = popPS()
600     return NEXT
601 end)
602
603 # I/O
604
605 openFiles = Dict{Int64,IOStream}()
606 nextFileID = 1
607
608
609 ## File access modes
610 FAM_RO = 0
611 FAM_WO = 1
612 FAM_RO_CFA = defConst("R/O", FAM_RO)
613 FAM_WO_CFA = defConst("W/O", FAM_WO)
614
615 function fileOpener(create::Bool)
616     fnameLen = popPS()
617     fnameAddr = popPS()
618     fam = popPS()
619
620     fname = getString(fnameAddr, fnameLen)
621
622     if create && !isfile(fname)
623         pushPS(0)
624         pushPS(-1) # error
625         return NEXT
626     end
627
628     if (fam == FAM_RO)
629         mode = "r"
630     else
631         mode = "w"
632     end
633
634     openFiles[nextFileID] = open(fname, mode)
635     pushPS(nextFileID)
636     pushPS(0)
637     
638     nextFileID += 1
639 end
640
641 OPEN_FILE_CFA = defPrimWord("OPEN-FILE", () -> begin
642     fileOpener(false)
643     return NEXT
644 end);
645
646 CREATE_FILE_CFA = defPrimWord("CREATE-FILE", () -> begin
647     fileOpener(true)
648     return NEXT
649 end);
650
651 CLOSE_FILE_CFA = defPrimWord("CLOSE-FILE", () -> begin
652     fid = popPS()
653     close(openFiles[fid])
654     delete!(openFiles, fid)
655     return NEXT
656 end)
657
658 CLOSE_FILES_CFA = defPrimWord("CLOSE-FILES", () -> begin
659     for fh in values(openFiles)
660         close(fh)
661     end
662     empty!(openFiles)
663
664     return NEXT
665 end)
666
667 READ_LINE_CFA = defPrimWord("READ-LINE", () -> begin
668     fid = popPS()
669     maxSize = popPS()
670     addr = popPS()
671
672     fh = openFiles[fid]
673     line = readline(fh)
674
675     eofFlag = endswith(line, '\n') ? 0 : -1
676     line = chomp(line)
677
678     putString(line, addr, maxSize)
679
680     pushPS(length(line))
681     pushPS(eofFlag)
682     pushPS(0)
683
684     return NEXT
685 end)
686
687
688 EMIT_CFA = defPrimWord("EMIT", () -> begin
689     print(Char(popPS()))
690     return NEXT
691 end)
692
693 function raw_mode!(mode::Bool)
694     if ccall(:jl_tty_set_mode, Int32, (Ptr{Void}, Int32), STDIN.handle, mode) != 0
695         throw("FATAL: Terminal unable to enter raw mode.")
696     end
697 end
698
699 function getKey()
700     raw_mode!(true)
701     byte = readbytes(STDIN, 1)[1]
702     raw_mode!(false)
703
704     if byte == 0x0d
705         return 0x0a
706     elseif byte == 127
707         return 0x08
708     else
709         return byte
710     end
711 end
712
713 KEY_CFA = defPrimWord("KEY", () -> begin
714     pushPS(Int(getKey()))
715     return NEXT
716 end)
717
718 function getLineFromSTDIN()
719
720     function getFrag(s)
721         chars = collect(s)
722         slashIdx = findlast(chars, '\\')
723
724         if slashIdx > 0
725             return join(chars[slashIdx:length(chars)])
726         else
727             return nothing
728         end
729     end
730
731     function backspaceStr(s, bsCount)
732         oldLen = length(s)
733         newLen = max(0, oldLen - bsCount)
734         return join(collect(s)[1:newLen])
735     end
736
737     line = ""
738     while true
739         key = Char(getKey())
740
741         if key == '\n'
742             print(" ")
743             return AbstractString(line)
744
745         elseif key == '\x04'
746             if isempty(line)
747                 return string("\x04")
748             end
749
750         elseif key == '\b'
751             if !isempty(line)
752                 print("\b\033[K")
753                 line = backspaceStr(line, 1)
754             end
755
756         elseif key == '\e'
757             # Strip ANSI escape sequence
758             nextKey = Char(getKey())
759             if nextKey == '['
760                 while true
761                     nextKey = Char(getKey())
762                     if nextKey >= '@' || nextKey <= '~'
763                         break
764                     end
765                 end
766             end
767
768         elseif key == '\t'
769             # Currently do nothing
770
771             frag = getFrag(line)
772             if frag != nothing
773                 if haskey(REPLCompletions.latex_symbols, frag)
774                     print(repeat("\b", length(frag)))
775                     print("\033[K")
776                     comp = REPLCompletions.latex_symbols[frag]
777                     line = string(backspaceStr(line, length(frag)), comp)
778                     print(comp)
779                 end
780             end
781
782         else
783             print(key)
784             line = string(line, key)
785         end
786     end
787 end
788
789 SPAN, SPAN_CFA = defNewVar("SPAN", 0)
790 EXPECT_CFA = defPrimWord("EXPECT", () -> begin
791     maxLen = popPS()
792     addr = popPS()
793
794     line = getLineFromSTDIN()
795
796     mem[SPAN] = min(length(line), maxLen)
797     putString(line, addr, maxLen)
798
799     return NEXT
800 end)
801
802 BASE, BASE_CFA = defNewVar("BASE", 10)
803 NUMBER_CFA = defPrimWord("NUMBER", () -> begin
804     wordAddr = popPS()+1
805     wordLen = mem[wordAddr-1]
806
807     s = getString(wordAddr, wordLen)
808
809     pushPS(parse(Int64, s, mem[BASE]))
810
811     return NEXT
812 end)
813
814 # Dictionary searches
815
816 FROMLINK_CFA = defPrimWord("LINK>", () -> begin
817
818     addr = popPS()
819     lenAndFlags = mem[addr+1]
820     len = lenAndFlags & F_LENMASK
821
822     pushPS(addr + 2 + len)
823
824     return NEXT
825 end)
826
827 NUMCONTEXT, NUMCONTEXT_CFA = defNewVar("#CONTEXT", 1)
828
829 createHeader("FORTH", 0)
830 FORTH_CFA = mem[H]
831 dictWrite(defPrim(() -> begin
832     mem[CONTEXT + mem[NUMCONTEXT] - 1] = reg.W
833     return NEXT
834 end, name="FORTH"))
835 dictWrite(0) # cell for latest
836
837 CURRENT_CFA = defExistingVar("CURRENT", CURRENT)
838
839 # Switch to new FORTH vocabulary cfa
840 mem[FORTH_CFA+1] = mem[mem[CURRENT]+1]
841 mem[CURRENT] = FORTH_CFA
842
843 CONTEXT, CONTEXT_CFA = defNewVar("CONTEXT", zeros(Int64, 10))
844 mem[CONTEXT] = FORTH_CFA
845
846 FINDVOCAB_CFA = defPrimWord("FINDVOCAB", () -> begin
847     vocabCFA = popPS()
848     countedAddr = popPS()
849
850     wordAddr = countedAddr + 1
851     wordLen = mem[countedAddr]
852     word = lowercase(getString(wordAddr, wordLen))
853
854     lfa = vocabCFA+1
855     lenAndFlags = 0
856
857     while (lfa = mem[lfa]) > 0
858
859         lenAndFlags = mem[lfa+1]
860         len = lenAndFlags & F_LENMASK
861         hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN
862
863         if hidden || len != wordLen
864             continue
865         end
866
867         thisWord = lowercase(getString(lfa+2, len))
868
869         if thisWord == word
870             break
871         end
872     end
873
874     if lfa > 0
875         pushPS(lfa)
876         callPrim(mem[FROMLINK_CFA])
877         if (lenAndFlags & F_IMMED) == F_IMMED
878             pushPS(1)
879         else
880             pushPS(-1)
881         end
882     else
883         pushPS(countedAddr)
884         pushPS(0)
885     end
886
887     return NEXT
888 end)
889
890 FIND_CFA = defPrimWord("FIND", () -> begin
891
892     countedAddr = popPS()
893     context = mem[CONTEXT:(CONTEXT+mem[NUMCONTEXT]-1)]
894
895     for vocabCFA in reverse(context)
896         pushPS(countedAddr)
897         pushPS(vocabCFA)
898         callPrim(mem[FINDVOCAB_CFA])
899
900         callPrim(mem[DUP_CFA])
901         if popPS() != 0
902             return NEXT
903         else
904             popPS()
905             popPS()
906         end
907     end
908
909     pushPS(countedAddr)
910     pushPS(0)
911
912     return NEXT
913 end)
914
915
916 # Branching
917
918 BRANCH_CFA = defPrimWord("BRANCH", () -> begin
919     reg.IP += mem[reg.IP]
920     return NEXT
921 end)
922
923 ZBRANCH_CFA = defPrimWord("0BRANCH", () -> begin
924     if (popPS() == 0)
925         reg.IP += mem[reg.IP]
926     else
927         reg.IP += 1
928     end
929
930     return NEXT
931 end)
932
933 # Strings
934
935 LITSTRING_CFA = defPrimWord("LITSTRING", () -> begin
936     len = mem[reg.IP]
937     reg.IP += 1
938     pushPS(reg.IP)
939     pushPS(len)
940     reg.IP += len
941
942     return NEXT
943 end)
944
945 TYPE_CFA = defPrimWord("TYPE", () -> begin
946     len = popPS()
947     addr = popPS()
948     str = getString(addr, len)
949     print(str)
950     return NEXT
951 end)
952
953 # Interpreter/Compiler-specific I/O
954
955 TIB_CFA = defConst("TIB", TIB)
956 NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0)
957
958 FIB_CFA = defConst("FIB", TIB)
959 NUMFIB, NUMFIB_CFA = defNewVar("#FIB", 0)
960
961 TOIN, TOIN_CFA = defNewVar(">IN", 0)
962
963 SOURCE_ID, SOURCE_ID_CFA = defNewVar("SOURCE-ID", 0)
964
965 SOURCE_CFA = defPrimWord("SOURCE", () -> begin
966     if mem[SOURCE_ID] == 0
967         pushPS(TIB)
968         pushPS(NUMTIB)
969     else
970         pushPS(FIB)
971         pushPS(NUMFIB)
972     end
973     return NEXT
974 end)
975
976 QUERY_CFA = defWord("QUERY",
977     [TIB_CFA, LIT_CFA, 160, EXPECT_CFA,
978     SPAN_CFA, FETCH_CFA, NUMTIB_CFA, STORE_CFA,
979     LIT_CFA, 0, TOIN_CFA, STORE_CFA,
980     EXIT_CFA])
981
982 QUERY_FILE_CFA = defWord("QUERY-FILE",
983     [FIB_CFA, LIT_CFA, 160, ROT_CFA, READ_LINE_CFA,
984     DROP_CFA, SWAP_CFA,
985     NUMFIB_CFA, STORE_CFA,
986     EXIT_CFA])
987
988 WORD_CFA = defPrimWord("WORD", () -> begin
989     delim = popPS()
990
991     callPrim(mem[SOURCE_CFA])
992     sizeAddr = popPS()
993     bufferAddr = popPS()
994
995     # Chew up initial occurrences of delim
996     while (mem[TOIN]<mem[sizeAddr] && mem[bufferAddr+mem[TOIN]] == delim)
997         mem[TOIN] += 1
998     end
999
1000     countAddr = mem[H]
1001     addr = mem[H]+1
1002
1003     # Start reading in word
1004     count = 0
1005     while (mem[TOIN]<mem[sizeAddr])
1006         mem[addr] = mem[bufferAddr+mem[TOIN]]
1007         mem[TOIN] += 1
1008
1009         if (mem[addr] == delim)
1010             break
1011         end
1012
1013         count += 1
1014         addr += 1
1015     end
1016
1017     # Record count
1018     mem[countAddr] = count
1019     pushPS(countAddr)
1020
1021     return NEXT
1022 end)
1023
1024 # Compilation
1025
1026 STATE, STATE_CFA = defNewVar("STATE", 0)
1027
1028 COMMA_CFA = defPrimWord(",", () -> begin
1029     mem[mem[H]] = popPS()
1030     mem[H] += 1
1031
1032     return NEXT
1033 end)
1034
1035 HERE_CFA = defWord("HERE",
1036     [H_CFA, FETCH_CFA, EXIT_CFA])
1037
1038 HEADER_CFA = defPrimWord("HEADER", () -> begin
1039     wordAddr = popPS()+1
1040     wordLen = mem[wordAddr-1]
1041     word = getString(wordAddr, wordLen)
1042
1043     createHeader(word, 0)
1044
1045     return NEXT
1046 end)
1047
1048 CREATE_CFA = defWord("CREATE",
1049     [LIT_CFA, 32, WORD_CFA, HEADER_CFA,
1050     LIT_CFA, DOVAR, COMMA_CFA,
1051     EXIT_CFA])
1052
1053 DODOES = defPrim(() -> begin
1054     pushRS(reg.IP)
1055     reg.IP = popPS()
1056     pushPS(reg.W + 1)
1057     return NEXT
1058 end, name="DODOES")
1059
1060 DOES_HELPER_CFA = defPrimWord("(DOES>)", () -> begin
1061
1062     pushPS(mem[mem[CURRENT]+1])
1063     callPrim(mem[FROMLINK_CFA])
1064     cfa = popPS()
1065
1066     runtimeAddr = popPS()
1067
1068     mem[cfa] = defPrim(eval(:(() -> begin
1069         pushPS($(runtimeAddr))
1070         return DODOES
1071     end)), name="doesPrim")
1072
1073     return NEXT
1074 end, flags=F_IMMED | F_HIDDEN)
1075
1076 DOES_CFA = defWord("DOES>",
1077     [LIT_CFA, LIT_CFA, COMMA_CFA, HERE_CFA, LIT_CFA, 3, ADD_CFA, COMMA_CFA,
1078     LIT_CFA, DOES_HELPER_CFA, COMMA_CFA, LIT_CFA, EXIT_CFA, COMMA_CFA, EXIT_CFA],
1079     flags=F_IMMED)
1080
1081 LBRAC_CFA = defPrimWord("[", () -> begin
1082     mem[STATE] = 0
1083     return NEXT
1084 end, flags=F_IMMED)
1085
1086 RBRAC_CFA = defPrimWord("]", () -> begin
1087     mem[STATE] = 1
1088     return NEXT
1089 end, flags=F_IMMED)
1090
1091 HIDDEN_CFA = defPrimWord("HIDDEN", () -> begin
1092     lenAndFlagsAddr = mem[mem[CURRENT]+1] + 1
1093     mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_HIDDEN
1094     return NEXT
1095 end)
1096
1097 COLON_CFA = defWord(":",
1098     [LIT_CFA, 32, WORD_CFA,
1099     HEADER_CFA,
1100     LIT_CFA, DOCOL, COMMA_CFA,
1101     HIDDEN_CFA,
1102     RBRAC_CFA,
1103     EXIT_CFA])
1104
1105 SEMICOLON_CFA = defWord(";",
1106     [LIT_CFA, EXIT_CFA, COMMA_CFA,
1107     HIDDEN_CFA,
1108     LBRAC_CFA,
1109     EXIT_CFA], flags=F_IMMED)
1110
1111 IMMEDIATE_CFA = defPrimWord("IMMEDIATE", () -> begin
1112     lenAndFlagsAddr = mem[mem[CURRENT]+1] + 1
1113     mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED
1114     return NEXT
1115 end, flags=F_IMMED)
1116
1117 CODE_CFA = defPrimWord("CODE", () -> begin
1118     pushPS(32)
1119     callPrim(mem[WORD_CFA])
1120     callPrim(mem[HEADER_CFA])
1121
1122     exprString = "() -> begin\n"
1123     while true
1124         if mem[TOIN] >= mem[NUMTIB]
1125             exprString = string(exprString, "\n")
1126             if currentSource() == STDIN
1127                 println()
1128             end
1129
1130             pushPS(TIB)
1131             pushPS(160)
1132             callPrim(mem[EXPECT_CFA])
1133             mem[NUMTIB] = mem[SPAN]
1134             mem[TOIN] = 0
1135         end
1136
1137         pushPS(32)
1138         callPrim(mem[WORD_CFA])
1139         cAddr = popPS()
1140         thisWord = getString(cAddr+1, mem[cAddr])
1141
1142         if uppercase(thisWord) == "END-CODE"
1143             break
1144         end
1145
1146         exprString = string(exprString, " ", thisWord)
1147     end
1148     exprString = string(exprString, "\nreturn NEXT\nend")
1149
1150     func = eval(parse(exprString))
1151     dictWrite(defPrim(func))
1152
1153     return NEXT
1154 end)
1155
1156 # Outer Interpreter
1157
1158 EXECUTE_CFA = defPrimWord("EXECUTE", () -> begin
1159     reg.W = popPS()
1160     return mem[reg.W]
1161 end)
1162
1163 INTERPRET_CFA = defWord("INTERPRET",
1164     [LIT_CFA, 32, WORD_CFA, # Read next space-delimited word
1165
1166     DUP_CFA, FETCH_CFA, ZE_CFA, ZBRANCH_CFA, 3,
1167         DROP_CFA, EXIT_CFA, # Exit if input buffer is exhausted
1168
1169     STATE_CFA, FETCH_CFA, ZBRANCH_CFA, 24,
1170         # Compiling
1171         FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 13,
1172
1173             # Found word. 
1174             LIT_CFA, -1, EQ_CFA, INVERT_CFA, ZBRANCH_CFA, 4,
1175
1176                 # Immediate: Execute!
1177                 EXECUTE_CFA, BRANCH_CFA, -26,
1178
1179                 # Not immediate: Compile!
1180                 COMMA_CFA, BRANCH_CFA, -29,
1181
1182             # No word found, parse number
1183             NUMBER_CFA, LIT_CFA, LIT_CFA, COMMA_CFA, COMMA_CFA, BRANCH_CFA, -36,
1184         
1185        # Interpreting
1186         FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 5,
1187
1188             # Found word. Execute!
1189             DROP_CFA, EXECUTE_CFA, BRANCH_CFA, -44,
1190
1191             # No word found, parse number and leave on stack
1192             NUMBER_CFA, BRANCH_CFA, -47,
1193     EXIT_CFA])
1194
1195 PROMPT_CFA = defPrimWord("PROMPT", () -> begin
1196     if mem[STATE] == 0
1197         print(" ok")
1198     end
1199     println()
1200
1201     return NEXT
1202 end)
1203
1204 QUIT_CFA = defWord("QUIT",
1205     [LIT_CFA, 0, STATE_CFA, STORE_CFA,
1206     LIT_CFA, 0, NUMTIB_CFA, STORE_CFA,
1207     RSP0_CFA, RSPSTORE_CFA,
1208     QUERY_CFA,
1209     INTERPRET_CFA, PROMPT_CFA,
1210     BRANCH_CFA,-4])
1211
1212 INTERPRET_CFA = defWord("INTERPRET",
1213     [SOURCE_ID_CFA, FETCH_CFA, TOR_CFA, # Store current source on return stack
1214
1215     LIT_CFA, 32, WORD_CFA, # Read next word from current input source
1216
1217     FAM_RO_CFA, OPEN_FILE_CFA, DROP_CFA, # Open the file named by this word.
1218
1219     DUP_CFA, SOURCE_ID_CFA, STORE_CFA, # Mark this as the current source
1220
1221     DUP_CFA, QUERY_FILE_CFA, # Read line from file
1222
1223     INTERPRET_CFA,
1224
1225     BRANCH_CFA, -4])
1226
1227
1228 ABORT_CFA = defWord("ABORT",
1229     [CLOSE_FILES_CFA, PSP0_CFA, PSPSTORE_CFA, QUIT_CFA])
1230
1231 BYE_CFA = defPrimWord("BYE", () -> begin
1232     println("\nBye!")
1233     return 0
1234 end)
1235
1236 EOF_CFA = defPrimWord("\x04", () -> begin
1237     return 0
1238 end)
1239
1240 #### VM loop ####
1241
1242 initialized = false
1243 initFileName = nothing
1244 if isfile("lib.4th")
1245     initFileName = "lib.4th"
1246 elseif isfile(Pkg.dir("forth","src", "lib.4th"))
1247     initFileName = Pkg.dir("forth","src","lib.4th")
1248 end
1249
1250 function run(;initialize=true)
1251
1252     # Start with IP pointing to first instruction of outer interpreter
1253     pushRS(QUIT_CFA+1)
1254
1255     # Load library files
1256     global initialized, initFileName
1257     if !initialized && initialize
1258         if initFileName != nothing
1259             print("Including definitions from $initFileName...")
1260
1261             # TODO
1262
1263             initialized = true
1264         else
1265             println("No library file found. Only primitive words available.")
1266         end
1267     end
1268
1269
1270     # Primitive processing loop.
1271     # Everyting else is simply a consequence of this loop!
1272     jmp = mem[EXIT_CFA]
1273     while jmp != 0
1274         try
1275             #println("Entering prim $(getPrimName(jmp))")
1276             jmp = callPrim(jmp)
1277
1278         catch ex
1279             showerror(STDOUT, ex)
1280             println()
1281
1282             # QUIT
1283             reg.IP = ABORT_CFA + 1
1284             jmp = NEXT
1285         end
1286     end
1287 end
1288
1289 # Debugging tools
1290
1291 TRACE_CFA = defPrimWord("TRACE", () -> begin
1292     println("reg.W: $(reg.W) reg.IP: $(reg.IP)")
1293     print("PS: "); printPS()
1294     print("RS: "); printRS()
1295     print("[paused]")
1296     readline()
1297
1298     return NEXT
1299 end)
1300
1301 function dump(startAddr::Int64; count::Int64 = 100, cellsPerLine::Int64 = 10)
1302     chars = Array{Char,1}(cellsPerLine)
1303
1304     lineStartAddr = cellsPerLine*div((startAddr-1),cellsPerLine) + 1
1305     endAddr = startAddr + count - 1
1306
1307     q, r = divrem((endAddr-lineStartAddr+1), cellsPerLine)
1308     numLines = q + (r > 0 ? 1 : 0)
1309
1310     i = lineStartAddr
1311     for l in 1:numLines
1312         print(i,":")
1313
1314         for c in 1:cellsPerLine
1315             if i >= startAddr && i <= endAddr
1316                 print("\t",mem[i])
1317                 if mem[i]>=32 && mem[i]<128
1318                     chars[c] = Char(mem[i])
1319                 else
1320                     chars[c] = '.'
1321                 end
1322             else
1323                 print("\t")
1324                 chars[c] = ' '
1325             end
1326
1327             i += 1
1328         end
1329
1330         println("\t", AbstractString(chars))
1331     end
1332 end
1333
1334 function printPS()
1335     count = reg.PSP - PSP0
1336
1337     if count > 0
1338         print("<$count>")
1339         for i in (PSP0+1):reg.PSP
1340             print(" $(mem[i])")
1341         end
1342         println()
1343     else
1344         println("Parameter stack empty")
1345     end
1346 end
1347
1348 function printRS()
1349     count = reg.RSP - RSP0
1350
1351     if count > 0
1352         print("<$count>")
1353         for i in (RSP0+1):reg.RSP
1354             print(" $(mem[i])")
1355         end
1356         println()
1357     else
1358         println("Return stack empty")
1359     end
1360 end
1361
1362 DUMP = defPrimWord("DUMP", () -> begin
1363     count = popPS()
1364     addr = popPS()
1365
1366     println()
1367     dump(addr, count=count)
1368
1369     return NEXT
1370 end)
1371
1372 end