src/forth.jl

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