src/forth.jl

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