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