src/forth.jl

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