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