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