src/forth.jl

   1 module forth
   2
   3 import Base.REPLCompletions
   4
   5 # VM mem size
   6 size_mem = 1000000 # 1 mega-int
   7
   8 # Buffer sizes
   9 size_RS = 1000   # Return stack size
  10 size_PS = 1000   # Parameter stack size
  11 size_TIB = 1000  # Terminal input buffer size
  12 size_FIB = 1000  # File input buffer size
  13
  14 # Memory arrays
  15 mem = Array{Int64,1}(size_mem)
  16 primitives = Array{Function,1}()
  17 primNames = Array{AbstractString,1}()
  18
  19 # Memory geography and built-in variables
  20
  21 nextVarAddr = 1
  22 H = nextVarAddr; nextVarAddr += 1              # Next free memory address
  23 FORTH_LATEST = nextVarAddr; nextVarAddr += 1   # FORTH dict latest
  24 CURRENT = nextVarAddr; nextVarAddr += 1        # Current compilation dict
  25
  26 RSP0 = nextVarAddr                  # bottom of RS
  27 PSP0 = RSP0 + size_RS               # bottom of PS
  28 TIB = PSP0 + size_PS                # address of terminal input buffer
  29 FIB = TIB + size_TIB                # address of terminal input buffer
  30 mem[H] = FIB + size_FIB             # location of bottom of dictionary
  31 mem[FORTH_LATEST] = 0               # zero FORTH dict latest (no previous def)
  32 mem[CURRENT] = FORTH_LATEST-1       # Compile words to system dict initially
  33
  34 DICT = mem[H] # Save bottom of dictionary as constant
  35
  36 # VM registers
  37 type Reg
  38     RSP::Int64  # Return stack pointer
  39     PSP::Int64  # Parameter/data stack pointer
  40     IP::Int64   # Instruction pointer
  41     W::Int64    # Working register
  42 end
  43 reg = Reg(RSP0, PSP0, 0, 0)
  44
  45 # Stack manipulation functions
  46
  47 function ensurePSDepth(depth::Int64)
  48     if reg.PSP - PSP0 < depth
  49         error("Parameter stack underflow.")
  50     end
  51 end
  52
  53 function ensurePSCapacity(toAdd::Int64)
  54     if reg.PSP + toAdd >= PSP0 + size_PS
  55         error("Parameter stack overflow.")
  56     end
  57 end
  58
  59 function ensureRSDepth(depth::Int64)
  60     if reg.RSP - RSP0 < depth
  61         error("Return stack underflow.")
  62     end
  63 end
  64
  65 function ensureRSCapacity(toAdd::Int64)
  66     if reg.RSP + toAdd >= RSP0 + size_RS
  67         error("Return stack overflow.")
  68     end
  69 end
  70
  71 function pushRS(val::Int64)
  72     ensureRSCapacity(1)
  73     mem[reg.RSP+=1] = val
  74 end
  75
  76 function popRS()
  77     ensureRSDepth(1)
  78
  79     val = mem[reg.RSP]
  80     reg.RSP -= 1
  81     return val
  82 end
  83
  84 function pushPS(val::Int64)
  85     ensurePSCapacity(1)
  86
  87     mem[reg.PSP += 1] = val
  88 end
  89
  90 function popPS()
  91     ensurePSDepth(1)
  92
  93     val = mem[reg.PSP]
  94     reg.PSP -= 1
  95     return val
  96 end
  97
  98 # Handy functions for adding/retrieving strings to/from memory.
  99
 100 getString(addr::Int64, len::Int64) = AbstractString([Char(c) for c in mem[addr:(addr+len-1)]])
 101
 102 function putString(str::AbstractString, addr::Int64, maxLen::Int64)
 103     len = min(length(str), maxLen)
 104     mem[addr:(addr+len-1)] = [Int64(c) for c in str]
 105 end
 106
 107 stringAsInts(str::AbstractString) = [Int(c) for c in collect(str)]
 108
 109 # Primitive creation and calling functions
 110
 111 function defPrim(f::Function; name="nameless")
 112     push!(primitives, f)
 113     push!(primNames, replace(name, "\004", "EOF"))
 114
 115     return -length(primitives)
 116 end
 117
 118 function callPrim(addr::Int64)
 119     if addr >=0 || -addr>length(primitives)
 120         error("Attempted to execute non-existent primitive at address $addr.")
 121     else
 122         primitives[-addr]()
 123     end
 124 end
 125 getPrimName(addr::Int64) = primNames[-addr]
 126
 127 # Word creation functions
 128
 129 F_LENMASK = 31
 130 F_IMMED = 32
 131 F_HIDDEN = 64
 132 NFA_MARK = 128
 133
 134 function dictWrite(ints::Array{Int64,1})
 135     mem[mem[H]:(mem[H]+length(ints)-1)] = ints
 136     mem[H] += length(ints)
 137 end
 138 dictWrite(int::Int64) = dictWrite([int])
 139 dictWriteString(string::AbstractString) = dictWrite([Int64(c) for c in string])
 140
 141 function createHeader(name::AbstractString, flags::Int64)
 142     mem[mem[H]] = mem[mem[CURRENT]+1]
 143     mem[mem[CURRENT]+1] = mem[H]
 144     mem[H] += 1
 145
 146     dictWrite(length(name) | flags | NFA_MARK)
 147     dictWriteString(name)
 148 end
 149
 150 function defPrimWord(name::AbstractString, f::Function; flags::Int64=0)
 151     createHeader(name, flags)
 152
 153     codeWordAddr = mem[H]
 154     dictWrite(defPrim(f, name=name))
 155
 156     return codeWordAddr
 157 end
 158
 159 function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0)
 160     createHeader(name, flags)
 161
 162     addr = mem[H]
 163     dictWrite(DOCOL)
 164
 165     dictWrite(wordAddrs)
 166
 167     return addr
 168 end
 169
 170 # Variable creation functions
 171
 172 function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0)
 173
 174     defPrimWord(name, eval(:(() -> begin
 175         pushPS($(varAddr))
 176         return NEXT
 177     end)))
 178 end
 179
 180 function defNewVar(name::AbstractString, initial::Array{Int64,1}; flags::Int64=0)
 181     createHeader(name, flags)
 182
 183     codeWordAddr = mem[H]
 184     varAddr = mem[H] + 1
 185
 186     dictWrite(DOVAR)
 187     dictWrite(initial)
 188
 189     return varAddr, codeWordAddr
 190 end
 191
 192 defNewVar(name::AbstractString, initial::Int64; flags::Int64=0) =
 193     defNewVar(name, [initial]; flags=flags)
 194
 195 function defConst(name::AbstractString, val::Int64; flags::Int64=0)
 196     createHeader(name, flags)
 197
 198     codeWordAddr = mem[H]
 199
 200     dictWrite(DOCON)
 201     dictWrite(val)
 202
 203     return codeWordAddr
 204 end
 205
 206 # Threading Primitives (inner interpreter)
 207
 208 NEXT = defPrim(() -> begin
 209     reg.W = mem[reg.IP]
 210     reg.IP += 1
 211     return mem[reg.W]
 212 end, name="NEXT")
 213
 214 DOCOL = defPrim(() -> begin
 215     pushRS(reg.IP)
 216     reg.IP = reg.W + 1
 217     return NEXT
 218 end, name="DOCOL")
 219
 220 DOVAR = defPrim(() -> begin
 221     pushPS(reg.W + 1)
 222     return NEXT
 223 end, name="DOVAR")
 224
 225 DOCON = defPrim(() -> begin
 226     pushPS(mem[reg.W + 1])
 227     return NEXT
 228 end, name="DOVAR")
 229
 230 EXIT_CFA = defPrimWord("EXIT", () -> begin
 231     reg.IP = popRS()
 232     return NEXT
 233 end)
 234
 235 # Dictionary entries for core built-in variables, constants
 236
 237 H_CFA = defExistingVar("H", H)
 238
 239 PSP0_CFA = defConst("PSP0", PSP0)
 240 RSP0_CFA = defConst("RSP0", RSP0)
 241
 242 defConst("DOCOL", DOCOL)
 243 defConst("DOCON", DOCON)
 244 defConst("DOVAR", DOVAR)
 245
 246 defConst("DICT", DICT)
 247 defConst("MEMSIZE", size_mem)
 248
 249 F_IMMED_CFA = defConst("F_IMMED", F_IMMED)
 250 F_HIDDEN_CFA = defConst("F_HIDDEN", F_HIDDEN)
 251 F_LENMASK_CFA = defConst("F_LENMASK", F_LENMASK)
 252 NFA_MARK_CFA = defConst("NFA_MARK", NFA_MARK)
 253
 254 # Basic forth primitives
 255
 256 DROP_CFA = defPrimWord("DROP", () -> begin
 257     popPS()
 258     return NEXT
 259 end)
 260
 261 SWAP_CFA = defPrimWord("SWAP", () -> begin
 262     a = popPS()
 263     b = popPS()
 264     pushPS(a)
 265     pushPS(b)
 266     return NEXT
 267 end)
 268
 269 DUP_CFA = defPrimWord("DUP", () -> begin
 270     ensurePSDepth(1)
 271     pushPS(mem[reg.PSP])
 272     return NEXT
 273 end)
 274
 275 OVER_CFA = defPrimWord("OVER", () -> begin
 276     ensurePSDepth(2)
 277     pushPS(mem[reg.PSP-1])
 278     return NEXT
 279 end)
 280
 281 ROT_CFA = defPrimWord("ROT", () -> begin
 282     a = popPS()
 283     b = popPS()
 284     c = popPS()
 285     pushPS(b)
 286     pushPS(a)
 287     pushPS(c)
 288     return NEXT
 289 end)
 290
 291 NROT_CFA = defPrimWord("-ROT", () -> begin
 292     a = popPS()
 293     b = popPS()
 294     c = popPS()
 295     pushPS(a)
 296     pushPS(c)
 297     pushPS(b)
 298     return NEXT
 299 end)
 300
 301
 302 TWODROP_CFA = defPrimWord("2DROP", () -> begin
 303     popPS()
 304     popPS()
 305     return NEXT
 306 end)
 307
 308 TWODUP_CFA = defPrimWord("2DUP", () -> begin
 309     ensurePSDepth(2)
 310     a = mem[reg.PSP-1]
 311     b = mem[reg.PSP]
 312     pushPS(a)
 313     pushPS(b)
 314     return NEXT
 315 end)
 316
 317 TWOSWAP_CFA = defPrimWord("2SWAP", () -> begin
 318     a = popPS()
 319     b = popPS()
 320     c = popPS()
 321     d = popPS()
 322     pushPS(b)
 323     pushPS(a)
 324     pushPS(d)
 325     pushPS(c)
 326     return NEXT
 327 end)
 328
 329 TWOOVER_CFA = defPrimWord("2OVER", () -> begin
 330     ensurePSDepth(4)
 331     a = mem[reg.PSP-3]
 332     b = mem[reg.PSP-2]
 333     pushPS(a)
 334     pushPS(b)
 335     return NEXT
 336 end)
 337
 338 QDUP_CFA = defPrimWord("?DUP", () -> begin
 339     ensurePSDepth(1)
 340     val = mem[reg.PSP]
 341     if val != 0
 342         pushPS(val)
 343     end
 344     return NEXT
 345 end)
 346
 347 INCR_CFA = defPrimWord("1+", () -> begin
 348     ensurePSDepth(1)
 349     mem[reg.PSP] += 1
 350     return NEXT
 351 end)
 352
 353 DECR_CFA = defPrimWord("1-", () -> begin
 354     ensurePSDepth(1)
 355     mem[reg.PSP] -= 1
 356     return NEXT
 357 end)
 358
 359 INCR2_CFA = defPrimWord("2+", () -> begin
 360     ensurePSDepth(1)
 361     mem[reg.PSP] += 2
 362     return NEXT
 363 end)
 364
 365 DECR2_CFA = defPrimWord("2-", () -> begin
 366     ensurePSDepth(1)
 367     mem[reg.PSP] -= 2
 368     return NEXT
 369 end)
 370
 371 ADD_CFA = defPrimWord("+", () -> begin
 372     b = popPS()
 373     a = popPS()
 374     pushPS(a+b)
 375     return NEXT
 376 end)
 377
 378 SUB_CFA = defPrimWord("-", () -> begin
 379     b = popPS()
 380     a = popPS()
 381     pushPS(a-b)
 382     return NEXT
 383 end)
 384
 385 MUL_CFA = defPrimWord("*", () -> begin
 386     b = popPS()
 387     a = popPS()
 388     pushPS(a*b)
 389     return NEXT
 390 end)
 391
 392 DIVMOD_CFA = defPrimWord("/MOD", () -> begin
 393     b = popPS()
 394     a = popPS()
 395     q,r = divrem(a,b)
 396     pushPS(r)
 397     pushPS(q)
 398     return NEXT
 399 end)
 400
 401 TWOMUL_CFA = defPrimWord("2*", () -> begin
 402     pushPS(popPS() << 1)
 403     return NEXT
 404 end)
 405
 406 TWODIV_CFA = defPrimWord("2/", () -> begin
 407     pushPS(popPS() >> 1)
 408     return NEXT
 409 end)
 410
 411 EQ_CFA = defPrimWord("=", () -> begin
 412     b = popPS()
 413     a = popPS()
 414     pushPS(a==b ? -1 : 0)
 415     return NEXT
 416 end)
 417
 418 NE_CFA = defPrimWord("<>", () -> begin
 419     b = popPS()
 420     a = popPS()
 421     pushPS(a!=b ? -1 : 0)
 422     return NEXT
 423 end)
 424
 425 LT_CFA = defPrimWord("<", () -> begin
 426     b = popPS()
 427     a = popPS()
 428     pushPS(a<b ? -1 : 0)
 429     return NEXT
 430 end)
 431
 432 GT_CFA = defPrimWord(">", () -> begin
 433     b = popPS()
 434     a = popPS()
 435     pushPS(a>b ? -1 : 0)
 436     return NEXT
 437 end)
 438
 439 LE_CFA = defPrimWord("<=", () -> begin
 440     b = popPS()
 441     a = popPS()
 442     pushPS(a<=b ? -1 : 0)
 443     return NEXT
 444 end)
 445
 446 GE_CFA = defPrimWord(">=", () -> begin
 447     b = popPS()
 448     a = popPS()
 449     pushPS(a>=b ? -1 : 0)
 450     return NEXT
 451 end)
 452
 453 ZE_CFA = defPrimWord("0=", () -> begin
 454     pushPS(popPS() == 0 ? -1 : 0)
 455     return NEXT
 456 end)
 457
 458 ZNE_CFA = defPrimWord("0<>", () -> begin
 459     pushPS(popPS() != 0 ? -1 : 0)
 460     return NEXT
 461 end)
 462
 463 ZLT_CFA = defPrimWord("0<", () -> begin
 464     pushPS(popPS() < 0 ? -1 : 0)
 465     return NEXT
 466 end)
 467
 468 ZGT_CFA = defPrimWord("0>", () -> begin
 469     pushPS(popPS() > 0 ? -1 : 0)
 470     return NEXT
 471 end)
 472
 473 ZLE_CFA = defPrimWord("0<=", () -> begin
 474     pushPS(popPS() <= 0 ? -1 : 0)
 475     return NEXT
 476 end)
 477
 478 ZGE_CFA = defPrimWord("0>=", () -> begin
 479     pushPS(popPS() >= 0 ? -1 : 0)
 480     return NEXT
 481 end)
 482
 483 AND_CFA = defPrimWord("AND", () -> begin
 484     b = popPS()
 485     a = popPS()
 486     pushPS(a & b)
 487     return NEXT
 488 end)
 489
 490 OR_CFA = defPrimWord("OR", () -> begin
 491     b = popPS()
 492     a = popPS()
 493     pushPS(a | b)
 494     return NEXT
 495 end)
 496
 497 XOR_CFA = defPrimWord("XOR", () -> begin
 498     b = popPS()
 499     a = popPS()
 500     pushPS(a $ b)
 501     return NEXT
 502 end)
 503
 504 INVERT_CFA = defPrimWord("INVERT", () -> begin
 505     pushPS(~popPS())
 506     return NEXT
 507 end)
 508
 509 # Literals
 510
 511 LIT_CFA = defPrimWord("LIT", () -> begin
 512     pushPS(mem[reg.IP])
 513     reg.IP += 1
 514     return NEXT
 515 end)
 516
 517 # Memory primitives
 518
 519 STORE_CFA = defPrimWord("!", () -> begin
 520     addr = popPS()
 521     dat = popPS()
 522     mem[addr] = dat
 523     return NEXT
 524 end)
 525
 526 FETCH_CFA = defPrimWord("@", () -> begin
 527     addr = popPS()
 528     pushPS(mem[addr])
 529     return NEXT
 530 end)
 531
 532 ADDSTORE_CFA = defPrimWord("+!", () -> begin
 533     addr = popPS()
 534     toAdd = popPS()
 535     mem[addr] += toAdd
 536     return NEXT
 537 end)
 538
 539 SUBSTORE_CFA = defPrimWord("-!", () -> begin
 540     addr = popPS()
 541     toSub = popPS()
 542     mem[addr] -= toSub
 543     return NEXT
 544 end)
 545
 546
 547 # Return Stack
 548
 549 TOR_CFA = defPrimWord(">R", () -> begin
 550     pushRS(popPS())
 551     return NEXT
 552 end)
 553
 554 FROMR_CFA = defPrimWord("R>", () -> begin
 555     pushPS(popRS())
 556     return NEXT
 557 end)
 558
 559 RFETCH_CFA = defPrimWord("R@", () -> begin
 560     pushPS(mem[reg.RSP])
 561     return NEXT
 562 end)
 563
 564 RSPFETCH_CFA = defPrimWord("RSP@", () -> begin
 565     pushPS(reg.RSP)
 566     return NEXT
 567 end)
 568
 569 RSPSTORE_CFA = defPrimWord("RSP!", () -> begin
 570     reg.RSP = popPS()
 571     return NEXT
 572 end)
 573
 574 RDROP_CFA = defPrimWord("RDROP", () -> begin
 575     popRS()
 576     return NEXT
 577 end)
 578
 579 # Parameter Stack
 580
 581 PSPFETCH_CFA = defPrimWord("PSP@", () -> begin
 582     pushPS(reg.PSP)
 583     return NEXT
 584 end)
 585
 586 PSPSTORE_CFA = defPrimWord("PSP!", () -> begin
 587     reg.PSP = popPS()
 588     return NEXT
 589 end)
 590
 591 # Working Register
 592
 593 WFETCH_CFA = defPrimWord("W@", () -> begin
 594     pushPS(reg.W)
 595     return NEXT
 596 end)
 597
 598 WSTORE_CFA = defPrimWord("W!", () -> begin
 599     reg.W = popPS()
 600     return NEXT
 601 end)
 602
 603 # I/O
 604
 605 openFiles = Dict{Int64,IOStream}()
 606 nextFileID = 1
 607
 608
 609 ## File access modes
 610 FAM_RO = 0
 611 FAM_WO = 1
 612 FAM_RO_CFA = defConst("R/O", FAM_RO)
 613 FAM_WO_CFA = defConst("W/O", FAM_WO)
 614
 615 function fileOpener(create::Bool)
 616     fnameLen = popPS()
 617     fnameAddr = popPS()
 618     fam = popPS()
 619
 620     fname = getString(fnameAddr, fnameLen)
 621
 622     if create && !isfile(fname)
 623         pushPS(0)
 624         pushPS(-1) # error
 625         return NEXT
 626     end
 627
 628     if (fam == FAM_RO)
 629         mode = "r"
 630     else
 631         mode = "w"
 632     end
 633
 634     openFiles[nextFileID] = open(fname, mode)
 635     pushPS(nextFileID)
 636     pushPS(0)
 637
 638     nextFileID += 1
 639 end
 640
 641 OPEN_FILE_CFA = defPrimWord("OPEN-FILE", () -> begin
 642     fileOpener(false)
 643     return NEXT
 644 end);
 645
 646 CREATE_FILE_CFA = defPrimWord("CREATE-FILE", () -> begin
 647     fileOpener(true)
 648     return NEXT
 649 end);
 650
 651 CLOSE_FILE_CFA = defPrimWord("CLOSE-FILE", () -> begin
 652     fid = popPS()
 653     close(openFiles[fid])
 654     delete!(openFiles, fid)
 655     return NEXT
 656 end)
 657
 658 CLOSE_FILES_CFA = defPrimWord("CLOSE-FILES", () -> begin
 659     for fh in values(openFiles)
 660         close(fh)
 661     end
 662     empty!(openFiles)
 663
 664     return NEXT
 665 end)
 666
 667 READ_LINE_CFA = defPrimWord("READ-LINE", () -> begin
 668     fid = popPS()
 669     maxSize = popPS()
 670     addr = popPS()
 671
 672     fh = openFiles[fid]
 673     line = readline(fh)
 674
 675     eofFlag = endswith(line, '\n') ? 0 : -1
 676     line = chomp(line)
 677
 678     putString(line, addr, maxSize)
 679
 680     pushPS(length(line))
 681     pushPS(eofFlag)
 682     pushPS(0)
 683
 684     return NEXT
 685 end)
 686
 687
 688 EMIT_CFA = defPrimWord("EMIT", () -> begin
 689     print(Char(popPS()))
 690     return NEXT
 691 end)
 692
 693 function raw_mode!(mode::Bool)
 694     if ccall(:jl_tty_set_mode, Int32, (Ptr{Void}, Int32), STDIN.handle, mode) != 0
 695         throw("FATAL: Terminal unable to enter raw mode.")
 696     end
 697 end
 698
 699 function getKey()
 700     raw_mode!(true)
 701     byte = readbytes(STDIN, 1)[1]
 702     raw_mode!(false)
 703
 704     if byte == 0x0d
 705         return 0x0a
 706     elseif byte == 127
 707         return 0x08
 708     else
 709         return byte
 710     end
 711 end
 712
 713 KEY_CFA = defPrimWord("KEY", () -> begin
 714     pushPS(Int(getKey()))
 715     return NEXT
 716 end)
 717
 718 function getLineFromSTDIN()
 719
 720     function getFrag(s)
 721         chars = collect(s)
 722         slashIdx = findlast(chars, '\\')
 723
 724         if slashIdx > 0
 725             return join(chars[slashIdx:length(chars)])
 726         else
 727             return nothing
 728         end
 729     end
 730
 731     function backspaceStr(s, bsCount)
 732         oldLen = length(s)
 733         newLen = max(0, oldLen - bsCount)
 734         return join(collect(s)[1:newLen])
 735     end
 736
 737     line = ""
 738     while true
 739         key = Char(getKey())
 740
 741         if key == '\n'
 742             print(" ")
 743             return AbstractString(line)
 744
 745         elseif key == '\x04'
 746             if isempty(line)
 747                 return string("\x04")
 748             end
 749
 750         elseif key == '\b'
 751             if !isempty(line)
 752                 print("\b\033[K")
 753                 line = backspaceStr(line, 1)
 754             end
 755
 756         elseif key == '\e'
 757             # Strip ANSI escape sequence
 758             nextKey = Char(getKey())
 759             if nextKey == '['
 760                 while true
 761                     nextKey = Char(getKey())
 762                     if nextKey >= '@' || nextKey <= '~'
 763                         break
 764                     end
 765                 end
 766             end
 767
 768         elseif key == '\t'
 769             # Currently do nothing
 770
 771             frag = getFrag(line)
 772             if frag != nothing
 773                 if haskey(REPLCompletions.latex_symbols, frag)
 774                     print(repeat("\b", length(frag)))
 775                     print("\033[K")
 776                     comp = REPLCompletions.latex_symbols[frag]
 777                     line = string(backspaceStr(line, length(frag)), comp)
 778                     print(comp)
 779                 end
 780             end
 781
 782         else
 783             print(key)
 784             line = string(line, key)
 785         end
 786     end
 787 end
 788
 789 SPAN, SPAN_CFA = defNewVar("SPAN", 0)
 790 EXPECT_CFA = defPrimWord("EXPECT", () -> begin
 791     maxLen = popPS()
 792     addr = popPS()
 793
 794     line = getLineFromSTDIN()
 795
 796     mem[SPAN] = min(length(line), maxLen)
 797     putString(line, addr, maxLen)
 798
 799     return NEXT
 800 end)
 801
 802 BASE, BASE_CFA = defNewVar("BASE", 10)
 803 NUMBER_CFA = defPrimWord("NUMBER", () -> begin
 804     wordAddr = popPS()+1
 805     wordLen = mem[wordAddr-1]
 806
 807     s = getString(wordAddr, wordLen)
 808
 809     pushPS(parse(Int64, s, mem[BASE]))
 810
 811     return NEXT
 812 end)
 813
 814 # Dictionary searches
 815
 816 FROMLINK_CFA = defPrimWord("LINK>", () -> begin
 817
 818     addr = popPS()
 819     lenAndFlags = mem[addr+1]
 820     len = lenAndFlags & F_LENMASK
 821
 822     pushPS(addr + 2 + len)
 823
 824     return NEXT
 825 end)
 826
 827 NUMCONTEXT, NUMCONTEXT_CFA = defNewVar("#CONTEXT", 1)
 828
 829 createHeader("FORTH", 0)
 830 FORTH_CFA = mem[H]
 831 dictWrite(defPrim(() -> begin
 832     mem[CONTEXT + mem[NUMCONTEXT] - 1] = reg.W
 833     return NEXT
 834 end, name="FORTH"))
 835 dictWrite(0) # cell for latest
 836
 837 CURRENT_CFA = defExistingVar("CURRENT", CURRENT)
 838
 839 # Switch to new FORTH vocabulary cfa
 840 mem[FORTH_CFA+1] = mem[mem[CURRENT]+1]
 841 mem[CURRENT] = FORTH_CFA
 842
 843 CONTEXT, CONTEXT_CFA = defNewVar("CONTEXT", zeros(Int64, 10))
 844 mem[CONTEXT] = FORTH_CFA
 845
 846 FINDVOCAB_CFA = defPrimWord("FINDVOCAB", () -> begin
 847     vocabCFA = popPS()
 848     countedAddr = popPS()
 849
 850     wordAddr = countedAddr + 1
 851     wordLen = mem[countedAddr]
 852     word = lowercase(getString(wordAddr, wordLen))
 853
 854     lfa = vocabCFA+1
 855     lenAndFlags = 0
 856
 857     while (lfa = mem[lfa]) > 0
 858
 859         lenAndFlags = mem[lfa+1]
 860         len = lenAndFlags & F_LENMASK
 861         hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN
 862
 863         if hidden || len != wordLen
 864             continue
 865         end
 866
 867         thisWord = lowercase(getString(lfa+2, len))
 868
 869         if thisWord == word
 870             break
 871         end
 872     end
 873
 874     if lfa > 0
 875         pushPS(lfa)
 876         callPrim(mem[FROMLINK_CFA])
 877         if (lenAndFlags & F_IMMED) == F_IMMED
 878             pushPS(1)
 879         else
 880             pushPS(-1)
 881         end
 882     else
 883         pushPS(countedAddr)
 884         pushPS(0)
 885     end
 886
 887     return NEXT
 888 end)
 889
 890 FIND_CFA = defPrimWord("FIND", () -> begin
 891
 892     countedAddr = popPS()
 893     context = mem[CONTEXT:(CONTEXT+mem[NUMCONTEXT]-1)]
 894
 895     for vocabCFA in reverse(context)
 896         pushPS(countedAddr)
 897         pushPS(vocabCFA)
 898         callPrim(mem[FINDVOCAB_CFA])
 899
 900         callPrim(mem[DUP_CFA])
 901         if popPS() != 0
 902             return NEXT
 903         else
 904             popPS()
 905             popPS()
 906         end
 907     end
 908
 909     pushPS(countedAddr)
 910     pushPS(0)
 911
 912     return NEXT
 913 end)
 914
 915
 916 # Branching
 917
 918 BRANCH_CFA = defPrimWord("BRANCH", () -> begin
 919     reg.IP += mem[reg.IP]
 920     return NEXT
 921 end)
 922
 923 ZBRANCH_CFA = defPrimWord("0BRANCH", () -> begin
 924     if (popPS() == 0)
 925         reg.IP += mem[reg.IP]
 926     else
 927         reg.IP += 1
 928     end
 929
 930     return NEXT
 931 end)
 932
 933 # Strings
 934
 935 LITSTRING_CFA = defPrimWord("LITSTRING", () -> begin
 936     len = mem[reg.IP]
 937     reg.IP += 1
 938     pushPS(reg.IP)
 939     pushPS(len)
 940     reg.IP += len
 941
 942     return NEXT
 943 end)
 944
 945 TYPE_CFA = defPrimWord("TYPE", () -> begin
 946     len = popPS()
 947     addr = popPS()
 948     str = getString(addr, len)
 949     print(str)
 950     return NEXT
 951 end)
 952
 953 # Interpreter/Compiler-specific I/O
 954
 955 TIB_CFA = defConst("TIB", TIB)
 956 NUMTIB, NUMTIB_CFA = defNewVar("#TIB", 0)
 957
 958 FIB_CFA = defConst("FIB", TIB)
 959 NUMFIB, NUMFIB_CFA = defNewVar("#FIB", 0)
 960
 961 TOIN, TOIN_CFA = defNewVar(">IN", 0)
 962
 963 SOURCE_ID, SOURCE_ID_CFA = defNewVar("SOURCE-ID", 0)
 964
 965 SOURCE_CFA = defPrimWord("SOURCE", () -> begin
 966     if mem[SOURCE_ID] == 0
 967         pushPS(TIB)
 968         pushPS(NUMTIB)
 969     else
 970         pushPS(FIB)
 971         pushPS(NUMFIB)
 972     end
 973     return NEXT
 974 end)
 975
 976 QUERY_CFA = defWord("QUERY",
 977     [TIB_CFA, LIT_CFA, 160, EXPECT_CFA,
 978     SPAN_CFA, FETCH_CFA, NUMTIB_CFA, STORE_CFA,
 979     LIT_CFA, 0, TOIN_CFA, STORE_CFA,
 980     EXIT_CFA])
 981
 982 QUERY_FILE_CFA = defWord("QUERY-FILE",
 983     [FIB_CFA, LIT_CFA, 160, ROT_CFA, READ_LINE_CFA,
 984     DROP_CFA, SWAP_CFA,
 985     NUMFIB_CFA, STORE_CFA,
 986     EXIT_CFA])
 987
 988 WORD_CFA = defPrimWord("WORD", () -> begin
 989     delim = popPS()
 990
 991     callPrim(mem[SOURCE_CFA])
 992     sizeAddr = popPS()
 993     bufferAddr = popPS()
 994
 995     # Chew up initial occurrences of delim
 996     while (mem[TOIN]<mem[sizeAddr] && mem[bufferAddr+mem[TOIN]] == delim)
 997         mem[TOIN] += 1
 998     end
 999
1000     countAddr = mem[H]
1001     addr = mem[H]+1
1002
1003     # Start reading in word
1004     count = 0
1005     while (mem[TOIN]<mem[sizeAddr])
1006         mem[addr] = mem[bufferAddr+mem[TOIN]]
1007         mem[TOIN] += 1
1008
1009         if (mem[addr] == delim)
1010             break
1011         end
1012
1013         count += 1
1014         addr += 1
1015     end
1016
1017     # Record count
1018     mem[countAddr] = count
1019     pushPS(countAddr)
1020
1021     return NEXT
1022 end)
1023
1024 # Compilation
1025
1026 STATE, STATE_CFA = defNewVar("STATE", 0)
1027
1028 COMMA_CFA = defPrimWord(",", () -> begin
1029     mem[mem[H]] = popPS()
1030     mem[H] += 1
1031
1032     return NEXT
1033 end)
1034
1035 HERE_CFA = defWord("HERE",
1036     [H_CFA, FETCH_CFA, EXIT_CFA])
1037
1038 HEADER_CFA = defPrimWord("HEADER", () -> begin
1039     wordAddr = popPS()+1
1040     wordLen = mem[wordAddr-1]
1041     word = getString(wordAddr, wordLen)
1042
1043     createHeader(word, 0)
1044
1045     return NEXT
1046 end)
1047
1048 CREATE_CFA = defWord("CREATE",
1049     [LIT_CFA, 32, WORD_CFA, HEADER_CFA,
1050     LIT_CFA, DOVAR, COMMA_CFA,
1051     EXIT_CFA])
1052
1053 DODOES = defPrim(() -> begin
1054     pushRS(reg.IP)
1055     reg.IP = popPS()
1056     pushPS(reg.W + 1)
1057     return NEXT
1058 end, name="DODOES")
1059
1060 DOES_HELPER_CFA = defPrimWord("(DOES>)", () -> begin
1061
1062     pushPS(mem[mem[CURRENT]+1])
1063     callPrim(mem[FROMLINK_CFA])
1064     cfa = popPS()
1065
1066     runtimeAddr = popPS()
1067
1068     mem[cfa] = defPrim(eval(:(() -> begin
1069         pushPS($(runtimeAddr))
1070         return DODOES
1071     end)), name="doesPrim")
1072
1073     return NEXT
1074 end, flags=F_IMMED | F_HIDDEN)
1075
1076 DOES_CFA = defWord("DOES>",
1077     [LIT_CFA, LIT_CFA, COMMA_CFA, HERE_CFA, LIT_CFA, 3, ADD_CFA, COMMA_CFA,
1078     LIT_CFA, DOES_HELPER_CFA, COMMA_CFA, LIT_CFA, EXIT_CFA, COMMA_CFA, EXIT_CFA],
1079     flags=F_IMMED)
1080
1081 LBRAC_CFA = defPrimWord("[", () -> begin
1082     mem[STATE] = 0
1083     return NEXT
1084 end, flags=F_IMMED)
1085
1086 RBRAC_CFA = defPrimWord("]", () -> begin
1087     mem[STATE] = 1
1088     return NEXT
1089 end, flags=F_IMMED)
1090
1091 HIDDEN_CFA = defPrimWord("HIDDEN", () -> begin
1092     lenAndFlagsAddr = mem[mem[CURRENT]+1] + 1
1093     mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_HIDDEN
1094     return NEXT
1095 end)
1096
1097 COLON_CFA = defWord(":",
1098     [LIT_CFA, 32, WORD_CFA,
1099     HEADER_CFA,
1100     LIT_CFA, DOCOL, COMMA_CFA,
1101     HIDDEN_CFA,
1102     RBRAC_CFA,
1103     EXIT_CFA])
1104
1105 SEMICOLON_CFA = defWord(";",
1106     [LIT_CFA, EXIT_CFA, COMMA_CFA,
1107     HIDDEN_CFA,
1108     LBRAC_CFA,
1109     EXIT_CFA], flags=F_IMMED)
1110
1111 IMMEDIATE_CFA = defPrimWord("IMMEDIATE", () -> begin
1112     lenAndFlagsAddr = mem[mem[CURRENT]+1] + 1
1113     mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED
1114     return NEXT
1115 end, flags=F_IMMED)
1116
1117 CODE_CFA = defPrimWord("CODE", () -> begin
1118     pushPS(32)
1119     callPrim(mem[WORD_CFA])
1120     callPrim(mem[HEADER_CFA])
1121
1122     exprString = "() -> begin\n"
1123     while true
1124         if mem[TOIN] >= mem[NUMTIB]
1125             exprString = string(exprString, "\n")
1126             if currentSource() == STDIN
1127                 println()
1128             end
1129
1130             pushPS(TIB)
1131             pushPS(160)
1132             callPrim(mem[EXPECT_CFA])
1133             mem[NUMTIB] = mem[SPAN]
1134             mem[TOIN] = 0
1135         end
1136
1137         pushPS(32)
1138         callPrim(mem[WORD_CFA])
1139         cAddr = popPS()
1140         thisWord = getString(cAddr+1, mem[cAddr])
1141
1142         if uppercase(thisWord) == "END-CODE"
1143             break
1144         end
1145
1146         exprString = string(exprString, " ", thisWord)
1147     end
1148     exprString = string(exprString, "\nreturn NEXT\nend")
1149
1150     func = eval(parse(exprString))
1151     dictWrite(defPrim(func))
1152
1153     return NEXT
1154 end)
1155
1156 # Outer Interpreter
1157
1158 EXECUTE_CFA = defPrimWord("EXECUTE", () -> begin
1159     reg.W = popPS()
1160     return mem[reg.W]
1161 end)
1162
1163 INTERPRET_CFA = defWord("INTERPRET",
1164     [LIT_CFA, 32, WORD_CFA, # Read next space-delimited word
1165
1166     DUP_CFA, FETCH_CFA, ZE_CFA, ZBRANCH_CFA, 3,
1167         DROP_CFA, EXIT_CFA, # Exit if input buffer is exhausted
1168
1169     STATE_CFA, FETCH_CFA, ZBRANCH_CFA, 24,
1170         # Compiling
1171         FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 13,
1172
1173             # Found word.
1174             LIT_CFA, -1, EQ_CFA, INVERT_CFA, ZBRANCH_CFA, 4,
1175
1176                 # Immediate: Execute!
1177                 EXECUTE_CFA, BRANCH_CFA, -26,
1178
1179                 # Not immediate: Compile!
1180                 COMMA_CFA, BRANCH_CFA, -29,
1181
1182             # No word found, parse number
1183             NUMBER_CFA, LIT_CFA, LIT_CFA, COMMA_CFA, COMMA_CFA, BRANCH_CFA, -36,
1184
1185        # Interpreting
1186         FIND_CFA, QDUP_CFA, ZBRANCH_CFA, 5,
1187
1188             # Found word. Execute!
1189             DROP_CFA, EXECUTE_CFA, BRANCH_CFA, -44,
1190
1191             # No word found, parse number and leave on stack
1192             NUMBER_CFA, BRANCH_CFA, -47,
1193     EXIT_CFA])
1194
1195 PROMPT_CFA = defPrimWord("PROMPT", () -> begin
1196     if mem[STATE] == 0
1197         print(" ok")
1198     end
1199     println()
1200
1201     return NEXT
1202 end)
1203
1204 QUIT_CFA = defWord("QUIT",
1205     [LIT_CFA, 0, STATE_CFA, STORE_CFA,
1206     LIT_CFA, 0, NUMTIB_CFA, STORE_CFA,
1207     RSP0_CFA, RSPSTORE_CFA,
1208     QUERY_CFA,
1209     INTERPRET_CFA, PROMPT_CFA,
1210     BRANCH_CFA,-4])
1211
1212 INTERPRET_CFA = defWord("INTERPRET",
1213     [SOURCE_ID_CFA, FETCH_CFA, TOR_CFA, # Store current source on return stack
1214
1215     LIT_CFA, 32, WORD_CFA, # Read next word from current input source
1216
1217     FAM_RO_CFA, OPEN_FILE_CFA, DROP_CFA, # Open the file named by this word.
1218
1219     DUP_CFA, SOURCE_ID_CFA, STORE_CFA, # Mark this as the current source
1220
1221     DUP_CFA, QUERY_FILE_CFA, # Read line from file
1222
1223     INTERPRET_CFA,
1224
1225     BRANCH_CFA, -4])
1226
1227
1228 ABORT_CFA = defWord("ABORT",
1229     [CLOSE_FILES_CFA, PSP0_CFA, PSPSTORE_CFA, QUIT_CFA])
1230
1231 BYE_CFA = defPrimWord("BYE", () -> begin
1232     println("\nBye!")
1233     return 0
1234 end)
1235
1236 EOF_CFA = defPrimWord("\x04", () -> begin
1237     return 0
1238 end)
1239
1240 #### VM loop ####
1241
1242 initialized = false
1243 initFileName = nothing
1244 if isfile("lib.4th")
1245     initFileName = "lib.4th"
1246 elseif isfile(Pkg.dir("forth","src", "lib.4th"))
1247     initFileName = Pkg.dir("forth","src","lib.4th")
1248 end
1249
1250 function run(;initialize=true)
1251
1252     # Start with IP pointing to first instruction of outer interpreter
1253     pushRS(QUIT_CFA+1)
1254
1255     # Load library files
1256     global initialized, initFileName
1257     if !initialized && initialize
1258         if initFileName != nothing
1259             print("Including definitions from $initFileName...")
1260
1261             # TODO
1262
1263             initialized = true
1264         else
1265             println("No library file found. Only primitive words available.")
1266         end
1267     end
1268
1269
1270     # Primitive processing loop.
1271     # Everyting else is simply a consequence of this loop!
1272     jmp = mem[EXIT_CFA]
1273     while jmp != 0
1274         try
1275             #println("Entering prim $(getPrimName(jmp))")
1276             jmp = callPrim(jmp)
1277
1278         catch ex
1279             showerror(STDOUT, ex)
1280             println()
1281
1282             # QUIT
1283             reg.IP = ABORT_CFA + 1
1284             jmp = NEXT
1285         end
1286     end
1287 end
1288
1289 # Debugging tools
1290
1291 TRACE_CFA = defPrimWord("TRACE", () -> begin
1292     println("reg.W: $(reg.W) reg.IP: $(reg.IP)")
1293     print("PS: "); printPS()
1294     print("RS: "); printRS()
1295     print("[paused]")
1296     readline()
1297
1298     return NEXT
1299 end)
1300
1301 function dump(startAddr::Int64; count::Int64 = 100, cellsPerLine::Int64 = 10)
1302     chars = Array{Char,1}(cellsPerLine)
1303
1304     lineStartAddr = cellsPerLine*div((startAddr-1),cellsPerLine) + 1
1305     endAddr = startAddr + count - 1
1306
1307     q, r = divrem((endAddr-lineStartAddr+1), cellsPerLine)
1308     numLines = q + (r > 0 ? 1 : 0)
1309
1310     i = lineStartAddr
1311     for l in 1:numLines
1312         print(i,":")
1313
1314         for c in 1:cellsPerLine
1315             if i >= startAddr && i <= endAddr
1316                 print("\t",mem[i])
1317                 if mem[i]>=32 && mem[i]<128
1318                     chars[c] = Char(mem[i])
1319                 else
1320                     chars[c] = '.'
1321                 end
1322             else
1323                 print("\t")
1324                 chars[c] = ' '
1325             end
1326
1327             i += 1
1328         end
1329
1330         println("\t", AbstractString(chars))
1331     end
1332 end
1333
1334 function printPS()
1335     count = reg.PSP - PSP0
1336
1337     if count > 0
1338         print("<$count>")
1339         for i in (PSP0+1):reg.PSP
1340             print(" $(mem[i])")
1341         end
1342         println()
1343     else
1344         println("Parameter stack empty")
1345     end
1346 end
1347
1348 function printRS()
1349     count = reg.RSP - RSP0
1350
1351     if count > 0
1352         print("<$count>")
1353         for i in (RSP0+1):reg.RSP
1354             print(" $(mem[i])")
1355         end
1356         println()
1357     else
1358         println("Return stack empty")
1359     end
1360 end
1361
1362 DUMP = defPrimWord("DUMP", () -> begin
1363     count = popPS()
1364     addr = popPS()
1365
1366     println()
1367     dump(addr, count=count)
1368
1369     return NEXT
1370 end)
1371
1372 end