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