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