src/forth.jl

   1 module forth
   2
   3 # VM mem size
   4 size_mem = 640*1024
   5
   6 # Buffer sizes
   7 size_RS = 1024   # Return stack size
   8 size_PS = 1024   # Parameter stack size
   9 size_TIB = 1096  # Terminal input buffer size
  10
  11 # The mem array constitutes the memory of the VM. It has the following geography:
  12 #
  13 # mem = +-----------------------+
  14 #       | Built-in Variables    |
  15 #       +-----------------------+
  16 #       | Return Stack          |
  17 #       +-----------------------+
  18 #       | Parameter Stack       |
  19 #       +-----------------------+
  20 #       | Terminal Input Buffer |
  21 #       +-----------------------+
  22 #       | Dictionary            |
  23 #       +-----------------------+
  24 #
  25 # Note that all words (user-defined, primitive, variables, etc) are included in
  26 # the dictionary.
  27 #
  28 # Simple linear addressing is used with one exception: references to primitive code
  29 # blocks, which are represented as anonymous functions, appear the negative index
  30 # into the primitives array which contains only these functions.
  31
  32 mem = Array{Int64,1}(size_mem)
  33 primitives = Array{Function,1}()
  34
  35 # Built-in variables
  36
  37 nextVarAddr = 1
  38 RSP0 = nextVarAddr; nextVarAddr += 1
  39 PSP0 = nextVarAddr; nextVarAddr += 1
  40 HERE = nextVarAddr; nextVarAddr += 1
  41 LATEST = nextVarAddr; nextVarAddr += 1
  42
  43 mem[RSP0] = nextVarAddr              # bottom of RS
  44 mem[PSP0] = mem[RSP0] + size_RS      # bottom of PS
  45 TIB = mem[PSP0] + size_PS            # address of terminal input buffer
  46 mem[HERE] = TIB + size_TIB           # location of bottom of dictionary
  47 mem[LATEST] = 0                      # no previous definition
  48
  49 DICT = mem[HERE] # Save bottom of dictionary as constant
  50
  51 # VM registers
  52 type Reg
  53     RSP::Int64  # Return stack pointer
  54     PSP::Int64  # Parameter/data stack pointer
  55     IP::Int64   # Instruction pointer
  56     W::Int64    # Working register
  57     X::Int64    # Extra register
  58 end
  59 reg = Reg(mem[RSP0], mem[PSP0], 0, 0, 0)
  60
  61 # Stack manipulation
  62
  63 type StackUnderflow <: Exception end
  64
  65 getRSDepth() = reg.RSP - mem[RSP0]
  66 getPSDepth() = reg.PSP - mem[PSP0]
  67
  68 function ensurePSDepth(depth::Int64)
  69     if getPSDepth()<depth
  70         throw(StackUnderflow())
  71     end
  72 end
  73
  74 function ensureRSDepth(depth::Int64)
  75     if getRSDepth()<depth
  76         throw(StackUnderflow())
  77     end
  78 end
  79
  80 function pushRS(val::Int64)
  81     mem[reg.RSP+=1] = val
  82 end
  83
  84 function popRS()
  85     ensureRSDepth(1)
  86
  87     val = mem[reg.RSP]
  88     reg.RSP -= 1
  89     return val
  90 end
  91
  92 function pushPS(val::Int64)
  93     mem[reg.PSP += 1] = val
  94 end
  95
  96 function popPS()
  97     ensurePSDepth(1)
  98
  99     val = mem[reg.PSP]
 100     reg.PSP -= 1
 101     return val
 102 end
 103
 104 # Handy functions for adding/retrieving strings to/from memory.
 105
 106 getString(addr::Int64, len::Int64) = ASCIIString([Char(c) for c in mem[addr:(addr+len-1)]])
 107 function putString(str::ASCIIString, addr::Int64)
 108     mem[addr:(addr+length(str)-1)] = [Int64(c) for c in str]
 109 end
 110
 111 # Primitive creation and calling functions
 112
 113 function createHeader(name::AbstractString, flags::Int64)
 114     mem[mem[HERE]] = mem[LATEST]
 115     mem[LATEST] = mem[HERE]
 116     mem[HERE] += 1
 117
 118     mem[mem[HERE]] = length(name) | flags; mem[HERE] += 1
 119     putString(name, mem[HERE]); mem[HERE] += length(name)
 120 end
 121
 122 function defPrim(name::AbstractString, f::Function; flags::Int64=0)
 123     createHeader(name, flags)
 124
 125     codeWordAddr = mem[HERE]
 126     push!(primitives, f)
 127     mem[codeWordAddr] = -length(primitives)
 128     mem[HERE] += 1
 129
 130     return codeWordAddr
 131 end
 132
 133 callPrim(addr::Int64) = primitives[-addr]()
 134
 135 function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0)
 136     defPrim(name, eval(:(() -> begin
 137         pushPS($(varAddr))
 138         return mem[NEXT]
 139     end)))
 140 end
 141
 142 function defNewVar(name::AbstractString, initial::Int64; flags::Int64=0)
 143     createHeader(name, flags)
 144
 145     varAddr = mem[HERE] + 1
 146     push!(primitives, eval(:(() -> begin
 147         pushPS($(varAddr))
 148         return mem[NEXT]
 149     end)))
 150     mem[mem[HERE]] = -length(primitives); mem[HERE] += 1
 151
 152     mem[mem[HERE]] = initial; mem[HERE] += 1
 153
 154     return varAddr
 155 end
 156
 157 function defConst(name::AbstractString, val::Int64; flags::Int64=0)
 158     defPrim(name, eval(:(() -> begin
 159         pushPS($(val))
 160         return mem[NEXT]
 161     end)))
 162
 163     return val
 164 end
 165
 166 function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0)
 167     createHeader(name, flags)
 168
 169     addr = mem[HERE]
 170     mem[mem[HERE]] = mem[DOCOL]
 171     mem[HERE] += 1
 172
 173     for wordAddr in wordAddrs
 174         mem[mem[HERE]] = wordAddr
 175         mem[HERE] += 1
 176     end
 177
 178     return addr
 179 end
 180
 181 # Threading Primitives (inner interpreter)
 182
 183 NEXT = defPrim("NEXT", () -> begin
 184     reg.W = mem[reg.IP]
 185     reg.IP += 1
 186     return mem[reg.W]
 187 end)
 188
 189 DOCOL = defPrim("DOCOL", () -> begin
 190     pushRS(reg.IP)
 191     reg.IP = reg.W + 1
 192     return mem[NEXT]
 193 end)
 194
 195 EXIT = defPrim("EXIT", () -> begin
 196     reg.IP = popRS()
 197     return mem[NEXT]
 198 end)
 199
 200 # Basic forth primitives
 201
 202 DROP = defPrim("DROP", () -> begin
 203     popPS()
 204     return mem[NEXT]
 205 end)
 206
 207 SWAP = defPrim("SWAP", () -> begin
 208     a = popPS()
 209     b = popPS()
 210     pushPS(a)
 211     pushPS(b)
 212     return mem[NEXT]
 213 end)
 214
 215 DUP = defPrim("DUP", () -> begin
 216     pushPS(mem[reg.PSP])
 217     return mem[NEXT]
 218 end)
 219
 220 OVER = defPrim("OVER", () -> begin
 221     ensurePSDepth(2)
 222     pushPS(mem[reg.PSP-1])
 223     return mem[NEXT]
 224 end)
 225
 226 ROT = defPrim("ROT", () -> begin
 227     a = popPS()
 228     b = popPS()
 229     c = popPS()
 230     pushPS(a)
 231     pushPS(c)
 232     pushPS(b)
 233     return mem[NEXT]
 234 end)
 235
 236 NROT = defPrim("-ROT", () -> begin
 237     a = popPS()
 238     b = popPS()
 239     c = popPS()
 240     pushPS(b)
 241     pushPS(a)
 242     pushPS(c)
 243     return mem[NEXT]
 244 end)
 245
 246 TWODROP = defPrim("2DROP", () -> begin
 247     popPS()
 248     popPS()
 249     return mem[NEXT]
 250 end)
 251
 252 TWODUP = defPrim("2DUP", () -> begin
 253     ensurePSDepth(2)
 254     a = mem[reg.PSP-1]
 255     b = mem[reg.PSP]
 256     pushPS(a)
 257     pushPS(b)
 258     return mem[NEXT]
 259 end)
 260
 261 TWOSWAP = defPrim("2SWAP", () -> begin
 262     a = popPS()
 263     b = popPS()
 264     c = popPS()
 265     d = popPS()
 266     pushPS(b)
 267     pushPS(a)
 268     pushPS(c)
 269     pushPS(d)
 270     return mem[NEXT]
 271 end)
 272
 273 QDUP = defPrim("?DUP", () -> begin
 274     ensurePSDepth(1)
 275     val = mem[reg.PSP]
 276     if val != 0
 277         pushPS(val)
 278     end
 279     return mem[NEXT]
 280 end)
 281
 282 INCR = defPrim("1+", () -> begin
 283     ensurePSDepth(1)
 284     mem[reg.PSP] += 1
 285     return mem[NEXT]
 286 end)
 287
 288 DECR = defPrim("1-", () -> begin
 289     ensurePSDepth(1)
 290     mem[reg.PSP] -= 1
 291     return mem[NEXT]
 292 end)
 293
 294 INCR2 = defPrim("2+", () -> begin
 295     ensurePSDepth(1)
 296     mem[reg.PSP] += 2
 297     return mem[NEXT]
 298 end)
 299
 300 DECR2 = defPrim("2-", () -> begin
 301     ensurePSDepth(1)
 302     mem[reg.PSP] -= 2
 303     return mem[NEXT]
 304 end)
 305
 306 ADD = defPrim("+", () -> begin
 307     b = popPS()
 308     a = popPS()
 309     pushPS(a+b)
 310     return mem[NEXT]
 311 end)
 312
 313 SUB = defPrim("-", () -> begin
 314     b = popPS()
 315     a = popPS()
 316     pushPS(a-b)
 317     return mem[NEXT]
 318 end)
 319
 320 MUL = defPrim("*", () -> begin
 321     b = popPS()
 322     a = popPS()
 323     pushPS(a*b)
 324     return mem[NEXT]
 325 end)
 326
 327 DIVMOD = defPrim("/MOD", () -> begin
 328     b = popPS()
 329     a = popPS()
 330     q,r = divrem(a,b)
 331     pushPS(r)
 332     pushPS(q)
 333     return mem[NEXT]
 334 end)
 335
 336 EQU = defPrim("=", () -> begin
 337     b = popPS()
 338     a = popPS()
 339     pushPS(a==b ? -1 : 0)
 340     return mem[NEXT]
 341 end)
 342
 343 NEQU = defPrim("<>", () -> begin
 344     b = popPS()
 345     a = popPS()
 346     pushPS(a!=b ? -1 : 0)
 347     return mem[NEXT]
 348 end)
 349
 350 LT = defPrim("<", () -> begin
 351     b = popPS()
 352     a = popPS()
 353     pushPS(a<b ? -1 : 0)
 354     return mem[NEXT]
 355 end)
 356
 357 GT = defPrim(">", () -> begin
 358     b = popPS()
 359     a = popPS()
 360     pushPS(a>b ? -1 : 0)
 361     return mem[NEXT]
 362 end)
 363
 364 LE = defPrim("<=", () -> begin
 365     b = popPS()
 366     a = popPS()
 367     pushPS(a<=b ? -1 : 0)
 368     return mem[NEXT]
 369 end)
 370
 371 GE = defPrim(">=", () -> begin
 372     b = popPS()
 373     a = popPS()
 374     pushPS(a>=b ? -1 : 0)
 375     return mem[NEXT]
 376 end)
 377
 378 ZEQU = defPrim("0=", () -> begin
 379     pushPS(popPS() == 0 ? -1 : 0)
 380     return mem[NEXT]
 381 end)
 382
 383 ZNEQU = defPrim("0<>", () -> begin
 384     pushPS(popPS() != 0 ? -1 : 0)
 385     return mem[NEXT]
 386 end)
 387
 388 ZLT = defPrim("0<", () -> begin
 389     pushPS(popPS() < 0 ? -1 : 0)
 390     return mem[NEXT]
 391 end)
 392
 393 ZGT = defPrim("0>", () -> begin
 394     pushPS(popPS() > 0 ? -1 : 0)
 395     return mem[NEXT]
 396 end)
 397
 398 ZLE = defPrim("0<=", () -> begin
 399     pushPS(popPS() <= 0 ? -1 : 0)
 400     return mem[NEXT]
 401 end)
 402
 403 ZGE = defPrim("0>=", () -> begin
 404     pushPS(popPS() >= 0 ? -1 : 0)
 405     return mem[NEXT]
 406 end)
 407
 408 AND = defPrim("AND", () -> begin
 409     b = popPS()
 410     a = popPS()
 411     pushPS(a & b)
 412     return mem[NEXT]
 413 end)
 414
 415 OR = defPrim("OR", () -> begin
 416     b = popPS()
 417     a = popPS()
 418     pushPS(a | b)
 419     return mem[NEXT]
 420 end)
 421
 422 XOR = defPrim("XOR", () -> begin
 423     b = popPS()
 424     a = popPS()
 425     pushPS(a $ b)
 426     return mem[NEXT]
 427 end)
 428
 429 INVERT = defPrim("INVERT", () -> begin
 430     pushPS(~popPS())
 431     return mem[NEXT]
 432 end)
 433
 434 # Literals
 435
 436 LIT = defPrim("LIT", () -> begin
 437     pushPS(mem[reg.IP])
 438     reg.IP += 1
 439     return mem[NEXT]
 440 end)
 441
 442 # Memory primitives
 443
 444 STORE = defPrim("!", () -> begin
 445     addr = popPS()
 446     dat = popPS()
 447     mem[addr] = dat
 448     return mem[NEXT]
 449 end)
 450
 451 FETCH = defPrim("@", () -> begin
 452     addr = popPS()
 453     pushPS(mem[addr])
 454     return mem[NEXT]
 455 end)
 456
 457 ADDSTORE = defPrim("+!", () -> begin
 458     addr = popPS()
 459     toAdd = popPS()
 460     mem[addr] += toAdd
 461     return mem[NEXT]
 462 end)
 463
 464 SUBSTORE = defPrim("-!", () -> begin
 465     addr = popPS()
 466     toSub = popPS()
 467     mem[addr] -= toSub
 468     return mem[NEXT]
 469 end)
 470
 471
 472 # Built-in variables
 473
 474 defExistingVar("HERE", HERE)
 475 defExistingVar("LATEST", LATEST)
 476 defExistingVar("PSP0", PSP0)
 477 defExistingVar("RSP0", RSP0)
 478 STATE = defNewVar("STATE", 0)
 479 BASE = defNewVar("BASE", 10)
 480
 481 # Constants
 482
 483 defConst("VERSION", 1)
 484 defConst("DOCOL", DOCOL)
 485 defConst("DICT", DICT)
 486 F_IMMED = defConst("F_IMMED", 128)
 487 F_HIDDEN = defConst("F_HIDDEN", 256)
 488 F_LENMASK = defConst("F_LENMASK", 127)
 489
 490 # Return Stack
 491
 492 TOR = defPrim(">R", () -> begin
 493     pushRS(popPS())
 494     return mem[NEXT]
 495 end)
 496
 497 FROMR = defPrim("R>", () -> begin
 498     pushPS(popRS())
 499     return mem[NEXT]
 500 end)
 501
 502 RSPFETCH = defPrim("RSP@", () -> begin
 503     pushPS(reg.RSP)
 504     return mem[NEXT]
 505 end)
 506
 507 RSPSTORE = defPrim("RSP!", () -> begin
 508     RSP = popPS()
 509     return mem[NEXT]
 510 end)
 511
 512 RDROP = defPrim("RDROP", () -> begin
 513     popRS()
 514     return mem[NEXT]
 515 end)
 516
 517 # Parameter Stack
 518
 519 PSPFETCH = defPrim("PSP@", () -> begin
 520     pushPS(reg.PSP)
 521     return mem[NEXT]
 522 end)
 523
 524 PSPSTORE = defPrim("PSP!", () -> begin
 525     PSP = popPS()
 526     return mem[NEXT]
 527 end)
 528
 529 # I/O
 530
 531 defConst("TIB", TIB)
 532 NUMTIB = defNewVar("#TIB", 0)
 533 TOIN = defNewVar(">IN", 0)
 534
 535 KEY = defPrim("KEY", () -> begin
 536     if mem[TOIN] >= mem[NUMTIB]
 537         mem[TOIN] = 0
 538         line = readline()
 539         mem[NUMTIB] = length(line)
 540         putString(line, TIB)
 541     end
 542
 543     pushPS(mem[TIB + mem[TOIN]])
 544     mem[TOIN] += 1
 545
 546     return mem[NEXT]
 547 end)
 548
 549 EMIT = defPrim("EMIT", () -> begin
 550     print(Char(popPS()))
 551     return mem[NEXT]
 552 end)
 553
 554 WORD = defPrim("WORD", () -> begin
 555
 556     c = -1
 557
 558     skip_to_end = false
 559     while true
 560
 561         callPrim(mem[KEY])
 562         c = Char(popPS())
 563
 564         if c == '\\'
 565             skip_to_end = true
 566             continue
 567         end
 568
 569         if skip_to_end
 570             if c == '\n'
 571                 skip_to_end = false
 572             end
 573             continue
 574         end
 575
 576         if c == ' ' || c == '\t'
 577             continue
 578         end
 579
 580         break
 581     end
 582
 583     wordAddr = mem[HERE]
 584     offset = 0
 585
 586     while true
 587         mem[wordAddr + offset] = Int64(c)
 588         offset += 1
 589
 590         callPrim(mem[KEY])
 591         c = Char(popPS())
 592
 593         if c == ' ' || c == '\t' || c == '\n'
 594             break
 595         end
 596     end
 597
 598     wordLen = offset
 599
 600     pushPS(wordAddr)
 601     pushPS(wordLen)
 602
 603     return mem[NEXT]
 604 end)
 605
 606 NUMBER = defPrim("NUMBER", () -> begin
 607
 608     wordLen = popPS()
 609     wordAddr = popPS()
 610
 611     s = getString(wordAddr, wordLen)
 612
 613     try
 614         pushPS(parse(Int64, s, mem[BASE]))
 615         pushPS(0)
 616     catch
 617         pushPS(1) # Error indication
 618     end
 619
 620     return mem[NEXT]
 621 end)
 622
 623 # Dictionary searches
 624
 625 FIND = defPrim("FIND", () -> begin
 626
 627     wordLen = popPS()
 628     wordAddr = popPS()
 629     word = getString(wordAddr, wordLen)
 630
 631     latest = LATEST
 632
 633     i = 0
 634     while (latest = mem[latest]) > 0
 635         lenAndFlags = mem[latest+1]
 636         len = lenAndFlags & F_LENMASK
 637         hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN
 638
 639         if hidden || len != wordLen
 640             continue
 641         end
 642
 643         thisAddr = latest+2
 644         thisWord = getString(thisAddr, len)
 645
 646         if thisWord == word
 647             break
 648         end
 649     end
 650
 651     pushPS(latest)
 652
 653     return mem[NEXT]
 654 end)
 655
 656 TOCFA = defPrim(">CFA", () -> begin
 657
 658     addr = popPS()
 659     lenAndFlags = mem[addr+1]
 660     len = lenAndFlags & F_LENMASK
 661
 662     pushPS(addr + 2 + len)
 663
 664     return mem[NEXT]
 665 end)
 666
 667 TODFA = defWord(">DFA", [TOCFA, INCR, EXIT])
 668
 669 # Compilation
 670
 671 CREATE = defPrim("CREATE", () -> begin
 672
 673     wordLen = popPS()
 674     wordAddr = popPS()
 675     word = getString(wordAddr, wordLen)
 676
 677     createHeader(word, 0)
 678
 679     return mem[NEXT]
 680 end)
 681
 682 COMMA = defPrim(",", () -> begin
 683     mem[mem[HERE]] = popPS()
 684     mem[HERE] += 1
 685
 686     return mem[NEXT]
 687 end)
 688
 689 LBRAC = defPrim("[", () -> begin
 690     mem[STATE] = 0
 691     return mem[NEXT]
 692 end, flags=F_IMMED)
 693
 694 RBRAC = defPrim("]", () -> begin
 695     mem[STATE] = 1
 696     return mem[NEXT]
 697 end, flags=F_IMMED)
 698
 699 HIDDEN = defPrim("HIDDEN", () -> begin
 700     addr = popPS() + 1
 701     mem[addr] = mem[addr] $ F_HIDDEN
 702     return mem[NEXT]
 703 end)
 704
 705 HIDE = defWord("HIDE",
 706     [WORD,
 707     FIND,
 708     HIDDEN,
 709     EXIT])
 710
 711 COLON = defWord(":",
 712     [WORD,
 713     CREATE,
 714     LIT, DOCOL, COMMA,
 715     LATEST, FETCH, HIDDEN,
 716     RBRAC,
 717     EXIT])
 718
 719 SEMICOLON = defWord(";",
 720     [LIT, EXIT, COMMA,
 721     LATEST, FETCH, HIDDEN,
 722     LBRAC,
 723     EXIT], flags=F_IMMED)
 724
 725 IMMEDIATE = defPrim("IMMEDIATE", () -> begin
 726     lenAndFlagsAddr = mem[LATEST] + 1
 727     mem[lenAndFlagsAddr] = mem[lenAndFlagsAddr] $ F_IMMED
 728     return mem[NEXT]
 729 end, flags=F_IMMED)
 730
 731 TICK = defWord("'", [WORD, FIND, TOCFA, EXIT])
 732
 733 # Branching
 734
 735 BRANCH = defPrim("BRANCH", () -> begin
 736     reg.IP += mem[reg.IP]
 737     return mem[NEXT]
 738 end)
 739
 740 ZBRANCH = defPrim("0BRANCH", () -> begin
 741     if (popPS() == 0)
 742         reg.IP += mem[reg.IP]
 743     else
 744         reg.IP += 1
 745     end
 746
 747     return mem[NEXT]
 748 end)
 749
 750 # Strings
 751
 752 LITSTRING = defPrim("LITSTRING", () -> begin
 753     len = mem[reg.IP]
 754     reg.IP += 1
 755     pushPS(reg.IP)
 756     pushPS(len)
 757     reg.IP += len
 758
 759     return mem[NEXT]
 760 end)
 761
 762 #### VM loop ####
 763 function runVM()
 764     jmp = mem[NEXT]
 765     while (jmp = callPrim(jmp)) != 0 end
 766 end
 767
 768 # Debugging tools
 769
 770 function dump(startAddr::Int64; count::Int64 = 100, cellsPerLine::Int64 = 10)
 771     chars = Array{Char,1}(cellsPerLine)
 772
 773     lineStartAddr = cellsPerLine*div((startAddr-1),cellsPerLine) + 1
 774     endAddr = startAddr + count - 1
 775
 776     q, r = divrem((endAddr-lineStartAddr+1), cellsPerLine)
 777     numLines = q + (r > 0 ? 1 : 0)
 778
 779     i = lineStartAddr
 780     for l in 1:numLines
 781         print(i,":")
 782
 783         for c in 1:cellsPerLine
 784             if i >= startAddr && i <= endAddr
 785                 print("\t",mem[i])
 786                 if mem[i]>=32 && mem[i]<128
 787                     chars[c] = Char(mem[i])
 788                 else
 789                     chars[c] = '.'
 790                 end
 791             else
 792                 print("\t")
 793                 chars[c] = ' '
 794             end
 795
 796             i += 1
 797         end
 798
 799         println("\t", ASCIIString(chars))
 800     end
 801 end
 802
 803 function printPS()
 804     count = reg.PSP - mem[PSP0]
 805
 806     if count > 0
 807         print("<$count>")
 808         for i in (mem[PSP0]+1):reg.PSP
 809             print(" $(mem[i])")
 810         end
 811         println()
 812     else
 813         println("Parameter stack empty")
 814     end
 815 end
 816
 817 function printRS()
 818     count = reg.RSP - mem[RSP0]
 819
 820     if count > 0
 821         print("<$count>")
 822         for i in (mem[RSP0]+1):reg.RSP
 823             print(" $(mem[i])")
 824         end
 825         println()
 826     else
 827         println("Return stack empty")
 828     end
 829 end
 830
 831 end