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