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