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