Fixed bug in FIND.
[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 # Handy functions for adding/retrieving strings to/from memory.
105
106 getString(addr::Int64, len::Int64) = ASCIIString([Char(c) for c in mem[addr:(addr+len-1)]])
107 function putString(str::ASCIIString, addr::Int64)
108     mem[addr:(addr+length(str)-1)] = [Int64(c) for c in str]
109 end
110
111 # Primitive creation and calling functions
112
113 function createHeader(name::AbstractString, flags::Int64)
114     mem[mem[HERE]] = mem[LATEST]
115     mem[LATEST] = mem[HERE]
116     mem[HERE] += 1
117
118     mem[mem[HERE]] = length(name) | flags; mem[HERE] += 1
119     putString(name, mem[HERE]); mem[HERE] += length(name)
120 end
121
122 function defPrim(name::AbstractString, f::Function; flags::Int64=0)
123     createHeader(name, flags)
124
125     codeWordAddr = mem[HERE]
126     push!(primitives, f)
127     mem[codeWordAddr] = -length(primitives)
128     mem[HERE] += 1
129
130     return codeWordAddr
131 end
132
133 callPrim(addr::Int64) = primitives[-addr]()
134
135 function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0)
136     defPrim(name, eval(:(() -> begin
137         pushPS($(varAddr))
138         return mem[NEXT]
139     end)))
140 end
141
142 function defNewVar(name::AbstractString, initial::Int64; flags::Int64=0)
143     createHeader(name, flags)
144     
145     varAddr = mem[HERE] + 1
146     push!(primitives, eval(:(() -> begin
147         pushPS($(varAddr))
148         return mem[NEXT]
149     end)))
150     mem[mem[HERE]] = -length(primitives); mem[HERE] += 1
151
152     mem[mem[HERE]] = initial; mem[HERE] += 1
153
154     return varAddr
155 end
156
157 function defConst(name::AbstractString, val::Int64; flags::Int64=0)
158     defPrim(name, eval(:(() -> begin
159         pushPS($(val))
160         return mem[NEXT]
161     end)))
162
163     return val
164 end
165
166 function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0)
167     createHeader(name, flags)
168
169     addr = mem[HERE]
170     mem[mem[HERE]] = mem[DOCOL]
171     mem[HERE] += 1
172
173     for wordAddr in wordAddrs
174         mem[mem[HERE]] = wordAddr
175         mem[HERE] += 1
176     end
177
178     return addr
179 end
180
181 # Threading Primitives (inner interpreter)
182
183 NEXT = defPrim("NEXT", () -> begin
184     reg.W = mem[reg.IP]
185     reg.IP += 1
186     return mem[reg.W]
187 end)
188
189 DOCOL = defPrim("DOCOL", () -> begin
190     pushRS(reg.IP)
191     reg.IP = reg.W + 1
192     return mem[NEXT]
193 end)
194
195 EXIT = defPrim("EXIT", () -> begin
196     reg.IP = popRS()
197     return mem[NEXT]
198 end)
199
200 # Basic forth primitives
201
202 DROP = defPrim("DROP", () -> begin
203     popPS()
204     return mem[NEXT]
205 end)
206
207 SWAP = defPrim("SWAP", () -> begin
208     a = popPS()
209     b = popPS()
210     pushPS(a)
211     pushPS(b)
212     return mem[NEXT]
213 end)
214
215 DUP = defPrim("DUP", () -> begin
216     pushPS(mem[reg.PSP])
217     return mem[NEXT]
218 end)
219
220 OVER = defPrim("OVER", () -> begin
221     ensurePSDepth(2)
222     pushPS(mem[reg.PSP-1])
223     return mem[NEXT]
224 end)
225
226 ROT = defPrim("ROT", () -> begin
227     a = popPS()
228     b = popPS()
229     c = popPS()
230     pushPS(a)
231     pushPS(c)
232     pushPS(b)
233     return mem[NEXT]
234 end)
235
236 NROT = defPrim("-ROT", () -> begin
237     a = popPS()
238     b = popPS()
239     c = popPS()
240     pushPS(b)
241     pushPS(a)
242     pushPS(c)
243     return mem[NEXT]
244 end)
245
246 TWODROP = defPrim("2DROP", () -> begin
247     popPS()
248     popPS()
249     return mem[NEXT]
250 end)
251
252 TWODUP = defPrim("2DUP", () -> begin
253     ensurePSDepth(2)
254     a = mem[reg.PSP-1]
255     b = mem[reg.PSP]
256     pushPS(a)
257     pushPS(b)
258     return mem[NEXT]
259 end)
260
261 TWOSWAP = defPrim("2SWAP", () -> begin
262     a = popPS()
263     b = popPS()
264     c = popPS()
265     d = popPS()
266     pushPS(b)
267     pushPS(a)
268     pushPS(c)
269     pushPS(d)
270     return mem[NEXT]
271 end)
272
273 QDUP = defPrim("?DUP", () -> begin
274     ensurePSDepth(1)
275     val = mem[reg.PSP]
276     if val != 0
277         pushPS(val)
278     end
279     return mem[NEXT]
280 end)
281
282 INCR = defPrim("1+", () -> begin
283     ensurePSDepth(1)
284     mem[reg.PSP] += 1
285     return mem[NEXT]
286 end)
287
288 DECR = defPrim("1-", () -> begin
289     ensurePSDepth(1)
290     mem[reg.PSP] -= 1
291     return mem[NEXT]
292 end)
293
294 INCR2 = defPrim("2+", () -> begin
295     ensurePSDepth(1)
296     mem[reg.PSP] += 2
297     return mem[NEXT]
298 end)
299
300 DECR2 = defPrim("2-", () -> begin
301     ensurePSDepth(1)
302     mem[reg.PSP] -= 2
303     return mem[NEXT]
304 end)
305
306 ADD = defPrim("+", () -> begin
307     b = popPS()
308     a = popPS()
309     pushPS(a+b)
310     return mem[NEXT]
311 end)
312
313 SUB = defPrim("-", () -> begin
314     b = popPS()
315     a = popPS()
316     pushPS(a-b)
317     return mem[NEXT]
318 end)
319
320 MUL = defPrim("*", () -> begin
321     b = popPS()
322     a = popPS()
323     pushPS(a*b)
324     return mem[NEXT]
325 end)
326
327 DIVMOD = defPrim("/MOD", () -> begin
328     b = popPS()
329     a = popPS()
330     q,r = divrem(a,b)
331     pushPS(r)
332     pushPS(q)
333     return mem[NEXT]
334 end)
335
336 EQU = defPrim("=", () -> begin
337     b = popPS()
338     a = popPS()
339     pushPS(a==b ? -1 : 0)
340     return mem[NEXT]
341 end)
342
343 NEQU = defPrim("<>", () -> begin
344     b = popPS()
345     a = popPS()
346     pushPS(a!=b ? -1 : 0)
347     return mem[NEXT]
348 end)
349
350 LT = defPrim("<", () -> begin
351     b = popPS()
352     a = popPS()
353     pushPS(a<b ? -1 : 0)
354     return mem[NEXT]
355 end)
356
357 GT = defPrim(">", () -> begin
358     b = popPS()
359     a = popPS()
360     pushPS(a>b ? -1 : 0)
361     return mem[NEXT]
362 end)
363
364 LE = defPrim("<=", () -> begin
365     b = popPS()
366     a = popPS()
367     pushPS(a<=b ? -1 : 0)
368     return mem[NEXT]
369 end)
370
371 GE = defPrim(">=", () -> begin
372     b = popPS()
373     a = popPS()
374     pushPS(a>=b ? -1 : 0)
375     return mem[NEXT]
376 end)
377
378 ZEQU = defPrim("0=", () -> begin
379     pushPS(popPS() == 0 ? -1 : 0)
380     return mem[NEXT]
381 end)
382
383 ZNEQU = defPrim("0<>", () -> begin
384     pushPS(popPS() != 0 ? -1 : 0)
385     return mem[NEXT]
386 end)
387
388 ZLT = defPrim("0<", () -> begin
389     pushPS(popPS() < 0 ? -1 : 0)
390     return mem[NEXT]
391 end)
392
393 ZGT = defPrim("0>", () -> begin
394     pushPS(popPS() > 0 ? -1 : 0)
395     return mem[NEXT]
396 end)
397
398 ZLE = defPrim("0<=", () -> begin
399     pushPS(popPS() <= 0 ? -1 : 0)
400     return mem[NEXT]
401 end)
402
403 ZGE = defPrim("0>=", () -> begin
404     pushPS(popPS() >= 0 ? -1 : 0)
405     return mem[NEXT]
406 end)
407
408 AND = defPrim("AND", () -> begin
409     b = popPS()
410     a = popPS()
411     pushPS(a & b)
412     return mem[NEXT]
413 end)
414
415 OR = defPrim("OR", () -> begin
416     b = popPS()
417     a = popPS()
418     pushPS(a | b)
419     return mem[NEXT]
420 end)
421
422 XOR = defPrim("XOR", () -> begin
423     b = popPS()
424     a = popPS()
425     pushPS(a $ b)
426     return mem[NEXT]
427 end)
428
429 INVERT = defPrim("INVERT", () -> begin
430     pushPS(~popPS())
431     return mem[NEXT]
432 end)
433
434 # Literals
435
436 LIT = defPrim("LIT", () -> begin
437     pushPS(mem[reg.IP])
438     reg.IP += 1
439     return mem[NEXT]
440 end)
441
442 # Memory primitives
443
444 STORE = defPrim("!", () -> begin
445     addr = popPS()
446     dat = popPS()
447     mem[addr] = dat
448     return mem[NEXT]
449 end)
450
451 FETCH = defPrim("@", () -> begin
452     addr = popPS()
453     pushPS(mem[addr])
454     return mem[NEXT]
455 end)
456
457 ADDSTORE = defPrim("+!", () -> begin
458     addr = popPS()
459     toAdd = popPS()
460     mem[addr] += toAdd
461     return mem[NEXT]
462 end)
463
464 SUBSTORE = defPrim("-!", () -> begin
465     addr = popPS()
466     toSub = popPS()
467     mem[addr] -= toSub
468     return mem[NEXT]
469 end)
470
471
472 # Built-in variables
473
474 defExistingVar("HERE", HERE)
475 defExistingVar("LATEST", LATEST)
476 defExistingVar("PSP0", PSP0)
477 defExistingVar("RSP0", RSP0)
478 STATE = defNewVar("STATE", 0)
479 BASE = defNewVar("BASE", 10)
480
481 # Constants
482
483 defConst("VERSION", 1)
484 defConst("DOCOL", DOCOL)
485 defConst("DICT", DICT)
486 F_IMMED = defConst("F_IMMED", 128)
487 F_HIDDEN = defConst("F_HIDDEN", 256)
488 F_LENMASK = defConst("F_LENMASK", 127)
489
490 # Return Stack
491
492 TOR = defPrim(">R", () -> begin
493     pushRS(popPS())
494     return mem[NEXT]
495 end)
496
497 FROMR = defPrim("R>", () -> begin
498     pushPS(popRS())
499     return mem[NEXT]
500 end)
501
502 RSPFETCH = defPrim("RSP@", () -> begin
503     pushPS(reg.RSP)
504     return mem[NEXT]
505 end)
506
507 RSPSTORE = defPrim("RSP!", () -> begin
508     RSP = popPS()
509     return mem[NEXT]
510 end)
511
512 RDROP = defPrim("RDROP", () -> begin
513     popRS()
514     return mem[NEXT]
515 end)
516
517 # Parameter Stack
518
519 PSPFETCH = defPrim("PSP@", () -> begin
520     pushPS(reg.PSP)
521     return mem[NEXT]
522 end)
523
524 PSPSTORE = defPrim("PSP!", () -> begin
525     PSP = popPS()
526     return mem[NEXT]
527 end)
528
529 # I/O
530
531 defConst("TIB", TIB)
532 NUMTIB = defNewVar("#TIB", 0)
533 TOIN = defNewVar(">IN", 0)
534
535 KEY = defPrim("KEY", () -> begin
536     if mem[TOIN] >= mem[NUMTIB]
537         mem[TOIN] = 0
538         line = readline()
539         mem[NUMTIB] = length(line)
540         putString(line, TIB)
541     end
542
543     pushPS(mem[TIB + mem[TOIN]])
544     mem[TOIN] += 1
545
546     return mem[NEXT]
547 end)
548
549 EMIT = defPrim("EMIT", () -> begin
550     print(Char(popPS()))
551     return mem[NEXT]
552 end)
553
554 WORD = defPrim("WORD", () -> begin
555     
556     c = -1
557
558     skip_to_end = false
559     while true
560
561         callPrim(mem[KEY])
562         c = Char(popPS())
563
564         if c == '\\'
565             skip_to_end = true
566             continue
567         end
568
569         if skip_to_end
570             if c == '\n'
571                 skip_to_end = false
572             end
573             continue
574         end
575
576         if c == ' ' || c == '\t'
577             continue
578         end
579
580         break
581     end
582
583     wordAddr = mem[HERE]
584     offset = 0
585
586     while true
587         mem[wordAddr + offset] = Int64(c)
588         offset += 1
589
590         callPrim(mem[KEY])
591         c = Char(popPS())
592
593         if c == ' ' || c == '\t' || c == '\n'
594             break
595         end
596     end
597
598     wordLen = offset
599
600     pushPS(wordAddr)
601     pushPS(wordLen)
602
603     return mem[NEXT]
604 end)
605
606 NUMBER = defPrim("NUMBER", () -> begin
607
608     wordLen = popPS()
609     wordAddr = popPS()
610
611     s = getString(wordAddr, wordLen)
612
613     try
614         pushPS(parse(Int64, s, mem[BASE]))
615         pushPS(0)
616     catch
617         pushPS(1) # Error indication
618     end
619
620     return mem[NEXT]
621 end)
622
623 # Dictionary searches
624
625 FIND = defPrim("FIND", () -> begin
626
627     wordLen = popPS()
628     wordAddr = popPS()
629     word = getString(wordAddr, wordLen)
630
631     latest = LATEST
632     
633     i = 0
634     while (latest = mem[latest]) > 0
635         lenAndFlags = mem[latest+1]
636         len = lenAndFlags & F_LENMASK
637         hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN
638
639         if hidden || len != wordLen
640             continue
641         end
642         
643         thisAddr = latest+2
644         thisWord = getString(thisAddr, len)
645
646         if thisWord == word
647             break
648         end
649     end
650
651     pushPS(latest)
652
653     return mem[NEXT]
654 end)
655
656 TOCFA = defPrim(">CFA", () -> begin
657
658     addr = popPS()
659     lenAndFlags = mem[addr+1]
660     len = lenAndFlags & F_LENMASK
661
662     pushPS(addr + 2 + len)
663
664     return mem[NEXT]
665 end)
666
667 TODFA = defWord(">DFA", [TOCFA, INCR, EXIT])
668
669 # Compilation
670
671 CREATE = defPrim("CREATE", () -> begin
672
673     wordLen = popPS()
674     wordAddr = popPS()
675     word = getString(wordAddr, wordLen)
676
677     createHeader(word, 0)
678
679     return mem[NEXT]
680 end)
681
682 COMMA = defPrim(",", () -> begin
683     mem[mem[HERE]] = popPS()
684     mem[HERE] += 1
685
686     return mem[NEXT]
687 end)
688
689 LBRAC = defPrim("[", () -> begin
690     mem[STATE] = 0
691     return mem[NEXT]
692 end, flags=F_IMMED)
693
694 RBRAC = defPrim("]", () -> begin
695     mem[STATE] = 1
696     return mem[NEXT]
697 end, flags=F_IMMED)
698
699 HIDDEN = defPrim("HIDDEN", () -> begin
700     addr = popPS() + 1
701     mem[addr] = mem[addr] $ F_HIDDEN
702     return mem[NEXT]
703 end)
704
705 HIDE = defWord("HIDE",
706     [WORD,
707     FIND,
708     HIDDEN,
709     EXIT])
710
711 COLON = defWord(":",
712     [WORD,
713     CREATE,
714     LIT, DOCOL, COMMA,
715     LATEST, FETCH, HIDDEN,
716     RBRAC,
717     EXIT])
718
719 SEMICOLON = defWord(";",
720     [LIT, EXIT, COMMA,
721     LATEST, FETCH, HIDDEN,
722     LBRAC,
723     EXIT], flags=F_IMMED)
724
725 IMMEDIATE = defPrim("IMMEDIATE", () -> begin
726     lenAndFlagsAddr = mem[LATEST] + 1
727     mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED
728     return mem[NEXT]
729 end, flags=F_IMMED)
730
731 TICK = defWord("'", [WORD, FIND, TOCFA, EXIT])
732
733 # Branching
734
735 BRANCH = defPrim("BRANCH", () -> begin
736     reg.IP += mem[reg.IP]
737     return mem[NEXT]
738 end)
739
740 ZBRANCH = defPrim("0BRANCH", () -> begin
741     if (popPS() == 0)
742         reg.IP += mem[reg.IP]
743     else
744         reg.IP += 1
745     end
746
747     return mem[NEXT]
748 end)
749
750 # Strings
751
752 LITSTRING = defPrim("LITSTRING", () -> begin
753     len = mem[reg.IP]
754     reg.IP += 1
755     pushPS(reg.IP)
756     pushPS(len)
757     reg.IP += len
758
759     return mem[NEXT]
760 end)
761
762 #### VM loop ####
763 function runVM()
764     jmp = mem[NEXT]
765     while (jmp = callPrim(jmp)) != 0 end
766 end
767
768 # Debugging tools
769
770 function dump(startAddr::Int64; count::Int64 = 100, cellsPerLine::Int64 = 10)
771     chars = Array{Char,1}(cellsPerLine)
772
773     for i in 0:(count-1)
774         addr = startAddr + i
775         if i%cellsPerLine == 0
776             print("$addr:")
777         end
778
779         print("\t$(mem[addr]) ")
780
781         if (mem[addr]>=32 && mem[addr]<128)
782             chars[i%cellsPerLine + 1] = Char(mem[addr])
783         else
784             chars[i%cellsPerLine + 1] = '.'
785         end
786
787         if i%cellsPerLine == cellsPerLine-1
788             println(string("\t", ASCIIString(chars)))
789         end
790     end
791 end
792
793 function printPS()
794     count = reg.PSP - mem[PSP0]
795
796     if count > 0
797         print("<$count>")
798         for i in (mem[PSP0]+1):reg.PSP
799             print(" $(mem[i])")
800         end
801         println()
802     else
803         println("Parameter stack empty")
804     end
805 end
806
807 function printRS()
808     count = reg.RSP - mem[RSP0]
809
810     if count > 0
811         print("<$count>")
812         for i in (mem[RSP0]+1):reg.RSP
813             print(" $(mem[i])")
814         end
815         println()
816     else
817         println("Return stack empty")
818     end
819 end
820
821 end