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