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