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