src/forth.jl

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