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     push!(primitives, f)
 119     mem[mem[HERE]] = -length(primitives)
 120     mem[HERE] += 1
 121
 122     return -length(primitives)
 123 end
 124
 125 callPrim(addr::Int64) = primitives[-addr]()
 126
 127 function defExistingVar(name::AbstractString, varAddr::Int64; flags::Int64=0)
 128     defPrim(name, eval(:(() -> begin
 129         pushPS($(varAddr))
 130         return NEXT
 131     end)))
 132 end
 133
 134 function defNewVar(name::AbstractString, initial::Int64; flags::Int64=0)
 135     createHeader(name, flags)
 136
 137     varAddr = mem[HERE] + 1
 138     push!(primitives, eval(:(() -> begin
 139         pushPS($(varAddr))
 140         return NEXT
 141     end)))
 142     mem[mem[HERE]] = -length(primitives); mem[HERE] += 1
 143
 144     mem[mem[HERE]] = initial; mem[HERE] += 1
 145
 146     return varAddr
 147 end
 148
 149 function defConst(name::AbstractString, val::Int64; flags::Int64=0)
 150     defPrim(name, eval(:(() -> begin
 151         pushPS($(val))
 152         return NEXT
 153     end)))
 154
 155     return val
 156 end
 157
 158 function defWord(name::AbstractString, wordAddrs::Array{Int64,1}; flags::Int64=0)
 159     createHeader(name, flags)
 160
 161     mem[mem[HERE]] = DOCOL
 162     mem[HERE] += 1
 163
 164     for wordAddr in wordAddrs
 165         mem[mem[HERE]] = wordAddr
 166         mem[HERE] += 1
 167     end
 168 end
 169
 170 # Threading Primitives
 171
 172 NEXT = defPrim("NEXT", () -> begin
 173     reg.W = mem[reg.IP]
 174     reg.IP += 1
 175     X = mem[reg.W]
 176     return X
 177 end)
 178
 179 DOCOL = defPrim("DOCOL", () -> begin
 180     pushRS(reg.IP)
 181     reg.IP = reg.W + 1
 182     return NEXT
 183 end)
 184
 185 EXIT = defPrim("EXIT", () -> begin
 186     reg.IP = popRS()
 187     return NEXT
 188 end)
 189
 190
 191 # Basic forth primitives
 192
 193 DROP = defPrim("DROP", () -> begin
 194     popPS()
 195     return NEXT
 196 end)
 197
 198 SWAP = defPrim("SWAP", () -> begin
 199     a = popPS()
 200     b = popPS()
 201     pushPS(a)
 202     pushPS(b)
 203     return NEXT
 204 end)
 205
 206 DUP = defPrim("DUP", () -> begin
 207     pushPS(mem[reg.PSP])
 208     return NEXT
 209 end)
 210
 211 OVER = defPrim("OVER", () -> begin
 212     ensurePSDepth(2)
 213     pushPS(mem[reg.PSP-1])
 214     return NEXT
 215 end)
 216
 217 ROT = defPrim("ROT", () -> begin
 218     a = popPS()
 219     b = popPS()
 220     c = popPS()
 221     pushPS(a)
 222     pushPS(c)
 223     pushPS(b)
 224     return NEXT
 225 end)
 226
 227 NROT = defPrim("-ROT", () -> begin
 228     a = popPS()
 229     b = popPS()
 230     c = popPS()
 231     pushPS(b)
 232     pushPS(a)
 233     pushPS(c)
 234     return NEXT
 235 end)
 236
 237 TWODROP = defPrim("2DROP", () -> begin
 238     popPS()
 239     popPS()
 240     return NEXT
 241 end)
 242
 243 TWODUP = defPrim("2DUP", () -> begin
 244     ensurePSDepth(2)
 245     a = mem[reg.PSP-1]
 246     b = mem[reg.PSP]
 247     pushPS(a)
 248     pushPS(b)
 249     return NEXT
 250 end)
 251
 252 TWOSWAP = defPrim("2SWAP", () -> begin
 253     a = popPS()
 254     b = popPS()
 255     c = popPS()
 256     d = popPS()
 257     pushPS(b)
 258     pushPS(a)
 259     pushPS(c)
 260     pushPS(d)
 261     return NEXT
 262 end)
 263
 264 QDUP = defPrim("?DUP", () -> begin
 265     ensurePSDepth(1)
 266     val = mem[reg.PSP]
 267     if val != 0
 268         pushPS(val)
 269     end
 270     return NEXT
 271 end)
 272
 273 INCR = defPrim("1+", () -> begin
 274     ensurePSDepth(1)
 275     mem[reg.PSP] += 1
 276     return NEXT
 277 end)
 278
 279 DECR = defPrim("1-", () -> begin
 280     ensurePSDepth(1)
 281     mem[reg.PSP] -= 1
 282     return NEXT
 283 end)
 284
 285 ADD = defPrim("+", () -> begin
 286     a = popPS()
 287     b = popPS()
 288     pushPS(a+b)
 289     return NEXT
 290 end)
 291
 292 SUB = defPrim("-", () -> begin
 293     a = popPS()
 294     b = popPS()
 295     pushPS(b-a)
 296     return NEXT
 297 end)
 298
 299 MUL = defPrim("*", () -> begin
 300     a = popPS()
 301     b = popPS()
 302     pushPS(a*b)
 303     return NEXT
 304 end)
 305
 306 DIVMOD = defPrim("/MOD", () -> begin
 307     a = popPS()
 308     b = popPS()
 309     q,r = divrem(b,a)
 310     pushPS(r)
 311     pushPS(q)
 312     return NEXT
 313 end)
 314
 315 LIT = defPrim("LIT", () -> begin
 316     pushPS(mem[reg.IP])
 317     reg.IP += 1
 318     return NEXT
 319 end)
 320
 321 # Memory primitives
 322
 323 STORE = defPrim("!", () -> begin
 324     addr = popPS()
 325     dat = popPS()
 326     mem[addr] = dat
 327     return NEXT
 328 end)
 329
 330 FETCH = defPrim("@", () -> begin
 331     addr = popPS()
 332     pushPS(mem[addr])
 333     return NEXT
 334 end)
 335
 336 ADDSTORE = defPrim("+!", () -> begin
 337     addr = popPS()
 338     toAdd = popPS()
 339     mem[addr] += toAdd
 340     return NEXT
 341 end)
 342
 343 SUBSTORE = defPrim("-!", () -> begin
 344     addr = popPS()
 345     toSub = popPS()
 346     mem[addr] -= toSub
 347     return NEXT
 348 end)
 349
 350
 351 # Built-in variables
 352
 353 defExistingVar("HERE", HERE)
 354 defExistingVar("LATEST", LATEST)
 355 defExistingVar("PSP0", PSP0)
 356 defExistingVar("RSP0", RSP0)
 357 STATE = defNewVar("STATE", 0)
 358 BASE = defNewVar("BASE", 10)
 359
 360 # Constants
 361
 362 defConst("VERSION", 1)
 363 defConst("DOCOL", DOCOL)
 364 defConst("DICT", DICT)
 365 F_IMMED = defConst("F_IMMED", 128)
 366 F_HIDDEN = defConst("F_HIDDEN", 256)
 367 F_LENMASK = defConst("F_LENMASK", 127)
 368
 369 # Return Stack
 370
 371 TOR = defPrim(">R", () -> begin
 372     pushRS(popPS())
 373     return NEXT
 374 end)
 375
 376 FROMR = defPrim("R>", () -> begin
 377     pushPS(popRS())
 378     return NEXT
 379 end)
 380
 381 RSPFETCH = defPrim("RSP@", () -> begin
 382     pushPS(reg.RSP)
 383     return NEXT
 384 end)
 385
 386 RSPSTORE = defPrim("RSP!", () -> begin
 387     RSP = popPS()
 388     return NEXT
 389 end)
 390
 391 RDROP = defPrim("RDROP", () -> begin
 392     popRS()
 393     return NEXT
 394 end)
 395
 396 # Parameter Stack
 397
 398 PSPFETCH = defPrim("PSP@", () -> begin
 399     pushPS(reg.PSP)
 400     return NEXT
 401 end)
 402
 403 PSPSTORE = defPrim("PSP!", () -> begin
 404     PSP = popPS()
 405     return NEXT
 406 end)
 407
 408 # I/O
 409
 410 defConst("TIB", TIB)
 411 NUMTIB = defNewVar("#TIB", 0)
 412 TOIN = defNewVar(">IN", 0)
 413
 414 KEY = defPrim("KEY", () -> begin
 415     if mem[TOIN] >= mem[NUMTIB]
 416         mem[TOIN] = 0
 417         line = readline()
 418         mem[NUMTIB] = length(line)
 419         mem[TIB:(TIB+mem[NUMTIB]-1)] = [Int64(c) for c in collect(line)]
 420     end
 421
 422     pushPS(mem[TIB + mem[TOIN]])
 423     mem[TOIN] += 1
 424
 425     return NEXT
 426 end)
 427
 428 EMIT = defPrim("EMIT", () -> begin
 429     print(Char(popPS()))
 430     return NEXT
 431 end)
 432
 433 WORD = defPrim("WORD", () -> begin
 434
 435     c = -1
 436
 437     skip_to_end = false
 438     while true
 439
 440         callPrim(KEY)
 441         c = Char(popPS())
 442
 443         if c == '\\'
 444             skip_to_end = true
 445             continue
 446         end
 447
 448         if skip_to_end
 449             if c == '\n'
 450                 skip_to_end = false
 451             end
 452             continue
 453         end
 454
 455         if c == ' ' || c == '\t'
 456             continue
 457         end
 458
 459         break
 460     end
 461
 462     wordAddr = mem[HERE]
 463     offset = 0
 464
 465     while true
 466         mem[wordAddr + offset] = Int64(c)
 467         offset += 1
 468
 469         callPrim(KEY)
 470         c = Char(popPS())
 471
 472         if c == ' ' || c == '\t' || c == '\n'
 473             break
 474         end
 475     end
 476
 477     wordLen = offset
 478
 479     pushPS(wordAddr)
 480     pushPS(wordLen)
 481
 482     return NEXT
 483 end)
 484
 485 NUMBER = defPrim("NUMBER", () -> begin
 486
 487     wordLen = popPS()
 488     wordAddr = popPS()
 489
 490     s = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]])
 491
 492     try
 493         pushPS(parse(Int64, s, mem[BASE]))
 494         pushPS(0)
 495     catch
 496         pushPS(1) # Error indication
 497     end
 498
 499     return NEXT
 500 end)
 501
 502 # Dictionary searches
 503
 504 FIND = defPrim("FIND", () -> begin
 505
 506     wordLen = popPS()
 507     wordAddr = popPS()
 508     word = ASCIIString([Char(c) for c in mem[wordAddr:(wordAddr+wordLen-1)]])
 509
 510     latest = mem[LATEST]
 511
 512     while latest>0
 513         lenAndFlags = mem[latest+1]
 514         len = lenAndFlags & F_LENMASK
 515         hidden = (lenAndFlags & F_HIDDEN) == F_HIDDEN
 516
 517         if hidden || len != wordLen
 518             latest = mem[latest]
 519             continue
 520         end
 521
 522         thisAddr = latest+2
 523         thisWord = ASCIIString([Char(c) for c in mem[thisAddr:(thisAddr+len-1)]])
 524
 525         if thisWord == word
 526             break
 527         end
 528     end
 529
 530     pushPS(latest)
 531
 532     return NEXT
 533 end)
 534
 535 TOCFA = defPrim(">CFA", () -> begin
 536
 537     addr = popPS()
 538     lenAndFlags = mem[addr+1]
 539     len = lenAndFlags & F_LENMASK
 540
 541     pushPS(addr + 2 + len)
 542
 543     return NEXT
 544 end)
 545
 546 TODFA = defWord(">DFA", [TOCFA, INCR1, EXIT])
 547
 548 #### VM loop ####
 549 #function runVM(reg::Reg)
 550 #    jmp = NEXT
 551 #    while (jmp = callPrim(reg, jmp)) != 0 end
 552 #end
 553
 554 # Debugging tools
 555
 556 function coredump(startAddr::Int64; count::Int64 = 16, cellsPerLine::Int64 = 8)
 557     chars = Array{Char,1}(cellsPerLine)
 558
 559     for i in 0:(count-1)
 560         addr = startAddr + i
 561         if i%cellsPerLine == 0
 562             print("$addr:")
 563         end
 564
 565         print("\t$(mem[addr]) ")
 566
 567         if (mem[addr]>=32 && mem[addr]<176)
 568             chars[i%cellsPerLine + 1] = Char(mem[addr])
 569         else
 570             chars[i%cellsPerLine + 1] = '.'
 571         end
 572
 573         if i%cellsPerLine == cellsPerLine-1
 574             println(string("\t", ASCIIString(chars)))
 575         end
 576     end
 577 end
 578
 579 function printPS()
 580     count = reg.PSP - mem[PSP0]
 581
 582     if count > 0
 583         print("<$count>")
 584         for i in (mem[PSP0]+1):reg.PSP
 585             print(" $(mem[i])")
 586         end
 587         println()
 588     else
 589         println("Parameter stack empty")
 590     end
 591 end
 592
 593 end