src/forth.jl

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