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