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("VERSION", 1)
 527 defConst("DOCOL", DOCOL)
 528 defConst("DOCON", DOCON)
 529 defConst("DOVAR", DOVAR)
 530 defConst("DICT", DICT)
 531 F_IMMED = defConst("F_IMMED", 128)
 532 F_HIDDEN = defConst("F_HIDDEN", 256)
 533 F_LENMASK = defConst("F_LENMASK", 127)
 534
 535 # Return Stack
 536
 537 TOR = defPrimWord(">R", () -> begin
 538     pushRS(popPS())
 539     return NEXT
 540 end)
 541
 542 FROMR = defPrimWord("R>", () -> begin
 543     pushPS(popRS())
 544     return NEXT
 545 end)
 546
 547 RFETCH = defPrimWord("R@", () -> begin
 548     pushPS(mem[reg.RSP])
 549     return NEXT
 550 end)
 551
 552 RSPFETCH = defPrimWord("RSP@", () -> begin
 553     pushPS(reg.RSP)
 554     return NEXT
 555 end)
 556
 557 RSPSTORE = defPrimWord("RSP!", () -> begin
 558     RSP = popPS()
 559     return NEXT
 560 end)
 561
 562 RDROP = defPrimWord("RDROP", () -> begin
 563     popRS()
 564     return NEXT
 565 end)
 566
 567 # Parameter Stack
 568
 569 PSPFETCH = defPrimWord("PSP@", () -> begin
 570     pushPS(reg.PSP)
 571     return NEXT
 572 end)
 573
 574 PSPSTORE = defPrimWord("PSP!", () -> begin
 575     PSP = popPS()
 576     return NEXT
 577 end)
 578
 579 # Working Register
 580
 581 WFETCH = defPrimWord("W@", () -> begin
 582     pushPS(reg.W)
 583     return NEXT
 584 end)
 585
 586 WSTORE = defPrimWord("W!", () -> begin
 587     reg.W = popPS()
 588     return NEXT
 589 end)
 590
 591 # I/O
 592
 593 sources = Array{Any,1}()
 594 currentSource() = sources[length(sources)]
 595
 596 defConst("TIB", TIB)
 597 NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0)
 598 TOIN, TOIN_CFA = defNewVar(">IN", 0)
 599 EOF = defConst("EOF", 4)
 600
 601 KEY = defPrimWord("KEY", () -> begin
 602     if mem[TOIN] >= mem[NUMTIB]
 603         mem[TOIN] = 0
 604
 605         if !eof(currentSource())
 606             line = readline(currentSource())
 607             mem[NUMTIB] = length(line)
 608             putString(line, TIB)
 609         else
 610             mem[NUMTIB] = 1
 611             mem[TIB] = EOF
 612         end
 613     end
 614
 615     pushPS(mem[TIB + mem[TOIN]])
 616     mem[TOIN] += 1
 617
 618     return NEXT
 619 end)
 620
 621 EMIT = defPrimWord("EMIT", () -> begin
 622     print(Char(popPS()))
 623     return NEXT
 624 end)
 625
 626 WORD = defPrimWord("WORD", () -> begin
 627
 628     eof_char = Char(EOF)
 629     c = eof_char
 630
 631     skip_to_end = false
 632     while true
 633
 634         callPrim(mem[KEY])
 635         c = Char(popPS())
 636
 637         if c == '\\'
 638             skip_to_end = true
 639             continue
 640         end
 641
 642         if skip_to_end
 643             if c == '\n' || c == eof_char
 644                 skip_to_end = false
 645             end
 646             continue
 647         end
 648
 649         if c == ' ' || c == '\t'
 650             continue
 651         end
 652
 653         break
 654     end
 655
 656     wordAddr = mem[HERE]
 657     offset = 0
 658
 659     if c == '\n' || c == eof_char
 660         # Treat newline as a special word
 661
 662         mem[wordAddr + offset] = Int64(c)
 663         pushPS(wordAddr)
 664         pushPS(1)
 665         return NEXT
 666     end
 667
 668     while true
 669         mem[wordAddr + offset] = Int64(c)
 670         offset += 1
 671
 672         callPrim(mem[KEY])
 673         c = Char(popPS())
 674
 675         if c == ' ' || c == '\t' || c == '\n' || c == eof_char
 676             # Rewind KEY
 677             mem[TOIN] -= 1
 678             break
 679         end
 680     end
 681
 682     wordLen = offset
 683
 684     pushPS(wordAddr)
 685     pushPS(wordLen)
 686
 687     return NEXT
 688 end)
 689
 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 CREATE = defPrimWord("CREATE", () -> 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 LBRAC = defPrimWord("[", () -> begin
 791     mem[STATE] = 0
 792     return NEXT
 793 end, flags=F_IMMED)
 794
 795 RBRAC = defPrimWord("]", () -> begin
 796     mem[STATE] = 1
 797     return NEXT
 798 end, flags=F_IMMED)
 799
 800 HIDDEN = defPrimWord("HIDDEN", () -> begin
 801     addr = popPS() + 1
 802     mem[addr] = mem[addr] $ F_HIDDEN
 803     return NEXT
 804 end)
 805
 806 HIDE = defWord("HIDE",
 807     [WORD,
 808     FIND,
 809     HIDDEN,
 810     EXIT])
 811
 812 COLON = defWord(":",
 813     [WORD,
 814     CREATE,
 815     LIT, DOCOL, COMMA,
 816     LATEST_CFA, FETCH, HIDDEN,
 817     RBRAC,
 818     EXIT])
 819
 820 SEMICOLON = defWord(";",
 821     [LIT, EXIT, COMMA,
 822     LATEST_CFA, FETCH, HIDDEN,
 823     LBRAC,
 824     EXIT], flags=F_IMMED)
 825
 826 IMMEDIATE = defPrimWord("IMMEDIATE", () -> begin
 827     lenAndFlagsAddr = mem[LATEST] + 1
 828     mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED
 829     return NEXT
 830 end, flags=F_IMMED)
 831
 832 TICK = defWord("'",
 833     [WORD, FIND, TOCFA, EXIT])
 834
 835 BTICK = defWord("[']",
 836     [FROMR, DUP, INCR, TOR, FETCH, EXIT])
 837
 838
 839 # Strings
 840
 841 LITSTRING = defPrimWord("LITSTRING", () -> begin
 842     len = mem[reg.IP]
 843     reg.IP += 1
 844     pushPS(reg.IP)
 845     pushPS(len)
 846     reg.IP += len
 847
 848     return NEXT
 849 end)
 850
 851 TELL = defPrimWord("TELL", () -> begin
 852     len = popPS()
 853     addr = popPS()
 854     str = getString(addr, len)
 855     print(str)
 856     return NEXT
 857 end)
 858
 859 # Outer interpreter
 860
 861 EXECUTE = defPrimWord("EXECUTE", () -> begin
 862     reg.W = popPS()
 863     return mem[reg.W]
 864 end)
 865
 866 type ParseError <: Exception
 867     wordName::ASCIIString
 868 end
 869 Base.showerror(io::IO, ex::ParseError) = print(io, "Parse error at word: '$(ex.wordName)'.")
 870
 871 DEBUG, DEBUG_CFA = defNewVar("DEBUG", 0)
 872
 873 INTERPRET = defPrimWord("INTERPRET", () -> begin
 874
 875     callPrim(mem[WORD])
 876
 877     wordName = getString(mem[reg.PSP-1], mem[reg.PSP])
 878     if mem[DEBUG] != 0
 879         println("... ", replace(replace(wordName, "\004", "EOF"), "\n", "\\n"), " ...")
 880     end
 881
 882     callPrim(mem[TWODUP])
 883     callPrim(mem[FIND])
 884
 885     wordAddr = mem[reg.PSP]
 886
 887     if wordAddr>0
 888         # Word in dictionary
 889
 890         isImmediate = (mem[wordAddr+1] & F_IMMED) != 0
 891         callPrim(mem[TOCFA])
 892
 893         callPrim(mem[NROT]) # get rid of extra copy of word string details
 894         popPS()
 895         popPS()
 896
 897         if mem[STATE] == 0 || isImmediate
 898             # Execute!
 899             return callPrim(mem[EXECUTE])
 900         else
 901             # Append CFA to dictionary
 902             callPrim(mem[COMMA])
 903         end
 904     else
 905         # Not in dictionary, assume number
 906
 907         popPS()
 908
 909         callPrim(mem[NUMBER])
 910
 911         if popPS() != 0
 912             throw(ParseError(wordName))
 913         end
 914
 915         if mem[STATE] == 0
 916             # Number already on stack!
 917         else
 918             # Append literal to dictionary
 919             pushPS(LIT)
 920             callPrim(mem[COMMA])
 921             callPrim(mem[COMMA])
 922         end
 923     end
 924
 925     return NEXT
 926 end)
 927
 928 QUIT = defWord("QUIT",
 929     [RSP0_CFA, RSPSTORE,
 930     INTERPRET,
 931     BRANCH,-2])
 932
 933 BYE = defPrimWord("BYE", () -> begin
 934     return 0
 935 end)
 936
 937 PROMPT = defPrimWord("PROMPT", () -> begin
 938     println(" ok")
 939 end)
 940
 941 NL = defPrimWord("\n", () -> begin
 942     if mem[STATE] == 0 && currentSource() == STDIN
 943         callPrim(mem[PROMPT])
 944     end
 945     return NEXT
 946 end, flags=F_IMMED)
 947
 948 INCLUDE = defPrimWord("INCLUDE", () -> begin
 949     callPrim(mem[WORD])
 950     wordLen = popPS()
 951     wordAddr = popPS()
 952     word = getString(wordAddr, wordLen)
 953
 954     push!(sources, open(word, "r"))
 955
 956     # Clear input buffer
 957     mem[NUMTIB] = 0
 958
 959     return NEXT
 960 end)
 961
 962 EOF_WORD = defPrimWord("\x04", () -> begin
 963     if currentSource() != STDIN
 964         close(currentSource())
 965     end
 966
 967     pop!(sources)
 968
 969     if length(sources)>0
 970         if currentSource() == STDIN
 971             callPrim(mem[PROMPT])
 972         end
 973
 974         return NEXT
 975     else
 976         return 0
 977     end
 978 end, flags=F_IMMED)
 979
 980 # Odds and Ends
 981
 982 CHAR = defPrimWord("CHAR", () -> begin
 983     callPrim(mem[WORD])
 984     wordLen = popPS()
 985     wordAddr = popPS()
 986     word = getString(wordAddr, wordLen)
 987     pushPS(Int64(word[1]))
 988
 989     return NEXT
 990 end)
 991
 992 initialized = false
 993 initFileName = nothing
 994 if isfile("lib.4th")
 995     initFileName = "lib.4th"
 996 elseif isfile(Pkg.dir("forth/src/lib.4th"))
 997     initFileName = Pkg.dir("forth/src/lib.4th")
 998 end
 999
1000
1001 #### VM loop ####
1002 function run(;initialize=true)
1003     # Begin with STDIN as source
1004     push!(sources, STDIN)
1005
1006     global initialized, initFileName
1007     if !initialized && initialize
1008         if initFileName != nothing
1009             print("Including definitions from $initFileName...")
1010             push!(sources, open(initFileName, "r"))
1011             initialized = true
1012         else
1013             println("No library file found. Only primitive words available.")
1014         end
1015     end
1016
1017     # Start with IP pointing to first instruction of outer interpreter
1018     reg.IP = QUIT + 1
1019
1020     # Primitive processing loop.
1021     # Everyting else is simply a consequence of this loop!
1022     jmp = NEXT
1023     while jmp != 0
1024         try
1025             if mem[DEBUG] != 0
1026                 println("Evaluating prim ", jmp," ", primNames[-jmp])
1027             end
1028
1029             jmp = callPrim(jmp)
1030
1031         catch ex
1032             showerror(STDOUT, ex)
1033             println()
1034
1035             while !isempty(sources) && currentSource() != STDIN
1036                 close(pop!(sources))
1037             end
1038
1039             mem[STATE] = 0
1040             mem[NUMTIB] = 0
1041             reg.PSP = mem[PSP0]
1042             reg.RSP = mem[RSP0]
1043             reg.IP = QUIT + 1
1044             jmp = NEXT
1045         end
1046     end
1047 end
1048
1049 # Debugging tools
1050
1051 function dump(startAddr::Int64; count::Int64 = 100, cellsPerLine::Int64 = 10)
1052     chars = Array{Char,1}(cellsPerLine)
1053
1054     lineStartAddr = cellsPerLine*div((startAddr-1),cellsPerLine) + 1
1055     endAddr = startAddr + count - 1
1056
1057     q, r = divrem((endAddr-lineStartAddr+1), cellsPerLine)
1058     numLines = q + (r > 0 ? 1 : 0)
1059
1060     i = lineStartAddr
1061     for l in 1:numLines
1062         print(i,":")
1063
1064         for c in 1:cellsPerLine
1065             if i >= startAddr && i <= endAddr
1066                 print("\t",mem[i])
1067                 if mem[i]>=32 && mem[i]<128
1068                     chars[c] = Char(mem[i])
1069                 else
1070                     chars[c] = '.'
1071                 end
1072             else
1073                 print("\t")
1074                 chars[c] = ' '
1075             end
1076
1077             i += 1
1078         end
1079
1080         println("\t", ASCIIString(chars))
1081     end
1082 end
1083
1084 function printPS()
1085     count = reg.PSP - mem[PSP0]
1086
1087     if count > 0
1088         print("<$count>")
1089         for i in (mem[PSP0]+1):reg.PSP
1090             print(" $(mem[i])")
1091         end
1092         println()
1093     else
1094         println("Parameter stack empty")
1095     end
1096 end
1097
1098 function printRS()
1099     count = reg.RSP - mem[RSP0]
1100
1101     if count > 0
1102         print("<$count>")
1103         for i in (mem[RSP0]+1):reg.RSP
1104             print(" $(mem[i])")
1105         end
1106         println()
1107     else
1108         println("Return stack empty")
1109     end
1110 end
1111
1112 DUMP = defPrimWord("DUMP", () -> begin
1113     count = popPS()
1114     addr = popPS()
1115
1116     dump(addr, count=count)
1117
1118     return NEXT
1119 end)
1120
1121 end