src/forth.jl

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