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