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