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