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