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